From 5143129baac805d3a49ac3ee9f3344c7a447634f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 30 Oct 2016 17:53:07 +0100 Subject: Termops API using EConstr. --- pretyping/cases.ml | 89 ++++++++++++++++++++++---------------------- pretyping/coercion.ml | 2 +- pretyping/constr_matching.ml | 20 +++++----- pretyping/detyping.ml | 32 ++++++++-------- pretyping/evarconv.ml | 23 ++++++------ pretyping/evarsolve.ml | 71 ++++++++++++++++++----------------- pretyping/evarsolve.mli | 4 +- pretyping/pretyping.ml | 4 +- pretyping/recordops.ml | 6 +-- pretyping/recordops.mli | 2 +- pretyping/reductionops.ml | 41 ++++++++++---------- pretyping/reductionops.mli | 2 +- pretyping/retyping.ml | 17 +++++---- pretyping/tacred.ml | 14 +++---- pretyping/unification.ml | 46 +++++++++++------------ 15 files changed, 190 insertions(+), 183 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d5b125135e..6b480986c7 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -535,19 +535,19 @@ let dependencies_in_pure_rhs nargs eqns = let deps_columns = matrix_transpose deps_rows in List.map (List.exists (fun x -> x)) deps_columns -let dependent_decl a = +let dependent_decl sigma a = function - | LocalAssum (na,t) -> dependent a t - | LocalDef (na,c,t) -> dependent a t || dependent a c + | LocalAssum (na,t) -> dependent sigma (EConstr.of_constr a) (EConstr.of_constr t) + | LocalDef (na,c,t) -> dependent sigma (EConstr.of_constr a) (EConstr.of_constr t) || dependent sigma (EConstr.of_constr a) (EConstr.of_constr c) -let rec dep_in_tomatch n = function - | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch n l - | Abstract (_,d) :: l -> dependent_decl (mkRel n) d || dep_in_tomatch (n+1) l +let rec dep_in_tomatch sigma n = function + | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch sigma n l + | Abstract (_,d) :: l -> dependent_decl sigma (mkRel n) d || dep_in_tomatch sigma (n+1) l | [] -> false -let dependencies_in_rhs nargs current tms eqns = +let dependencies_in_rhs sigma nargs current tms eqns = match kind_of_term current with - | Rel n when dep_in_tomatch n tms -> List.make nargs true + | Rel n when dep_in_tomatch sigma n tms -> List.make nargs true | _ -> dependencies_in_pure_rhs nargs eqns (* Computing the matrix of dependencies *) @@ -562,24 +562,24 @@ let dependencies_in_rhs nargs current tms eqns = [n-2;1], [1] points to [dn] and [n-2] to [d3] *) -let rec find_dependency_list tmblock = function +let rec find_dependency_list sigma tmblock = function | [] -> [] | (used,tdeps,d)::rest -> - let deps = find_dependency_list tmblock rest in - if used && List.exists (fun x -> dependent_decl x d) tmblock + let deps = find_dependency_list sigma tmblock rest in + if used && List.exists (fun x -> dependent_decl sigma x d) tmblock then List.add_set Int.equal (List.length rest + 1) (List.union Int.equal deps tdeps) else deps -let find_dependencies is_dep_or_cstr_in_rhs (tm,(_,tmtypleaves),d) nextlist = - let deps = find_dependency_list (tm::tmtypleaves) nextlist in +let find_dependencies sigma is_dep_or_cstr_in_rhs (tm,(_,tmtypleaves),d) nextlist = + let deps = find_dependency_list sigma (tm::tmtypleaves) nextlist in if is_dep_or_cstr_in_rhs || not (List.is_empty deps) then ((true ,deps,d)::nextlist) else ((false,[] ,d)::nextlist) -let find_dependencies_signature deps_in_rhs typs = - let l = List.fold_right2 find_dependencies deps_in_rhs typs [] in +let find_dependencies_signature sigma deps_in_rhs typs = + let l = List.fold_right2 (find_dependencies sigma) deps_in_rhs typs [] in List.map (fun (_,deps,_) -> deps) l (* Assume we had terms t1..tq to match in a context xp:Tp,...,x1:T1 |- @@ -1095,30 +1095,30 @@ let rec ungeneralize n ng body = let ungeneralize_branch n k (sign,body) cs = (sign,ungeneralize (n+cs.cs_nargs) k body) -let rec is_dependent_generalization ng body = +let rec is_dependent_generalization sigma ng body = match kind_of_term body with | Lambda (_,_,c) when Int.equal ng 0 -> - dependent (mkRel 1) c + not (EConstr.Vars.noccurn sigma 1 (EConstr.of_constr c)) | Lambda (na,t,c) -> (* We traverse an inner generalization *) - is_dependent_generalization (ng-1) c + is_dependent_generalization sigma (ng-1) c | LetIn (na,b,t,c) -> (* We traverse an alias *) - is_dependent_generalization ng c + is_dependent_generalization sigma ng c | Case (ci,p,c,brs) -> (* We traverse a split *) Array.exists2 (fun q c -> let _,b = decompose_lam_n_decls q c in - is_dependent_generalization ng b) + is_dependent_generalization sigma ng b) ci.ci_cstr_ndecls brs | App (g,args) -> (* We traverse an inner generalization *) assert (isCase g); - is_dependent_generalization (ng+Array.length args) g + is_dependent_generalization sigma (ng+Array.length args) g | _ -> assert false -let is_dependent_branch k (_,br) = - is_dependent_generalization k br +let is_dependent_branch sigma k (_,br) = + is_dependent_generalization sigma k br let postprocess_dependencies evd tocheck brs tomatch pred deps cs = let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with @@ -1126,8 +1126,8 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = | n::deps, Abstract (i,d) :: tomatch -> let d = map_constr (nf_evar evd) d in let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in - if is_d || List.exists (fun c -> dependent_decl (lift k c) d) tocheck - && Array.exists (is_dependent_branch k) brs then + if is_d || List.exists (fun c -> dependent_decl evd (lift k c) d) tocheck + && Array.exists (is_dependent_branch evd k) brs then (* Dependency in the current term to match and its dependencies is real *) let brs,tomatch,pred,inst = aux (k+1) brs tomatch pred (mkRel n::tocheck) deps in let inst = match d with @@ -1249,8 +1249,8 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* We compute over which of x(i+1)..xn and x matching on xi will need a *) (* generalization *) let dep_sign = - find_dependencies_signature - (dependencies_in_rhs const_info.cs_nargs current pb.tomatch eqns) + find_dependencies_signature !(pb.evdref) + (dependencies_in_rhs !(pb.evdref) const_info.cs_nargs current pb.tomatch eqns) (List.rev typs') in (* The dependent term to subst in the types of the remaining UnPushed @@ -1452,7 +1452,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = mat = List.map (push_alias_eqn alias) pb.mat } in let j = compile pb in { uj_val = - if isRel c || isVar c || count_occurrences (mkRel 1) j.uj_val <= 1 then + if isRel c || isVar c || count_occurrences !(pb.evdref) (EConstr.mkRel 1) (EConstr.of_constr j.uj_val) <= 1 then subst1 c j.uj_val else mkLetIn (na,c,t,j.uj_val); @@ -1561,7 +1561,7 @@ let matx_of_eqns env eqns = returning True never happens and any inhabited type can be put instead). *) -let adjust_to_extended_env_and_remove_deps env extenv subst t = +let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = let n = Context.Rel.length (rel_context env) in let n' = Context.Rel.length (rel_context extenv) in (* We first remove the bindings that are dependently typed (they are @@ -1583,7 +1583,7 @@ let adjust_to_extended_env_and_remove_deps env extenv subst t = | LocalAssum _ -> p in let p = traverse_local_defs p in let u = lift (n' - n) u in - try Some (p, u, expand_vars_in_term extenv u) + try Some (p, u, expand_vars_in_term extenv sigma u) (* pedrot: does this really happen to raise [Failure _]? *) with Failure _ -> None in let subst0 = List.map_filter map subst in @@ -1617,7 +1617,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = let src = match kind_of_term t with | Evar (evk,_) -> (loc,Evar_kinds.SubEvar evk) | _ -> (loc,Evar_kinds.CasesType true) in - let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv subst t in + let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv !evdref subst t in (* We traverse the type T of the original problem Xi looking for subterms that match the non-constructor part of the constraints (this part is in subst); these subterms are the "good" subterms and we replace them @@ -1644,7 +1644,8 @@ let abstract_tycon loc env evdref subst tycon extenv t = let good = List.filter (fun (_,u,_) -> is_conv_leq env !evdref t u) subst in match good with | [] -> - map_constr_with_full_binders push_binder aux x t + let self env c = EConstr.of_constr (aux env (EConstr.Unsafe.to_constr c)) in + EConstr.Unsafe.to_constr (map_constr_with_full_binders !evdref push_binder self x (EConstr.of_constr t)) | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = @@ -1652,16 +1653,16 @@ let abstract_tycon loc env evdref subst tycon extenv t = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in let ty = lift (-k) (aux x ty) in - let depvl = free_rels ty in + let depvl = free_rels !evdref (EConstr.of_constr ty) in let inst = List.map_i (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 (rel_context extenv) in let rel_filter = - List.map (fun a -> not (isRel a) || dependent a u + List.map (fun a -> not (isRel a) || dependent !evdref (EConstr.of_constr a) (EConstr.of_constr u) || Int.Set.mem (destRel a) depvl) inst in let named_filter = - List.map (fun d -> dependent (mkVar (NamedDecl.get_id d)) u) + List.map (fun d -> local_occur_var !evdref (NamedDecl.get_id d) (EConstr.of_constr u)) (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in @@ -1753,7 +1754,7 @@ let build_inversion_problem loc env sigma tms t = List.map (fun (c,d) -> (c,extract_inductive_data pb_env sigma d,d)) decls in let decls = List.rev decls in - let dep_sign = find_dependencies_signature (List.make n true) decls in + let dep_sign = find_dependencies_signature sigma (List.make n true) decls in let sub_tms = List.map2 (fun deps (tm, (tmtyp,_), decl) -> @@ -1878,7 +1879,7 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in match kind_of_term tm with - | Rel n when dependent tm c + | Rel n when dependent sigma (EConstr.of_constr tm) (EConstr.of_constr c) && Int.equal signlen 1 (* The term to match is not of a dependent type itself *) -> ((n, len) :: subst, len - signlen) | Rel n when signlen > 1 (* The term is of a dependent type, @@ -1890,13 +1891,13 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = List.fold_left (fun (subst, len) arg -> match kind_of_term arg with - | Rel n when dependent arg c -> + | Rel n when dependent sigma (EConstr.of_constr arg) (EConstr.of_constr c) -> ((n, len) :: subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs in let subst = - if dependent tm c && List.for_all isRel realargs + if dependent sigma (EConstr.of_constr tm) (EConstr.of_constr c) && List.for_all isRel realargs then (n, len) :: subst else subst in (subst, pred len)) | _ -> (subst, len - signlen)) @@ -2279,7 +2280,7 @@ let lift_ctx n ctx = in ctx' (* Turn matched terms into variables. *) -let abstract_tomatch env tomatchs tycon = +let abstract_tomatch env sigma tomatchs tycon = let prev, ctx, names, tycon = List.fold_left (fun (prev, ctx, names, tycon) (c, t) -> @@ -2288,7 +2289,7 @@ let abstract_tomatch env tomatchs tycon = Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon | _ -> let tycon = Option.map - (fun t -> subst_term (lift 1 c) (lift 1 t)) tycon in + (fun t -> subst_term sigma (EConstr.of_constr (lift 1 c)) (EConstr.of_constr (lift 1 t))) tycon in let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, @@ -2406,7 +2407,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_function evdref env matx tomatchl in let tycon = valcon_of_tycon tycon in - let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env tomatchs tycon in + let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env !evdref tomatchs tycon in let env = push_rel_context tomatchs_lets env in let len = List.length eqns in let sign, allnames, signlen, eqs, neqs, args = @@ -2460,7 +2461,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env List.map (fun (c,d) -> (c,extract_inductive_data env !evdref d,d)) typs in let dep_sign = - find_dependencies_signature + find_dependencies_signature !evdref (List.make (List.length typs) true) typs in @@ -2535,7 +2536,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e List.map (fun (c,d) -> (c,extract_inductive_data env sigma d,d)) typs in let dep_sign = - find_dependencies_signature + find_dependencies_signature !evdref (List.make (List.length typs) true) typs in diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 2b860ae9c5..a3970fc0f3 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -487,7 +487,7 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let v1 = Option.get v1 in let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in let t2 = match v2 with - | None -> subst_term v1 t2 + | None -> subst_term evd' (EConstr.of_constr v1) (EConstr.of_constr t2) | Some v2 -> Retyping.get_type_of env1 evd' v2 in let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 5ec44a68d8..d7b73d3339 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -79,7 +79,7 @@ let add_binders na1 na2 binding_vars (names, terms as subst) = (names, terms) | _ -> subst -let rec build_lambda vars ctx m = match vars with +let rec build_lambda sigma vars ctx m = match vars with | [] -> let len = List.length ctx in lift (-1 * len) m @@ -100,12 +100,12 @@ let rec build_lambda vars ctx m = match vars with let map i = if i > n then pred i else i in let vars = List.map map vars in (** Check that the abstraction is legal *) - let frels = free_rels t in + let frels = free_rels sigma (EConstr.of_constr t) in let brels = List.fold_right Int.Set.add vars Int.Set.empty in let () = if not (Int.Set.subset frels brels) then raise PatternMatchingFailure in (** Create the abstraction *) let m = mkLambda (na, t, m) in - build_lambda vars (pre @ suf) m + build_lambda sigma vars (pre @ suf) m let rec extract_bound_aux k accu frels ctx = match ctx with | [] -> accu @@ -133,12 +133,12 @@ let make_renaming ids = function end | _ -> dummy_constr -let merge_binding allow_bound_rels ctx n cT subst = +let merge_binding sigma allow_bound_rels ctx n cT subst = let c = match ctx with | [] -> (* Optimization *) ([], cT) | _ -> - let frels = free_rels cT in + let frels = free_rels sigma (EConstr.of_constr cT) in if allow_bound_rels then let vars = extract_bound_vars frels ctx in let ordered_vars = Id.Set.elements vars in @@ -169,7 +169,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels else false) in let rec sorec ctx env subst p t = - let cT = strip_outer_cast t in + let cT = strip_outer_cast sigma (EConstr.of_constr t) in match p,kind_of_term cT with | PSoApp (n,args),m -> let fold (ans, seen) = function @@ -179,13 +179,13 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | _ -> error "Only bound indices allowed in second order pattern matching." in let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in - let frels = free_rels cT in + let frels = free_rels sigma (EConstr.of_constr cT) in if Int.Set.subset frels relset then - constrain n ([], build_lambda relargs ctx cT) subst + constrain n ([], build_lambda sigma relargs ctx cT) subst else raise PatternMatchingFailure - | PMeta (Some n), m -> merge_binding allow_bound_rels ctx n cT subst + | PMeta (Some n), m -> merge_binding sigma allow_bound_rels ctx n cT subst | PMeta None, m -> subst @@ -216,7 +216,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels let subst = match meta with | None -> subst - | Some n -> merge_binding allow_bound_rels ctx n c subst in + | Some n -> merge_binding sigma allow_bound_rels ctx n c subst in Array.fold_left2 (sorec ctx env) subst args1 args22 else (* Might be a projection on the right *) match kind_of_term c2 with diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index cad5551c15..72cf310100 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -215,11 +215,11 @@ let lookup_name_as_displayed env t s = | Prod (name,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' - | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop (EConstr.of_constr c'))) | LetIn (name,_,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' - | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop (EConstr.of_constr c'))) | Cast (c,_,_) -> lookup avoid n c | _ -> None in lookup (ids_of_named_context (named_context env)) 1 t @@ -261,13 +261,13 @@ let update_name na ((_,(e,_)),c) = | _ -> na -let rec decomp_branch tags nal b (avoid,env as e) c = +let rec decomp_branch tags nal b (avoid,env as e) sigma c = let flag = if b then RenamingForGoal else RenamingForCasesPattern (fst env,c) in match tags with | [] -> (List.rev nal,(e,c)) | b::tags -> let na,c,f,body,t = - match kind_of_term (strip_outer_cast c), b with + match kind_of_term (strip_outer_cast sigma (EConstr.of_constr c)), b with | Lambda (na,t,c),false -> na,c,compute_displayed_let_name_in,None,Some t | LetIn (na,b,t,c),true -> na,c,compute_displayed_name_in,Some b,Some t @@ -279,17 +279,17 @@ let rec decomp_branch tags nal b (avoid,env as e) c = in let na',avoid' = f flag avoid na c in decomp_branch tags (na'::nal) b - (avoid', add_name_opt na' body t env) c + (avoid', add_name_opt na' body t env) sigma c -let rec build_tree na isgoal e ci cl = +let rec build_tree na isgoal e sigma ci cl = let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name na rhs) in let cnl = ci.ci_pp_info.cstr_tags in let cna = ci.ci_cstr_nargs in List.flatten (List.init (Array.length cl) - (fun i -> contract_branch isgoal e (cnl.(i),cna.(i),mkpat i,cl.(i)))) + (fun i -> contract_branch isgoal e sigma (cnl.(i),cna.(i),mkpat i,cl.(i)))) -and align_tree nal isgoal (e,c as rhs) = match nal with +and align_tree nal isgoal (e,c as rhs) sigma = match nal with | [] -> [[],rhs] | na::nal -> match kind_of_term c with @@ -298,20 +298,20 @@ and align_tree nal isgoal (e,c as rhs) = match nal with && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> - let clauses = build_tree na isgoal e ci cl in + let clauses = build_tree na isgoal e sigma ci cl in List.flatten (List.map (fun (pat,rhs) -> - let lines = align_tree nal isgoal rhs in + let lines = align_tree nal isgoal rhs sigma in List.map (fun (hd,rest) -> pat::hd,rest) lines) clauses) | _ -> let pat = PatVar(dl,update_name na rhs) in - let mat = align_tree nal isgoal rhs in + let mat = align_tree nal isgoal rhs sigma in List.map (fun (hd,rest) -> pat::hd,rest) mat -and contract_branch isgoal e (cdn,can,mkpat,b) = - let nal,rhs = decomp_branch cdn [] isgoal e b in - let mat = align_tree nal isgoal rhs in +and contract_branch isgoal e sigma (cdn,can,mkpat,b) = + let nal,rhs = decomp_branch cdn [] isgoal e sigma b in + let mat = align_tree nal isgoal rhs sigma in List.map (fun (hd,rhs) -> (mkpat rhs hd,rhs)) mat (**********************************************************************) @@ -439,7 +439,7 @@ let detype_instance sigma l = else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) let rec detype flags avoid env sigma t = - match kind_of_term (collapse_appl t) with + match kind_of_term (collapse_appl sigma (EConstr.of_constr t)) with | Rel n -> (try match lookup_name_of_rel n (fst env) with | Name id -> GVar (dl, id) @@ -628,7 +628,7 @@ and share_names flags n l avoid env sigma c t = and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl = try if !Flags.raw_print || not (reverse_matching ()) then raise Exit; - let mat = build_tree Anonymous (snd flags) (avoid,env) ci bl in + let mat = build_tree Anonymous (snd flags) (avoid,env) sigma ci bl in List.map (fun (pat,((avoid,env),c)) -> (dl,[],[pat],detype flags avoid env sigma c)) mat with e when CErrors.noncritical e -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index d06009dce5..194d0b297c 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -141,9 +141,10 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = match kind_of_term t2 with Prod (_,a,b) -> (* assert (l2=[]); *) let _, a, b = destProd (Evarutil.nf_evar sigma t2) in - if dependent (mkRel 1) b then raise Not_found - else lookup_canonical_conversion (proji, Prod_cs), - (Stack.append_app [|a;pop b|] Stack.empty) + if EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b) then + lookup_canonical_conversion (proji, Prod_cs), + (Stack.append_app [|a;pop (EConstr.of_constr b)|] Stack.empty) + else raise Not_found | Sort s -> lookup_canonical_conversion (proji, Sort_cs (family_of_sort s)),[] @@ -178,7 +179,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let c' = subst_univs_level_constr subst c in let t' = subst_univs_level_constr subst t' in let bs' = List.map (subst_univs_level_constr subst) bs in - let h, _ = decompose_app_vect t' in + let h, _ = decompose_app_vect sigma (EConstr.of_constr t') in ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, (n,Stack.zip(t2,sk2)) @@ -372,7 +373,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | None -> fallback () | Some l1' -> (* Miller-Pfenning's patterns unification *) let t2 = nf_evar evd tM in - let t2 = solve_pattern_eqn env l1' t2 in + let t2 = solve_pattern_eqn env evd l1' t2 in solve_simple_eqn (evar_conv_x ts) env evd (position_problem on_left pbty,ev,t2) in @@ -893,7 +894,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (fun i -> exact_ise_stack2 env i (evar_conv_x trs) sk1 sk2); test; (fun i -> evar_conv_x trs env i CONV h2 - (fst (decompose_app_vect (substl ks h))))] + (fst (decompose_app_vect i (EConstr.of_constr (substl ks h)))))] else UnifFailure(evd,(*dummy*)NotSameHead) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = @@ -973,14 +974,14 @@ let apply_on_subterm env evdref f c t = in applyrec (env,(0,c)) t -let filter_possible_projections c ty ctxt args = +let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the fv of args to have a well-typed filter; don't know how necessary it is however to have a well-typed filter here *) - let fv1 = free_rels (mkApp (c,args)) (* Hack: locally untyped *) in - let fv2 = collect_vars (mkApp (c,args)) in + let fv1 = free_rels evd (EConstr.of_constr (mkApp (c,args))) (* Hack: locally untyped *) in + let fv2 = collect_vars evd (EConstr.of_constr (mkApp (c,args))) in let len = Array.length args in - let tyvars = collect_vars ty in + let tyvars = collect_vars evd (EConstr.of_constr ty) in List.map_i (fun i decl -> let () = assert (i < len) in let a = Array.unsafe_get args i in @@ -1039,7 +1040,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let t = NamedDecl.get_type decl' in let evs = ref [] in let ty = Retyping.get_type_of env_rhs evd c in - let filter' = filter_possible_projections c ty ctxt args in + let filter' = filter_possible_projections evd c ty ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) | _, _, [] -> [] | _ -> anomaly (Pp.str "Signature or instance are shorter than the occurrences list") in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index bafb009f52..ea3ab17a75 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -73,7 +73,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) (** Refresh the types of evars under template polymorphic references *) and refresh_term_evars onevars top t = match kind_of_term (whd_evar !evdref t) with - | App (f, args) when is_template_polymorphic env f -> + | App (f, args) when is_template_polymorphic env !evdref (EConstr.of_constr f) -> let pos = get_polymorphic_positions f in refresh_polymorphic_positions args pos | App (f, args) when top && isEvar f -> @@ -356,14 +356,15 @@ let expansion_of_var aliases x = | [] -> x | a::_ -> a -let rec expand_vars_in_term_using aliases t = match kind_of_term t with +let rec expand_vars_in_term_using sigma aliases t = match kind_of_term t with | Rel _ | Var _ -> normalize_alias aliases t | _ -> - map_constr_with_full_binders - extend_alias expand_vars_in_term_using aliases t + let self aliases c = EConstr.of_constr (expand_vars_in_term_using sigma aliases (EConstr.Unsafe.to_constr c)) in + EConstr.Unsafe.to_constr (map_constr_with_full_binders sigma + extend_alias self aliases (EConstr.of_constr t)) -let expand_vars_in_term env = expand_vars_in_term_using (make_alias_map env) +let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env) let free_vars_and_rels_up_alias_expansion aliases c = let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in @@ -430,8 +431,8 @@ let constr_list_distinct l = | [] -> true in loop l -let get_actual_deps aliases l t = - if occur_meta_or_existential t then +let get_actual_deps evd aliases l t = + if occur_meta_or_existential evd (EConstr.of_constr t) then (* Probably no restrictions on allowed vars in presence of evars *) l else @@ -460,21 +461,21 @@ let remove_instance_local_defs evd evk args = (* Check if an applied evar "?X[args] l" is a Miller's pattern *) -let find_unification_pattern_args env l t = +let find_unification_pattern_args env evd l t = if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then let aliases = make_alias_map env in match (try Some (expand_and_check_vars aliases l) with Exit -> None) with - | Some l as x when constr_list_distinct (get_actual_deps aliases l t) -> x + | Some l as x when constr_list_distinct (get_actual_deps evd aliases l t) -> x | _ -> None else None -let is_unification_pattern_meta env nb m l t = +let is_unification_pattern_meta env evd nb m l t = (* Variables from context and rels > nb are implicitly all there *) (* so we need to be a rel <= nb *) if List.for_all (fun x -> isRel x && destRel x <= nb) l then - match find_unification_pattern_args env l t with - | Some _ as x when not (dependent (mkMeta m) t) -> x + match find_unification_pattern_args env evd l t with + | Some _ as x when not (dependent evd (EConstr.mkMeta m) (EConstr.of_constr t)) -> x | _ -> None else None @@ -485,7 +486,7 @@ let is_unification_pattern_evar env evd (evk,args) l t = then let args = remove_instance_local_defs evd evk args in let n = List.length args in - match find_unification_pattern_args env (args @ l) t with + match find_unification_pattern_args env evd (args @ l) t with | Some l -> Some (List.skipn n l) | _ -> None else None @@ -498,7 +499,7 @@ let is_unification_pattern_pure_evar env evd (evk,args) t = let is_unification_pattern (env,nb) evd f l t = match kind_of_term f with - | Meta m -> is_unification_pattern_meta env nb m l t + | Meta m -> is_unification_pattern_meta env evd nb m l t | Evar ev -> is_unification_pattern_evar env evd ev l t | _ -> None @@ -509,9 +510,9 @@ let is_unification_pattern (env,nb) evd f l t = *implicitly* depend on Vars but lambda abstraction will not reflect this dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) -let solve_pattern_eqn env l c = +let solve_pattern_eqn env sigma l c = let c' = List.fold_right (fun a c -> - let c' = subst_term (lift 1 a) (lift 1 c) in + let c' = subst_term sigma (EConstr.of_constr (lift 1 a)) (EConstr.of_constr (lift 1 c)) in match kind_of_term a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> @@ -550,7 +551,7 @@ let make_projectable_subst aliases sigma evi args = | LocalAssum (id,c), a::rest -> let a = whd_evar sigma a in let cstrs = - let a',args = decompose_app_vect a in + let a',args = decompose_app_vect sigma (EConstr.of_constr a) in match kind_of_term a' with | Construct cstr -> let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in @@ -923,12 +924,12 @@ let invert_invertible_arg fullenv evd aliases k (evk,argsv) args' = let set_of_evctx l = List.fold_left (fun s decl -> Id.Set.add (get_id decl) s) Id.Set.empty l -let filter_effective_candidates evi filter candidates = +let filter_effective_candidates evd evi filter candidates = match filter with | None -> candidates | Some filter -> let ids = set_of_evctx (Filter.filter_list filter (evar_context evi)) in - List.filter (fun a -> Id.Set.subset (collect_vars a) ids) candidates + List.filter (fun a -> Id.Set.subset (collect_vars evd (EConstr.of_constr a)) ids) candidates let filter_candidates evd evk filter candidates_update = let evi = Evd.find_undefined evd evk in @@ -939,7 +940,7 @@ let filter_candidates evd evk filter candidates_update = match candidates with | None -> NoUpdate | Some l -> - let l' = filter_effective_candidates evi filter l in + let l' = filter_effective_candidates evd evi filter l in if List.length l = List.length l' && candidates_update = NoUpdate then NoUpdate else @@ -952,7 +953,7 @@ let closure_of_filter evd evk = function | None -> None | Some filter -> let evi = Evd.find_undefined evd evk in - let vars = collect_vars (Evarutil.nf_evar evd (evar_concl evi)) in + let vars = collect_vars evd (EConstr.of_constr (evar_concl evi)) in let test b decl = b || Idset.mem (get_id decl) vars || match decl with | LocalAssum _ -> @@ -999,7 +1000,7 @@ let do_restrict_hyps evd (evk,args as ev) filter candidates = (* ?e is assumed to have no candidates *) let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = - let rhs = expand_vars_in_term env rhs in + let rhs = expand_vars_in_term env evd rhs in let filter = restrict_upon_filter evd evk (* Keep only variables that occur in rhs *) @@ -1010,7 +1011,7 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = (* expands only rels and vars aliases, not rels or vars bound to an *) (* arbitrary complex term *) (fun a -> not (isRel a || isVar a) - || dependent a rhs || List.exists (fun (id,_) -> isVarId id a) sols) + || dependent evd (EConstr.of_constr a) (EConstr.of_constr rhs) || List.exists (fun (id,_) -> isVarId id a) sols) argsv in let filter = closure_of_filter evd evk filter in let candidates = extract_candidates sols in @@ -1060,7 +1061,7 @@ let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = | _, None -> filter_candidates evd evk1 filter1 NoUpdate | None, Some _ -> raise DoesNotPreserveCandidateRestriction | Some l1, Some l2 -> - let l1 = filter_effective_candidates evi1 filter1 l1 in + let l1 = filter_effective_candidates evd evi1 filter1 l1 in let l1' = List.filter (fun c1 -> let c1' = instantiate_evar_array evi1 c1 argsv1 in let filter c2 = @@ -1091,9 +1092,7 @@ exception CannotProject of evar_map * existential *) let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = - let f,args2 = decompose_app_vect t in - let f,args1 = decompose_app_vect (whd_evar evd f) in - let args = Array.append args1 args2 in + let f,args = decompose_app_vect evd (EConstr.of_constr t) in match kind_of_term f with | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in @@ -1450,7 +1449,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | _ -> progress := true; match - let c,args = decompose_app_vect t in + let c,args = decompose_app_vect !evdref (EConstr.of_constr t) in match kind_of_term c with | Construct (cstr,u) when noccur_between 1 k t -> (* This is common case when inferring the return clause of match *) @@ -1466,10 +1465,11 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let ty = get_type_of env' !evdref t in let candidates = try + let self env c = EConstr.of_constr (imitate env (EConstr.Unsafe.to_constr c)) in let t = - map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) - imitate envk t in - t::l + map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + self envk (EConstr.of_constr t) in + EConstr.Unsafe.to_constr t::l with e when CErrors.noncritical e -> l in (match candidates with | [x] -> x @@ -1480,8 +1480,9 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = evar'') | None -> (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) - imitate envk t + let self env c = EConstr.of_constr (imitate env (EConstr.Unsafe.to_constr c)) in + EConstr.Unsafe.to_constr (map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + self envk (EConstr.of_constr t)) in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = @@ -1498,7 +1499,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = in is_id_subst filter_ctxt (Array.to_list argsv) && closed0 rhs && - Idset.subset (collect_vars rhs) !names + Idset.subset (collect_vars evd (EConstr.of_constr rhs)) !names in let body = if fast rhs then nf_evar evd rhs @@ -1530,7 +1531,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = with NoCandidates -> try let (evd',body) = invert_definition conv_algo choose env evd pbty ev rhs in - if occur_meta body then raise MetaOccurInBodyInternal; + if occur_meta evd' (EConstr.of_constr body) then raise MetaOccurInBodyInternal; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index f94c83b6dc..cf059febf4 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -18,7 +18,7 @@ val is_success : unification_result -> bool (** Replace the vars and rels that are aliases to other vars and rels by their representative that is most ancient in the context *) -val expand_vars_in_term : env -> constr -> constr +val expand_vars_in_term : env -> evar_map -> constr -> constr (** [evar_define choose env ev c] try to instantiate [ev] with [c] (typed in [env]), possibly solving related unification problems, possibly leaving open @@ -62,7 +62,7 @@ val is_unification_pattern_evar : env -> evar_map -> existential -> constr list val is_unification_pattern : env * int -> evar_map -> constr -> constr list -> constr -> constr list option -val solve_pattern_eqn : env -> constr list -> constr -> constr +val solve_pattern_eqn : env -> evar_map -> constr list -> constr -> constr val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 8f369a811e..9b572f376d 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -751,7 +751,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match evar_kind_of_term !evdref resj.uj_val with | App (f,args) -> let f = whd_evar !evdref f in - if is_template_polymorphic env.ExtraEnv.env f then + if is_template_polymorphic env.ExtraEnv.env !evdref (EConstr.of_constr f) then (* Special case for inductive type applications that must be refreshed right away. *) let sigma = !evdref in @@ -1009,7 +1009,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | VMcast -> let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in - if not (occur_existential cty || occur_existential tval) then + if not (occur_existential !evdref (EConstr.of_constr cty) || occur_existential !evdref (EConstr.of_constr tval)) then let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index cda052b796..e897d5f5c5 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -171,7 +171,7 @@ let keep_true_projections projs kinds = let filter (p, (_, b)) = if b then Some p else None in List.map_filter filter (List.combine projs kinds) -let cs_pattern_of_constr t = +let cs_pattern_of_constr sigma t = match kind_of_term t with App (f,vargs) -> begin @@ -179,7 +179,7 @@ let cs_pattern_of_constr t = with e when CErrors.noncritical e -> raise Not_found end | Rel n -> Default_cs, Some n, [] - | Prod (_,a,b) when not (Termops.dependent (mkRel 1) b) -> Prod_cs, None, [a; Termops.pop b] + | Prod (_,a,b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b) -> Prod_cs, None, [a; Termops.pop (EConstr.of_constr b)] | Sort s -> Sort_cs (family_of_sort s), None, [] | _ -> begin @@ -217,7 +217,7 @@ let compute_canonical_projections warn (con,ind) = | Some proji_sp -> begin try - let patt, n , args = cs_pattern_of_constr t in + let patt, n , args = cs_pattern_of_constr Evd.empty t (** FIXME *) in ((ConstRef proji_sp, patt, t, n, args) :: l) with Not_found -> let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index a6a90c751b..4a176760c2 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -65,7 +65,7 @@ type obj_typ = { o_TCOMPS : constr list } (** ordered *) (** Return the form of the component of a canonical structure *) -val cs_pattern_of_constr : constr -> cs_pattern * int option * constr list +val cs_pattern_of_constr : Evd.evar_map -> constr -> cs_pattern * int option * constr list val pr_cs_pattern : cs_pattern -> Pp.std_ppcmds diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index a85e493eae..820974888e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -197,14 +197,14 @@ module Cst_stack = struct (** [best_replace d cst_l c] makes the best replacement for [d] by [cst_l] in [c] *) - let best_replace d cst_l c = + let best_replace sigma d cst_l c = let reconstruct_head = List.fold_left (fun t (i,args) -> mkApp (t,Array.sub args i (Array.length args - i))) in List.fold_right - (fun (cst,params,args) t -> Termops.replace_term - (reconstruct_head d args) - (applist (cst, List.rev params)) - t) cst_l c + (fun (cst,params,args) t -> Termops.replace_term sigma + (EConstr.of_constr (reconstruct_head d args)) + (EConstr.of_constr (applist (cst, List.rev params))) + (EConstr.of_constr t)) cst_l c let pr l = let open Pp in @@ -612,8 +612,9 @@ let safe_meta_value sigma ev = let strong whdfun env sigma t = let rec strongrec env t = - map_constr_with_full_binders push_rel strongrec env (whdfun env sigma t) in - strongrec env t + let t = EConstr.of_constr (whdfun env sigma (EConstr.Unsafe.to_constr t)) in + map_constr_with_full_binders sigma push_rel strongrec env t in + EConstr.Unsafe.to_constr (strongrec env (EConstr.of_constr t)) let local_strong whdfun sigma = let rec strongrec t = Constr.map strongrec (whdfun sigma t) in @@ -712,14 +713,14 @@ let contract_cofix ?env ?reference (bodynum,(names,types,bodies as typedbodies)) substl closure bodies.(bodynum) (** Similar to the "fix" case below *) -let reduce_and_refold_cofix recfun env refold cst_l cofix sk = +let reduce_and_refold_cofix recfun env sigma refold cst_l cofix sk = let raw_answer = let env = if refold then Some env else None in contract_cofix ?env ?reference:(Cst_stack.reference cst_l) cofix in apply_subst (fun x (t,sk') -> let t' = - if refold then Cst_stack.best_replace (mkCoFix cofix) cst_l t else t in + if refold then Cst_stack.best_replace sigma (mkCoFix cofix) cst_l t else t in recfun x (t',sk')) [] refold Cst_stack.empty raw_answer sk @@ -757,7 +758,7 @@ let contract_fix ?env ?reference ((recindices,bodynum),(names,types,bodies as ty replace the fixpoint by the best constant from [cst_l] Other rels are directly substituted by constants "magically found from the context" in contract_fix *) -let reduce_and_refold_fix recfun env refold cst_l fix sk = +let reduce_and_refold_fix recfun env sigma refold cst_l fix sk = let raw_answer = let env = if refold then None else Some env in contract_fix ?env ?reference:(Cst_stack.reference cst_l) fix in @@ -765,7 +766,7 @@ let reduce_and_refold_fix recfun env refold cst_l fix sk = (fun x (t,sk') -> let t' = if refold then - Cst_stack.best_replace (mkFix fix) cst_l t + Cst_stack.best_replace sigma (mkFix fix) cst_l t else t in recfun x (t',sk')) [] refold Cst_stack.empty raw_answer sk @@ -947,7 +948,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in let u = if Int.equal napp 1 then f else appvect (f,lc) in - if noccurn 1 u then (pop u,Stack.empty),Cst_stack.empty else fold () + if noccurn 1 u then (pop (EConstr.of_constr u),Stack.empty),Cst_stack.empty else fold () | _ -> fold () else fold () | _ -> fold ()) @@ -974,7 +975,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> let x' = Stack.zip(x,args) in let out_sk = s' @ (Stack.append_app [|x'|] s'') in - reduce_and_refold_fix whrec env refold cst_l f out_sk + reduce_and_refold_fix whrec env sigma refold cst_l f out_sk |args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') -> let x' = Stack.zip(x,args) in begin match remains with @@ -1010,7 +1011,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then match Stack.strip_app stack with |args, ((Stack.Case _ |Stack.Proj _)::s') -> - reduce_and_refold_cofix whrec env refold cst_l cofix stack + reduce_and_refold_cofix whrec env sigma refold cst_l cofix stack |_ -> fold () else fold () @@ -1043,7 +1044,7 @@ let local_whd_state_gen flags sigma = | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in let u = if Int.equal napp 1 then f else appvect (f,lc) in - if noccurn 1 u then (pop u,Stack.empty) else s + if noccurn 1 u then (pop (EConstr.of_constr u),Stack.empty) else s | _ -> s else s | _ -> s) @@ -1568,10 +1569,10 @@ let meta_reducible_instance evd b = in let metas = Metaset.fold fold fm Metamap.empty in let rec irec u = - let u = whd_betaiota Evd.empty u in + let u = whd_betaiota Evd.empty u (** FIXME *) in match kind_of_term u with - | Case (ci,p,c,bl) when isMeta (strip_outer_cast c) -> - let m = destMeta (strip_outer_cast c) in + | Case (ci,p,c,bl) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd (EConstr.of_constr c))) -> + let m = destMeta (strip_outer_cast evd (EConstr.of_constr c)) in (match try let g, s = Metamap.find m metas in @@ -1581,8 +1582,8 @@ let meta_reducible_instance evd b = with | Some g -> irec (mkCase (ci,p,g,bl)) | None -> mkCase (ci,irec p,c,Array.map irec bl)) - | App (f,l) when isMeta (strip_outer_cast f) -> - let m = destMeta (strip_outer_cast f) in + | App (f,l) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd (EConstr.of_constr f))) -> + let m = destMeta (strip_outer_cast evd (EConstr.of_constr f)) in (match try let g, s = Metamap.find m metas in diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 4cd7a2a869..8dcf5c084e 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -44,7 +44,7 @@ module Cst_stack : sig val add_args : constr array -> t -> t val add_cst : constr -> t -> t val best_cst : t -> (constr * constr list) option - val best_replace : constr -> t -> constr -> constr + val best_replace : Evd.evar_map -> constr -> t -> constr -> constr val reference : t -> Constant.t option val pr : t -> Pp.std_ppcmds end diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 5b67af3e73..ac3b5ef639 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -93,7 +93,7 @@ let retype ?(polyprop=true) sigma = let rec type_of env cstr = match kind_of_term cstr with | Meta n -> - (try strip_outer_cast (Evd.meta_ftype sigma n).Evd.rebus + (try strip_outer_cast sigma (EConstr.of_constr (Evd.meta_ftype sigma n).Evd.rebus) with Not_found -> retype_error (BadMeta n)) | Rel n -> let ty = RelDecl.get_type (lookup_rel n env) in @@ -124,12 +124,13 @@ let retype ?(polyprop=true) sigma = subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) - | App(f,args) when is_template_polymorphic env f -> + | App(f,args) when is_template_polymorphic env sigma (EConstr.of_constr f) -> + let f = whd_evar sigma f in let t = type_of_global_reference_knowing_parameters env f args in - strip_outer_cast (subst_type env sigma t (Array.to_list args)) + strip_outer_cast sigma (EConstr.of_constr (subst_type env sigma t (Array.to_list args))) | App(f,args) -> - strip_outer_cast - (subst_type env sigma (type_of env f) (Array.to_list args)) + strip_outer_cast sigma + (EConstr.of_constr (subst_type env sigma (type_of env f) (Array.to_list args))) | Proj (p,c) -> let ty = type_of env c in (try @@ -152,7 +153,8 @@ let retype ?(polyprop=true) sigma = | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2) | Prop Null, (Type _ as s) -> s | Type u1, Type u2 -> Type (Univ.sup u1 u2)) - | App(f,args) when is_template_polymorphic env f -> + | App(f,args) when is_template_polymorphic env sigma (EConstr.of_constr f) -> + let f = whd_evar sigma f in let t = type_of_global_reference_knowing_parameters env f args in sort_of_atomic_type env sigma t args | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args @@ -168,7 +170,8 @@ let retype ?(polyprop=true) sigma = let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 - | App(f,args) when is_template_polymorphic env f -> + | App(f,args) when is_template_polymorphic env sigma (EConstr.of_constr f) -> + let f = whd_evar sigma f in let t = type_of_global_reference_knowing_parameters env f args in family_of_sort (sort_of_atomic_type env sigma t args) | App(f,args) -> diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 7da7385089..ff76abe372 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -177,7 +177,7 @@ let eval_table = Summary.ref (Cmap.empty : frozen) ~name:"evaluation" the xp..x1. *) -let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = +let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = let n = List.length labs in let nargs = List.length args in if nargs > n then raise Elimconst; @@ -202,7 +202,7 @@ let check_fix_reversibility labs args ((lv,i),(_,tys,bds)) = raise Elimconst; List.iteri (fun i t_i -> if not (Int.List.mem_assoc (i+1) li) then - let fvs = List.map ((+) (i+1)) (Int.Set.elements (free_rels t_i)) in + let fvs = List.map ((+) (i+1)) (Int.Set.elements (free_rels sigma (EConstr.of_constr t_i))) in match List.intersect Int.equal fvs reversible_rels with | [] -> () | _ -> raise Elimconst) @@ -261,7 +261,7 @@ let compute_consteval_direct env sigma ref = let open Context.Rel.Declaration in srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> - (try check_fix_reversibility labs l fix + (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel d && not onlyproj -> EliminationCases n | Case (_,_,d,_) -> srec env n labs true d @@ -1102,13 +1102,13 @@ let fold_one_com com env sigma c = (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) - let a = subst_term (clos_norm_flags unfold_side_red env sigma rcom) c in + let a = subst_term sigma (EConstr.of_constr (clos_norm_flags unfold_side_red env sigma rcom)) (EConstr.of_constr c) in if not (eq_constr a c) then subst1 com a else (* Then reason on the non beta-iota-zeta form for compatibility - even if it is probably a useless configuration *) - let a = subst_term rcom c in + let a = subst_term sigma (EConstr.of_constr rcom) (EConstr.of_constr c) in subst1 com a let fold_commands cl env sigma c = @@ -1133,8 +1133,8 @@ let compute = cbv_betadeltaiota let abstract_scheme env (locc,a) (c, sigma) = let ta = Retyping.get_type_of env sigma a in let na = named_hd env ta Anonymous in - if occur_meta ta then error "Cannot find a type for the generalisation."; - if occur_meta a then + if occur_meta sigma (EConstr.of_constr ta) then error "Cannot find a type for the generalisation."; + if occur_meta sigma (EConstr.of_constr a) then mkLambda (na,ta,c), sigma else let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index e2b3af7e97..3134dac6a6 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -87,7 +87,7 @@ let abstract_scheme env evd c l lname_typ = are unclear... if occur_meta ta then error "cannot find a type for the generalisation" else *) - if occur_meta a then mkLambda_name env (na,ta,t), evd + if occur_meta evd (EConstr.of_constr a) then mkLambda_name env (na,ta,t), evd else let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in mkLambda_name env (na,ta,t'), evd') @@ -182,7 +182,7 @@ let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) = extra assumptions added by unification to the context *) let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in - let c = solve_pattern_eqn env l c in + let c = solve_pattern_eqn env sigma l c in let pb = (Conv,TypeNotProcessed) in if noccur_between 1 nb c then sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst @@ -190,7 +190,7 @@ let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) = | Evar ev -> let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in - sigma,metasubst,(env,ev,solve_pattern_eqn env l c)::evarsubst + sigma,metasubst,(env,ev,solve_pattern_eqn env sigma l c)::evarsubst | _ -> assert false let push d (env,n) = (push_rel_assum d env,n+1) @@ -679,7 +679,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ - when not (dependent cM cN) (* helps early trying alternatives *) -> + when not (dependent sigma (EConstr.of_constr cM) (EConstr.of_constr cN)) (* helps early trying alternatives *) -> let sigma = if opt.with_types && flags.check_applied_meta_types then (try @@ -699,7 +699,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Meta k - when not (dependent cN cM) (* helps early trying alternatives *) -> + when not (dependent sigma (EConstr.of_constr cN) (EConstr.of_constr cM)) (* helps early trying alternatives *) -> let sigma = if opt.with_types && flags.check_applied_meta_types then (try @@ -728,15 +728,15 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb sigma,metasubst,((curenv,ev,cN)::evarsubst) | Evar (evk,_ as ev), _ when not (Evar.Set.mem evk flags.frozen_evars) - && not (occur_evar evk cN) -> - let cmvars = free_rels cM and cnvars = free_rels cN in + && not (occur_evar sigma evk (EConstr.of_constr cN)) -> + let cmvars = free_rels sigma (EConstr.of_constr cM) and cnvars = free_rels sigma (EConstr.of_constr cN) in if Int.Set.subset cnvars cmvars then sigma,metasubst,((curenv,ev,cN)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Evar (evk,_ as ev) when not (Evar.Set.mem evk flags.frozen_evars) - && not (occur_evar evk cM) -> - let cmvars = free_rels cM and cnvars = free_rels cN in + && not (occur_evar sigma evk (EConstr.of_constr cM)) -> + let cmvars = free_rels sigma (EConstr.of_constr cM) and cnvars = free_rels sigma (EConstr.of_constr cN) in if Int.Set.subset cmvars cnvars then sigma,metasubst,((curenv,ev,cM)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) @@ -1295,8 +1295,8 @@ let w_merge env with_types flags (evd,metas,evars) = (* This can make rhs' ill-typed if metas are *) let rhs' = subst_meta_instances metas rhs in match kind_of_term rhs with - | App (f,cl) when occur_meta rhs' -> - if occur_evar evk rhs' then + | App (f,cl) when occur_meta evd (EConstr.of_constr rhs') -> + if occur_evar evd evk (EConstr.of_constr rhs') then error_occur_check curenv evd evk rhs'; if is_mimick_head flags.modulo_delta f then let evd' = @@ -1474,16 +1474,16 @@ let iter_fail f a = (* make_abstraction: a variant of w_unify_to_subterm which works on contexts, with evars, and possibly with occurrences *) -let indirectly_dependent c d decls = +let indirectly_dependent sigma c d decls = not (isVar c) && (* This test is not needed if the original term is a variable, but it is needed otherwise, as e.g. when abstracting over "2" in "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious way to see that the second hypothesis depends indirectly over 2 *) - List.exists (fun d' -> dependent_in_decl (mkVar (NamedDecl.get_id d')) d) decls + List.exists (fun d' -> dependent_in_decl sigma (EConstr.mkVar (NamedDecl.get_id d')) d) decls -let indirect_dependency d decls = - decls |> List.filter (fun d' -> dependent_in_decl (mkVar (NamedDecl.get_id d')) d) |> List.hd |> NamedDecl.get_id +let indirect_dependency sigma d decls = + decls |> List.filter (fun d' -> dependent_in_decl sigma (EConstr.mkVar (NamedDecl.get_id d')) d) |> List.hd |> NamedDecl.get_id let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sigma (pending,c) = let current_sigma = Sigma.to_evar_map current_sigma in @@ -1610,7 +1610,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let occ = if likefirst then LikeFirst else AtOccs occ in let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in if Context.Named.Declaration.equal d newdecl - && not (indirectly_dependent c d depdecls) + && not (indirectly_dependent sigma c d depdecls) then if check_occs && not (in_every_hyp occs) then raise (PretypeError (env,sigma,NoOccurrenceFound (c,Some hyp))) @@ -1695,13 +1695,13 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let bestexn = ref None in let kop = Keys.constr_key op in let rec matchrec cl = - let cl = strip_outer_cast cl in + let cl = strip_outer_cast evd (EConstr.of_constr cl) in (try if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then (try if !keyed_unification then - let f1, l1 = decompose_app_vect op in - let f2, l2 = decompose_app_vect cl in + let f1, l1 = decompose_app_vect evd (EConstr.of_constr op) in + let f2, l2 = decompose_app_vect evd (EConstr.of_constr cl) in w_typed_unify_array env evd flags f1 l1 f2 l2,cl else w_typed_unify env evd CONV flags op cl,cl with ex when Pretype_errors.unsatisfiable_exception ex -> @@ -1788,7 +1788,7 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = in ffail 0 in let rec matchrec cl = - let cl = strip_outer_cast cl in + let cl = strip_outer_cast evd (EConstr.of_constr cl) in (bind (if closed0 cl then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) @@ -1839,7 +1839,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = else let allow_K = flags.allow_K_in_toplevel_higher_order_unification in let flags = - if occur_meta_or_existential op || !keyed_unification then + if occur_meta_or_existential evd (EConstr.of_constr op) || !keyed_unification then (* This is up to delta for subterms w/o metas ... *) flags else @@ -1848,7 +1848,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = unify pre-existing non frozen evars of the goal or of the pattern *) set_no_delta_flags flags in - let t' = (strip_outer_cast op,t) in + let t' = (strip_outer_cast evd (EConstr.of_constr op),t) in let (evd',cl) = try if is_keyed_unification () then @@ -1864,7 +1864,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = (* w_unify_to_subterm does not go through evars, so the next step, which was already in <= 8.4, is needed at least for compatibility of rewrite *) - dependent op t -> (evd,op) + dependent evd (EConstr.of_constr op) (EConstr.of_constr t) -> (evd,op) in if not allow_K && (* ensure we found a different instance *) -- cgit v1.2.3 From 8f6aab1f4d6d60842422abc5217daac806eb0897 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Nov 2016 20:53:32 +0100 Subject: Reductionops API using EConstr. --- pretyping/cases.ml | 24 +-- pretyping/classops.ml | 23 +-- pretyping/coercion.ml | 24 +-- pretyping/constr_matching.ml | 2 +- pretyping/detyping.ml | 2 +- pretyping/evarconv.ml | 177 +++++++++-------- pretyping/evarconv.mli | 8 +- pretyping/evardefine.ml | 10 +- pretyping/evarsolve.ml | 16 +- pretyping/evarsolve.mli | 2 +- pretyping/indrec.ml | 16 +- pretyping/inductiveops.ml | 53 +++--- pretyping/inductiveops.mli | 18 +- pretyping/nativenorm.ml | 95 +++++---- pretyping/pretyping.ml | 20 +- pretyping/recordops.ml | 5 +- pretyping/recordops.mli | 2 +- pretyping/reductionops.ml | 445 ++++++++++++++++++++++++------------------- pretyping/reductionops.mli | 100 +++++----- pretyping/retyping.ml | 29 ++- pretyping/tacred.ml | 266 ++++++++++++++------------ pretyping/typeclasses.ml | 2 +- pretyping/typing.ml | 12 +- pretyping/unification.ml | 66 +++---- pretyping/vnorm.ml | 110 +++++------ pretyping/vnorm.mli | 2 +- 26 files changed, 815 insertions(+), 714 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 6b480986c7..be72091a91 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -292,7 +292,7 @@ let inductive_template evdref env tmloc ind = applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = - let (IndType(indf,realargs) as ind) = find_rectype env sigma typ in + let (IndType(indf,realargs) as ind) = find_rectype env sigma (EConstr.of_constr typ) in let names = match realnames with | Some names -> names @@ -1035,7 +1035,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* We need _parallel_ bindings to get gamma, x1...xn |- PI tms. ccl'' *) (* Note: applying the substitution in tms is not important (is it sure?) *) let ccl'' = - whd_betaiota Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in + whd_betaiota Evd.empty (EConstr.of_constr (subst_predicate (realargsi, copti) ccl' tms)) in (* We adjust ccl st: gamma, x'1..x'n, x1..xn, tms |- ccl'' *) let ccl''' = liftn_predicate n (n+1) ccl'' tms in (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*) @@ -1044,7 +1044,7 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms = let pred = abstract_predicate env !evdref indf current realargs dep tms p in (pred, whd_betaiota !evdref - (applist (pred, realargs@[current]))) + (EConstr.of_constr (applist (pred, realargs@[current])))) (* Take into account that a type has been discovered to be inductive, leading to more dependencies in the predicate if the type has indices *) @@ -1199,7 +1199,7 @@ let rec generalize_problem names pb = function | LocalDef (Anonymous,_,_) -> pb', deps | _ -> (* for better rendering *) - let d = RelDecl.map_type (whd_betaiota !(pb.evdref)) d in + let d = RelDecl.map_type (fun c -> whd_betaiota !(pb.evdref) (EConstr.of_constr c)) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch (i+1) 1 tomatch in { pb' with @@ -1377,7 +1377,7 @@ and match_current pb (initial,tomatch) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in let ci = make_case_info pb.env (fst mind) pb.casestyle in - let pred = nf_betaiota !(pb.evdref) pred in + let pred = nf_betaiota !(pb.evdref) (EConstr.of_constr pred) in let case = make_case_or_project pb.env indf ci pred current brvals in @@ -1613,7 +1613,7 @@ let rec list_assoc_in_triple x = function *) let abstract_tycon loc env evdref subst tycon extenv t = - let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*) + let t = nf_betaiota !evdref (EConstr.of_constr t) in (* it helps in some cases to remove K-redex*) let src = match kind_of_term t with | Evar (evk,_) -> (loc,Evar_kinds.SubEvar evk) | _ -> (loc,Evar_kinds.CasesType true) in @@ -1635,13 +1635,13 @@ let abstract_tycon loc env evdref subst tycon extenv t = try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context env) in let ev' = e_new_evar env evdref ~src ty in - begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with + begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,EConstr.of_constr (substl inst ev')) with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; ev' | _ -> - let good = List.filter (fun (_,u,_) -> is_conv_leq env !evdref t u) subst in + let good = List.filter (fun (_,u,_) -> is_conv_leq env !evdref (EConstr.of_constr t) (EConstr.of_constr u)) subst in match good with | [] -> let self env c = EConstr.of_constr (aux env (EConstr.Unsafe.to_constr c)) in @@ -1705,7 +1705,7 @@ let build_inversion_problem loc env sigma tms t = let id = next_name_away (named_hd env t Anonymous) avoid in PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = - match kind_of_term (whd_all env sigma t) with + match kind_of_term (whd_all env sigma (EConstr.of_constr t)) with | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc | App (f,v) when isConstruct f -> let cstr,u = destConstruct f in @@ -2038,7 +2038,7 @@ let constr_of_pat env evdref arsign pat avoid = | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in let IndType (indf, _) = - try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) + try find_rectype env ( !evdref) (EConstr.of_constr (lift (-(List.length realargs)) ty)) with Not_found -> error_case_not_inductive env !evdref {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} in @@ -2068,7 +2068,7 @@ let constr_of_pat env evdref arsign pat avoid = let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in let apptype = Retyping.get_type_of env ( !evdref) app in - let IndType (indf, realargs) = find_rectype env ( !evdref) apptype in + let IndType (indf, realargs) = find_rectype env (!evdref) (EConstr.of_constr apptype) in match alias with Anonymous -> pat', sign, app, apptype, realargs, n, avoid @@ -2327,7 +2327,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let t = RelDecl.get_type decl in let argt = Retyping.get_type_of env !evdref arg in let eq, refl_arg = - if Reductionops.is_conv env !evdref argt t then + if Reductionops.is_conv env !evdref (EConstr.of_constr argt) (EConstr.of_constr t) then (mk_eq evdref (lift (nargeqs + slift) argt) (mkRel (nargeqs + slift)) (lift (nargeqs + nar) arg), diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 30d100af9f..fd21f5bd12 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -192,13 +192,14 @@ let coercion_exists coe = CoeTypMap.mem coe !coercion_tab (* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) let find_class_type sigma t = - let t', args = Reductionops.whd_betaiotazeta_stack sigma t in - match kind_of_term t' with - | Var id -> CL_SECVAR id, Univ.Instance.empty, args - | Const (sp,u) -> CL_CONST sp, u, args + let inj = EConstr.Unsafe.to_constr in + let t', args = Reductionops.whd_betaiotazeta_stack sigma (EConstr.of_constr t) in + match EConstr.kind sigma t' with + | Var id -> CL_SECVAR id, Univ.Instance.empty, List.map inj args + | Const (sp,u) -> CL_CONST sp, u, List.map inj args | Proj (p, c) when not (Projection.unfolded p) -> - CL_PROJ (Projection.constant p), Univ.Instance.empty, c :: args - | Ind (ind_sp,u) -> CL_IND ind_sp, u, args + CL_PROJ (Projection.constant p), Univ.Instance.empty, List.map inj (c :: args) + | Ind (ind_sp,u) -> CL_IND ind_sp, u, List.map inj args | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, [] | Sort _ -> CL_SORT, Univ.Instance.empty, [] | _ -> raise Not_found @@ -232,7 +233,7 @@ let class_of env sigma t = let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, u, args) with Not_found -> - let t = Tacred.hnf_constr env sigma t in + let t = Tacred.hnf_constr env sigma (EConstr.of_constr t) in let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, u, args) @@ -276,7 +277,7 @@ let apply_on_class_of env sigma t cont = t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) - let t = Tacred.hnf_constr env sigma t in + let t = Tacred.hnf_constr env sigma (EConstr.of_constr t) in let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; @@ -297,9 +298,9 @@ let lookup_path_to_sort_from env sigma s = let get_coercion_constructor env coe = let c, _ = - Reductionops.whd_all_stack env Evd.empty coe.coe_value + Reductionops.whd_all_stack env Evd.empty (EConstr.of_constr coe.coe_value) in - match kind_of_term c with + match EConstr.kind Evd.empty (** FIXME *) c with | Construct (cstr,u) -> (cstr, Inductiveops.constructor_nrealargs cstr -1) | _ -> @@ -403,7 +404,7 @@ type coercion = { let reference_arity_length ref = let t = Universes.unsafe_type_of_global ref in - List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t)) + List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty (EConstr.of_constr t))) (** FIXME *) let projection_arity_length p = let len = reference_arity_length (ConstRef p) in diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index a3970fc0f3..b062da1f49 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -63,7 +63,7 @@ let apply_coercion_args env evd check isproj argl funj = { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) - match kind_of_term (whd_all env evd typ) with + match kind_of_term (whd_all env evd (EConstr.of_constr typ)) with | Prod (_,c1,c2) -> if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then raise NoCoercion; @@ -95,7 +95,7 @@ let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdre Evarutil.e_new_evar env evdref ~src c let app_opt env evdref f t = - whd_betaiota !evdref (app_opt f t) + whd_betaiota !evdref (EConstr.of_constr (app_opt f t)) let pair_of_array a = (a.(0), a.(1)) @@ -128,11 +128,11 @@ let lift_args n sign = let mu env evdref t = let rec aux v = - let v' = hnf env !evdref v in + let v' = hnf env !evdref (EConstr.of_constr v) in match disc_subset v' with | Some (u, p) -> let f, ct = aux u in - let p = hnf_nodelta env !evdref p in + let p = hnf_nodelta env !evdref (EConstr.of_constr p) in (Some (fun x -> app_opt env evdref f (papp evdref sig_proj1 [| u; p; x |])), @@ -145,7 +145,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) = let open Context.Rel.Declaration in let rec coerce_unify env x y = - let x = hnf env !evdref x and y = hnf env !evdref y in + let x = hnf env !evdref (EConstr.of_constr x) and y = hnf env !evdref (EConstr.of_constr y) in try evdref := the_conv_x_leq env x y !evdref; None @@ -153,7 +153,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) and coerce' env x y : (Term.constr -> Term.constr) option = let subco () = subset_coerce env evdref x y in let dest_prod c = - match Reductionops.splay_prod_n env ( !evdref) 1 c with + match Reductionops.splay_prod_n env (!evdref) 1 (EConstr.of_constr c) with | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c | _ -> raise NoSubtacCoercion in @@ -337,7 +337,7 @@ let app_coercion env evdref coercion v = | None -> v | Some f -> let v' = Typing.e_solve_evars env evdref (f v) in - whd_betaiota !evdref v' + whd_betaiota !evdref (EConstr.of_constr v') let coerce_itf loc env evd v t c1 = let evdref = ref evd in @@ -373,7 +373,7 @@ let apply_coercion env sigma p hj typ_cl = (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core env evd j = - let t = whd_all env evd j.uj_type in + let t = whd_all env evd (EConstr.of_constr j.uj_type) in match kind_of_term t with | Prod (_,_,_) -> (evd,j) | Evar ev -> @@ -414,7 +414,7 @@ let inh_tosort_force loc env evd j = error_not_a_type ~loc env evd j let inh_coerce_to_sort loc env evd j = - let typ = whd_all env evd j.uj_type in + let typ = whd_all env evd (EConstr.of_constr j.uj_type) in match kind_of_term typ with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) | Evar ev when not (is_defined evd (fst ev)) -> @@ -466,8 +466,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = try inh_coerce_to_fail env evd rigidonly v t c1 with NoCoercion -> match - kind_of_term (whd_all env evd t), - kind_of_term (whd_all env evd c1) + kind_of_term (whd_all env evd (EConstr.of_constr t)), + kind_of_term (whd_all env evd (EConstr.of_constr c1)) with | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) @@ -485,7 +485,7 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = inh_conv_coerce_to_fail loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in let v1 = Option.get v1 in - let v2 = Option.map (fun v -> beta_applist (lift 1 v,[v1])) v in + let v2 = Option.map (fun v -> beta_applist evd' (EConstr.of_constr (lift 1 v),[EConstr.of_constr v1])) v in let t2 = match v2 with | None -> subst_term evd' (EConstr.of_constr v1) (EConstr.of_constr t2) | Some v2 -> Retyping.get_type_of env1 evd' v2 in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index d7b73d3339..66e6907149 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -165,7 +165,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | _, _ -> (if convert then let sigma,c' = Evd.fresh_global env sigma ref in - is_conv env sigma c' c + is_conv env sigma (EConstr.of_constr c') (EConstr.of_constr c) else false) in let rec sorec ctx env subst p t = diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 72cf310100..a4d943cfa6 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -502,7 +502,7 @@ let rec detype flags avoid env sigma t = let pb = Environ.lookup_projection p (snd env) in let body = pb.Declarations.proj_body in let ty = Retyping.get_type_of (snd env) sigma c in - let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in + let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma (EConstr.of_constr ty) in let body' = strip_lam_assum body in let body' = subst_instance_constr u body' in substl (c :: List.rev args) body' diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 194d0b297c..f54a57d57d 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -78,6 +78,7 @@ type flex_kind_of_term = | Flexible of existential let flex_kind_of_term ts env evd c sk = + let c = EConstr.Unsafe.to_constr c in match kind_of_term c with | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env evd c) @@ -88,10 +89,12 @@ let flex_kind_of_term ts env evd c sk = | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false +let zip evd (c, stk) = EConstr.Unsafe.to_constr (Stack.zip evd (c, stk)) + let apprec_nohdbeta ts env evd c = - let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in + let (t,sk as appr) = Reductionops.whd_nored_state evd (EConstr.of_constr c, []) in if Stack.not_purely_applicative sk - then Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state + then zip evd (fst (whd_betaiota_deltazeta_for_iota_state ts env evd Cst_stack.empty appr)) else c @@ -135,6 +138,8 @@ let occur_rigidly (evk,_ as ev) evd t = projection would have been reduced) *) let check_conv_record env sigma (t1,sk1) (t2,sk2) = + let t1 = EConstr.Unsafe.to_constr t1 in + let t2 = EConstr.Unsafe.to_constr t2 in let (proji, u), arg = Universes.global_app_of_constr t1 in let canon_s,sk2_effective = try @@ -143,7 +148,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let _, a, b = destProd (Evarutil.nf_evar sigma t2) in if EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b) then lookup_canonical_conversion (proji, Prod_cs), - (Stack.append_app [|a;pop (EConstr.of_constr b)|] Stack.empty) + (Stack.append_app [|EConstr.of_constr a;EConstr.of_constr (pop (EConstr.of_constr b))|] Stack.empty) else raise Not_found | Sort s -> lookup_canonical_conversion @@ -162,12 +167,12 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = | Some c -> (* A primitive projection applied to c *) let ty = Retyping.get_type_of ~lax:true env sigma c in let (i,u), ind_args = - try Inductiveops.find_mrectype env sigma ty + try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with _ -> raise Not_found - in Stack.append_app_list ind_args Stack.empty, c, sk1 + in Stack.append_app_list (List.map EConstr.of_constr ind_args) Stack.empty, c, sk1 | None -> match Stack.strip_n_app nparams sk1 with - | Some (params1, c1, extra_args1) -> params1, c1, extra_args1 + | Some (params1, c1, extra_args1) -> params1, EConstr.Unsafe.to_constr c1, extra_args1 | _ -> raise Not_found in let us2,extra_args2 = let l_us = List.length us in @@ -180,9 +185,9 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let t' = subst_univs_level_constr subst t' in let bs' = List.map (subst_univs_level_constr subst) bs in let h, _ = decompose_app_vect sigma (EConstr.of_constr t') in - ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), - (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, - (n,Stack.zip(t2,sk2)) + ctx',(h, t2),c',bs',(Stack.append_app_list (List.map EConstr.of_constr params) Stack.empty,params1), + (Stack.append_app_list (List.map EConstr.of_constr us) Stack.empty,us2),(extra_args1,extra_args2),c1, + (n, zip sigma (EConstr.of_constr t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -212,10 +217,11 @@ let ise_exact ise x1 x2 = | Some _, Success i -> UnifFailure (i,NotSameArgSize) let ise_array2 evd f v1 v2 = + let inj c = EConstr.Unsafe.to_constr c in let rec allrec i = function | -1 -> Success i | n -> - match f i v1.(n) v2.(n) with + match f i (inj v1.(n)) (inj v2.(n)) with | Success i' -> allrec i' (n-1) | UnifFailure _ as x -> x in let lv1 = Array.length v1 in @@ -225,28 +231,35 @@ let ise_array2 evd f v1 v2 = (* Applicative node of stack are read from the outermost to the innermost but are unified the other way. *) let rec ise_app_stack2 env f evd sk1 sk2 = + let inj = EConstr.Unsafe.to_constr in match sk1,sk2 with | Stack.App node1 :: q1, Stack.App node2 :: q2 -> let (t1,l1) = Stack.decomp_node_last node1 q1 in let (t2,l2) = Stack.decomp_node_last node2 q2 in begin match ise_app_stack2 env f evd l1 l2 with |(_,UnifFailure _) as x -> x - |x,Success i' -> x,f env i' CONV t1 t2 + |x,Success i' -> x,f env i' CONV (inj t1) (inj t2) end | _, _ -> (sk1,sk2), Success evd +let push_rec_types pfix env = + let (i, c, t) = pfix in + let inj c = EConstr.Unsafe.to_constr c in + push_rec_types (i, Array.map inj c, Array.map inj t) env + (* This function tries to unify 2 stacks element by element. It works from the end to the beginning. If it unifies a non empty suffix of stacks but not the entire stacks, the first part of the answer is Some(the remaining prefixes to tackle)) *) let ise_stack2 no_app env evd f sk1 sk2 = + let inj = EConstr.Unsafe.to_constr in let rec ise_stack2 deep i sk1 sk2 = let fail x = if deep then Some (List.rev sk1, List.rev sk2), Success i else None, x in match sk1, sk2 with | [], [] -> None, Success i | Stack.Case (_,t1,c1,_)::q1, Stack.Case (_,t2,c2,_)::q2 -> - (match f env i CONV t1 t2 with + (match f env i CONV (inj t1) (inj t2) with | Success i' -> (match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with | Success i'' -> ise_stack2 true i'' q1 q2 @@ -279,6 +292,7 @@ let ise_stack2 no_app env evd f sk1 sk2 = (* Make sure that the matching suffix is the all stack *) let exact_ise_stack2 env evd f sk1 sk2 = + let inj = EConstr.Unsafe.to_constr in let rec ise_stack2 i sk1 sk2 = match sk1, sk2 with | [], [] -> Success i @@ -286,7 +300,7 @@ let exact_ise_stack2 env evd f sk1 sk2 = ise_and i [ (fun i -> ise_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2); - (fun i -> f env i CONV t1 t2)] + (fun i -> f env i CONV (inj t1) (inj t2))] | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -344,19 +358,19 @@ let rec evar_conv_x ts env evd pbty term1 term2 = let term2 = apprec_nohdbeta (fst ts) env evd term2 in let default () = evar_eqappr_x ts env evd pbty - (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) - (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (EConstr.of_constr term1,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (EConstr.of_constr term2,Stack.empty), Cst_stack.empty) in begin match kind_of_term term1, kind_of_term term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) -> (match solve_simple_eqn (evar_conv_x ts) env evd - (position_problem true pbty,ev,term2) with + (position_problem true pbty,ev, EConstr.of_constr term2) with | UnifFailure (_,OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) | _, Evar ev when Evd.is_undefined evd (fst ev) -> (match solve_simple_eqn (evar_conv_x ts) env evd - (position_problem false pbty,ev,term1) with + (position_problem false pbty,ev, EConstr.of_constr term1) with | UnifFailure (_, OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) @@ -369,23 +383,25 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty UnifFailure (i, NotSameHead) in let miller_pfenning on_left fallback ev lF tM evd = + let lF = List.map EConstr.Unsafe.to_constr lF in match is_unification_pattern_evar env evd ev lF tM with | None -> fallback () | Some l1' -> (* Miller-Pfenning's patterns unification *) let t2 = nf_evar evd tM in let t2 = solve_pattern_eqn env evd l1' t2 in solve_simple_eqn (evar_conv_x ts) env evd - (position_problem on_left pbty,ev,t2) + (position_problem on_left pbty,ev, EConstr.of_constr t2) in let consume_stack on_left (termF,skF) (termO,skO) evd = + let inj = EConstr.Unsafe.to_constr in let switch f a b = if on_left then f a b else f b a in let not_only_app = Stack.not_purely_applicative skO in match switch (ise_stack2 not_only_app env evd (evar_conv_x ts)) skF skO with |Some (l,r), Success i' when on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (Stack.zip(termF,l)) (Stack.zip(termO,r)) + switch (evar_conv_x ts env i' pbty) (zip evd (termF,l)) (zip evd (termO,r)) |Some (r,l), Success i' when not on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (Stack.zip(termF,l)) (Stack.zip(termO,r)) - |None, Success i' -> switch (evar_conv_x ts env i' pbty) termF termO + switch (evar_conv_x ts env i' pbty) (zip evd (termF,l)) (zip evd (termO,r)) + |None, Success i' -> switch (evar_conv_x ts env i' pbty) (inj termF) (inj termO) |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) in let eta env evd onleft sk term sk' term' = @@ -394,15 +410,15 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let c = nf_evar evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state - (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in + (fst ts) env' evd Cst_stack.empty (EConstr.of_constr c'1, Stack.empty) in let out2 = whd_nored_state evd - (Stack.zip (term', sk' @ [Stack.Shift 1]), Stack.append_app [|mkRel 1|] Stack.empty), + (Stack.zip evd (term', sk' @ [Stack.Shift 1]), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in if onleft then evar_eqappr_x ts env' evd CONV out1 out2 else evar_eqappr_x ts env' evd CONV out2 out1 in let rigids env evd sk term sk' term' = - let univs = Universes.eq_constr_universes term term' in + let univs = EConstr.eq_constr_universes evd term term' in match univs with | Some univs -> ise_and evd [(fun i -> @@ -420,10 +436,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty match Stack.list_of_app_stack skF with | None -> quick_fail evd | Some lF -> - let tM = Stack.zip apprM in + let tM = zip evd apprM in miller_pfenning on_left (fun () -> if not_only_app then (* Postpone the use of an heuristic *) - switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) (Stack.zip apprF) tM + switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) (zip evd apprF) tM else quick_fail i) ev lF tM i and consume (termF,skF as apprF) (termM,skM as apprM) i = @@ -437,7 +453,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in let default i = ise_try i [f1; consume apprF apprM; delta] in - match kind_of_term termM with + match EConstr.kind evd termM with | Proj (p, c) when not (Stack.is_empty skF) -> (* Might be ?X args = p.c args', and we have to eta-expand the primitive projection if |args| >= |args'|+1. *) @@ -448,10 +464,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else let f = try - let termM' = Retyping.expand_projection env evd p c [] in + let termM' = Retyping.expand_projection env evd p (EConstr.Unsafe.to_constr c) [] in let apprM', cstsM' = whd_betaiota_deltazeta_for_iota_state - (fst ts) env evd cstsM (termM',skM) + (fst ts) env evd cstsM (EConstr.of_constr termM',skM) in let delta' i = switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) (apprM',cstsM') @@ -467,9 +483,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let flex_rigid on_left ev (termF, skF as apprF) (termR, skR as apprR) = let switch f a b = if on_left then f a b else f b a in let eta evd = - match kind_of_term termR with + match EConstr.kind evd termR with | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> - eta env evd false skR termR skF termF + eta env evd false skR (EConstr.Unsafe.to_constr termR) skF termF | Construct u -> eta_constructor ts env evd skR u skF termF | _ -> UnifFailure (evd,NotSameHead) in @@ -477,7 +493,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | None -> ise_try evd [consume_stack on_left apprF apprR; eta] | Some lF -> - let tR = Stack.zip apprR in + let tR = zip evd apprR in miller_pfenning on_left (fun () -> ise_try evd @@ -487,10 +503,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let i,tF = if isRel tR || isVar tR then (* Optimization so as to generate candidates *) - let i,ev = evar_absorb_arguments env i ev lF in + let i,ev = evar_absorb_arguments env i ev (List.map EConstr.Unsafe.to_constr lF) in i,mkEvar ev else - i,Stack.zip apprF in + i,zip evd apprF in switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) tF tR else @@ -516,20 +532,20 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let ev1' = whd_evar i' (mkEvar ev1) in if isEvar ev1' then solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar ev1',term2) + (position_problem true pbty,destEvar ev1', term2) else evar_eqappr_x ts env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + ((EConstr.of_constr ev1', sk1), csts1) ((term2, sk2), csts2) | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) let ev2' = whd_evar i' (mkEvar ev2) in if isEvar ev2' then solve_simple_eqn (evar_conv_x ts) env i' - (position_problem false pbty,destEvar ev2',Stack.zip(term1,r)) + (position_problem false pbty,destEvar ev2',Stack.zip evd (term1,r)) else evar_eqappr_x ts env evd pbty - ((ev2', sk1), csts1) ((term2, sk2), csts2) + ((EConstr.of_constr ev2', sk1), csts1) ((term2, sk2), csts2) | Some ([],r), Success i' -> (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) @@ -537,9 +553,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let ev1' = whd_evar i' (mkEvar ev1) in if isEvar ev1' then solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar ev1',Stack.zip(term2,r)) + (position_problem true pbty,destEvar ev1',Stack.zip evd (term2,r)) else evar_eqappr_x ts env evd pbty - ((ev1', sk1), csts1) ((term2, sk2), csts2) + ((EConstr.of_constr ev1', sk1), csts1) ((term2, sk2), csts2) | None, (UnifFailure _ as x) -> (* sk1 and sk2 have no common outer part *) if Stack.not_purely_applicative sk2 then @@ -584,13 +600,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_try evd [f1; f2] | Flexible ev1, MaybeFlexible v2 -> - flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) (EConstr.of_constr v2) | MaybeFlexible v1, Flexible ev2 -> - flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) (EConstr.of_constr v1) | MaybeFlexible v1, MaybeFlexible v2 -> begin - match kind_of_term term1, kind_of_term term2 with + match kind_of_term (EConstr.Unsafe.to_constr term1), kind_of_term (EConstr.Unsafe.to_constr term2) with | LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) -> let f1 i = (* FO *) ise_and i @@ -605,8 +621,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (EConstr.of_constr v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (EConstr.of_constr v2,sk2) in evar_eqappr_x ts env i pbty out1 out2 in ise_try evd [f1; f2] @@ -618,8 +634,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty [(fun i -> evar_conv_x ts env i CONV c c'); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (EConstr.of_constr v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (EConstr.of_constr v2,sk2) in evar_eqappr_x ts env i pbty out1 out2 in ise_try evd [f1; f2] @@ -627,7 +643,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Catch the p.c ~= p c' cases *) | Proj (p,c), Const (p',u) when eq_constant (Projection.constant p) p' -> let res = - try Some (destApp (Retyping.expand_projection env evd p c [])) + try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p c []))) with Retyping.RetypeError _ -> None in (match res with @@ -638,7 +654,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Const (p,u), Proj (p',c') when eq_constant p (Projection.constant p') -> let res = - try Some (destApp (Retyping.expand_projection env evd p' c' [])) + try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p' c' []))) with Retyping.RetypeError _ -> None in (match res with @@ -653,7 +669,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty allow this identification (first-order unification of universes). Otherwise fallback to unfolding. *) - let univs = Universes.eq_constr_universes term1 term2 in + let univs = EConstr.eq_constr_universes evd term1 term2 in match univs with | Some univs -> ise_and i [(fun i -> @@ -675,7 +691,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty if the first argument is a beta-redex (expand a constant only if necessary) or the second argument is potentially usable as a canonical projection or canonical value *) - let rec is_unnamed (hd, args) = match kind_of_term hd with + let rec is_unnamed (hd, args) = match EConstr.kind i hd with | (Var _|Construct _|Ind _|Const _|Prod _|Sort _) -> Stack.not_purely_applicative args | (CoFix _|Meta _|Rel _)-> true @@ -684,7 +700,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (subst1 b c, args))) + (fst ts) env i Cst_stack.empty (EConstr.Vars.subst1 b c, args))) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in @@ -692,34 +708,35 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (v2, applicative_stack))) in + (fst ts) env i Cst_stack.empty (EConstr.of_constr v2, applicative_stack))) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in - if (isLambda term1 || rhs_is_already_stuck) + if (EConstr.isLambda i term1 || rhs_is_already_stuck) && (not (Stack.not_purely_applicative sk1)) then evar_eqappr_x ~rhs_is_already_stuck ts env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + (fst ts) env i (Cst_stack.add_cst term1 csts1) (EConstr.of_constr v1,sk1)) (appr2,csts2) else evar_eqappr_x ts env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + (fst ts) env i (Cst_stack.add_cst term2 csts2) (EConstr.of_constr v2,sk2)) in ise_try evd [f1; f2; f3] end - | Rigid, Rigid when isLambda term1 && isLambda term2 -> - let (na1,c1,c'1) = destLambda term1 in - let (na2,c2,c'2) = destLambda term2 in + | Rigid, Rigid when EConstr.isLambda evd term1 && EConstr.isLambda evd term2 -> + let (na1,c1,c'1) = EConstr.destLambda evd term1 in + let (na2,c2,c'2) = EConstr.destLambda evd term2 in + let inj = EConstr.Unsafe.to_constr in assert app_empty; ise_and evd - [(fun i -> evar_conv_x ts env i CONV c1 c2); + [(fun i -> evar_conv_x ts env i CONV (inj c1) (inj c2)); (fun i -> - let c = nf_evar i c1 in + let c = nf_evar i (inj c1) in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV (inj c'1) (inj c'2))] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -733,7 +750,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty and f4 i = evar_eqappr_x ts env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) + (fst ts) env i (Cst_stack.add_cst term1 csts1) (EConstr.of_constr v1,sk1)) (appr2,csts2) in ise_try evd [f3; f4] @@ -747,19 +764,20 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty and f4 i = evar_eqappr_x ts env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + (fst ts) env i (Cst_stack.add_cst term2 csts2) (EConstr.of_constr v2,sk2)) in ise_try evd [f3; f4] (* Eta-expansion *) - | Rigid, _ when isLambda term1 && (* if ever ill-typed: *) List.is_empty sk1 -> - eta env evd true sk1 term1 sk2 term2 + | Rigid, _ when EConstr.isLambda evd term1 && (* if ever ill-typed: *) List.is_empty sk1 -> + eta env evd true sk1 (EConstr.Unsafe.to_constr term1) sk2 term2 - | _, Rigid when isLambda term2 && (* if ever ill-typed: *) List.is_empty sk2 -> - eta env evd false sk2 term2 sk1 term1 + | _, Rigid when EConstr.isLambda evd term2 && (* if ever ill-typed: *) List.is_empty sk2 -> + eta env evd false sk2 (EConstr.Unsafe.to_constr term2) sk1 term1 | Rigid, Rigid -> begin - match kind_of_term term1, kind_of_term term2 with + let inj = EConstr.Unsafe.to_constr in + match EConstr.kind evd term1, EConstr.kind evd term2 with | Sort s1, Sort s2 when app_empty -> (try @@ -774,11 +792,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd - [(fun i -> evar_conv_x ts env i CONV c1 c2); + [(fun i -> evar_conv_x ts env i CONV (inj c1) (inj c2)); (fun i -> - let c = nf_evar i c1 in + let c = nf_evar i (inj c1) in let na = Nameops.name_max n1 n2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty (inj c'1) (inj c'2))] | Rel x1, Rel x2 -> if Int.equal x1 x2 then @@ -822,10 +840,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else UnifFailure (evd,NotSameHead) | (Meta _, _) | (_, Meta _) -> + let inj = EConstr.Unsafe.to_constr in begin match ise_stack2 true env evd (evar_conv_x ts) sk1 sk2 with |_, (UnifFailure _ as x) -> x - |None, Success i' -> evar_conv_x ts env i' CONV term1 term2 - |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (Stack.zip (term1,sk1')) (Stack.zip (term2,sk2')) + |None, Success i' -> evar_conv_x ts env i' CONV (inj term1) (inj term2) + |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (inj (Stack.zip i' (term1,sk1'))) (inj (Stack.zip i' (term2,sk2'))) end | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _), _ -> @@ -905,8 +924,8 @@ and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = (try let l1' = Stack.tail pars sk1 in let l2' = - let term = Stack.zip (term2,sk2) in - List.map (fun p -> mkProj (Projection.make p false, term)) (Array.to_list projs) + let term = Stack.zip evd (term2,sk2) in + List.map (fun p -> EConstr.mkProj (Projection.make p false, term)) (Array.to_list projs) in exact_ise_stack2 env evd (evar_conv_x (fst ts, false)) l1' (Stack.append_app_list l2' Stack.empty) @@ -938,14 +957,14 @@ let first_order_unification ts env evd (ev1,l1) (term2,l2) = let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in ise_and evd (* First compare extra args for better failure message *) - [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1); + [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) (Array.map EConstr.of_constr rest2) (Array.map EConstr.of_constr l1)); (fun i -> (* Then instantiate evar unless already done by unifying args *) let t2 = mkApp(term2,deb2) in if is_defined i (fst ev1) then evar_conv_x ts env i CONV t2 (mkEvar ev1) else - solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1,t2))] + solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1, EConstr.of_constr t2))] let choose_less_dependent_instance evk evd term args = let evi = Evd.find_undefined evd evk in @@ -1153,7 +1172,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = let reason = ProblemBeyondCapabilities in UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> - let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in + let f env evd pbty x y = is_fconv ~reds:ts pbty env evd (EConstr.of_constr x) (EConstr.of_constr y) in Success (solve_refl ~can_drop:true f env evd (position_problem true pbty) evk1 args1 args2) | Evar ev1, Evar ev2 when app_empty -> diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 14947c8927..6f736e562d 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -43,11 +43,11 @@ val check_problems_are_solved : env -> evar_map -> unit (** Check if a canonical structure is applicable *) val check_conv_record : env -> evar_map -> - constr * types Stack.t -> constr * types Stack.t -> + state -> state -> Univ.universe_context_set * (constr * constr) - * constr * constr list * (constr Stack.t * constr Stack.t) * - (constr Stack.t * types Stack.t) * - (constr Stack.t * types Stack.t) * constr * + * constr * constr list * (EConstr.t Stack.t * EConstr.t Stack.t) * + (EConstr.t Stack.t * EConstr.t Stack.t) * + (EConstr.t Stack.t * EConstr.t Stack.t) * constr * (int option * constr) (** Try to solve problems of the form ?x[args] = c by second-order diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 06f619410c..3982edd1c4 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -33,7 +33,7 @@ let env_nf_evar sigma env = let env_nf_betaiotaevar sigma env = process_rel_context (fun d e -> - push_rel (RelDecl.map_constr (Reductionops.nf_betaiota sigma) d) e) env + push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota sigma (EConstr.of_constr c)) d) e) env (****************************************) (* Operations on value/type constraints *) @@ -78,7 +78,7 @@ let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in - let concl = Reductionops.whd_all evenv evd evi.evar_concl in + let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in let s = destSort concl in let evd1,(dom,u1) = let evd = Sigma.Unsafe.of_evar_map evd in @@ -131,7 +131,7 @@ let define_pure_evar_as_lambda env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in - let typ = Reductionops.whd_all evenv evd (evar_concl evi) in + let typ = Reductionops.whd_all evenv evd (EConstr.of_constr (evar_concl evi)) in let evd1,(na,dom,rng) = match kind_of_term typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ @@ -169,7 +169,7 @@ let define_evar_as_sort env evd (ev,args) = let evd, u = new_univ_variable univ_rigid evd in let evi = Evd.find_undefined evd ev in let s = Type u in - let concl = Reductionops.whd_all (evar_env evi) evd evi.evar_concl in + let concl = Reductionops.whd_all (evar_env evi) evd (EConstr.of_constr evi.evar_concl) in let sort = destSort concl in let evd' = Evd.define ev (mkSort s) evd in Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s @@ -181,7 +181,7 @@ let define_evar_as_sort env evd (ev,args) = let split_tycon loc env evd tycon = let rec real_split evd c = - let t = Reductionops.whd_all env evd c in + let t = Reductionops.whd_all env evd (EConstr.of_constr c) in match kind_of_term t with | Prod (na,dom,rng) -> evd, (na, dom, rng) | Evar ev (* ev is undefined because of whd_all *) -> diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index ea3ab17a75..17bb1406e2 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -145,7 +145,7 @@ let recheck_applications conv_algo env evdref t = let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in let rec aux i ty = if i < Array.length argsty then - match kind_of_term (whd_all env !evdref ty) with + match kind_of_term (whd_all env !evdref (EConstr.of_constr ty)) with | Prod (na, dom, codom) -> (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; @@ -525,7 +525,7 @@ let solve_pattern_eqn env sigma l c = l c in (* Warning: we may miss some opportunity to eta-reduce more since c' is not in normal form *) - shrink_eta c' + shrink_eta (EConstr.of_constr c') (*****************************************) (* Refining/solving unification problems *) @@ -683,7 +683,7 @@ let find_projectable_constructor env evd cstr k args cstr_subst = List.filter (fun (args',id) -> (* is_conv is maybe too strong (and source of useless computation) *) (* (at least expansion of aliases is needed) *) - Array.for_all2 (is_conv env evd) args args') l in + Array.for_all2 (fun c1 c2 -> is_conv env evd (EConstr.of_constr c1) (EConstr.of_constr c2)) args args') l in List.map snd l with Not_found -> [] @@ -808,7 +808,7 @@ let rec do_projection_effects define_fun env ty evd = function let evd = Evd.define evk (mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects define_fun env ty evd p in - let ty = whd_all env evd (Lazy.force ty) in + let ty = whd_all env evd (EConstr.of_constr (Lazy.force ty)) in if not (isSort ty) then (* Don't try to instantiate if a sort because if evar_concl is an evar it may commit to a univ level which is not the right @@ -1484,7 +1484,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = EConstr.Unsafe.to_constr (map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) self envk (EConstr.of_constr t)) in - let rhs = whd_beta evd rhs (* heuristic *) in + let rhs = whd_beta evd (EConstr.of_constr rhs) (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in let names = ref Idset.empty in @@ -1566,10 +1566,10 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = raise e | OccurCheckIn (evd,rhs) -> (* last chance: rhs actually reduces to ev *) - let c = whd_all env evd rhs in + let c = whd_all env evd (EConstr.of_constr rhs) in match kind_of_term c with | Evar (evk',argsv2) when Evar.equal evk evk' -> - solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c') + solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma (EConstr.of_constr c) (EConstr.of_constr c')) env evd pbty evk argsv argsv2 | _ -> raise (OccurCheckIn (evd,rhs)) @@ -1638,5 +1638,5 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1) | IllTypedInstance (env,t,u) -> UnifFailure (evd,InstanceNotSameType (evk1,env,t,u)) | IncompatibleCandidates -> - UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2)) + UnifFailure (evd,ConversionFailed (env,mkEvar ev1, EConstr.Unsafe.to_constr t2)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index cf059febf4..70e94b4dc7 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -52,7 +52,7 @@ val solve_evar_evar : ?force:bool -> env -> evar_map -> bool option -> existential -> existential -> evar_map val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> - bool option * existential * constr -> unification_result + bool option * existential * EConstr.t -> unification_result val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 9cf91a9476..4025ca8b84 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -153,7 +153,9 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let nparams = List.length vargs in let process_pos env depK pk = let rec prec env i sign p = - let p',largs = whd_allnolet_stack env sigma p in + let p',largs = whd_allnolet_stack env sigma (EConstr.of_constr p) in + let p' = EConstr.Unsafe.to_constr p' in + let largs = List.map EConstr.Unsafe.to_constr largs in match kind_of_term p' with | Prod (n,t,c) -> let d = LocalAssum (n,t) in @@ -170,7 +172,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = else base | _ -> - let t' = whd_all env sigma p in + let t' = whd_all env sigma (EConstr.of_constr p) in if Term.eq_constr p' t' then assert false else prec env i sign t' in @@ -229,7 +231,9 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let process_pos env fk = let rec prec env i hyps p = - let p',largs = whd_allnolet_stack env sigma p in + let p',largs = whd_allnolet_stack env sigma (EConstr.of_constr p) in + let p' = EConstr.Unsafe.to_constr p' in + let largs = List.map EConstr.Unsafe.to_constr largs in match kind_of_term p' with | Prod (n,t,c) -> let d = LocalAssum (n,t) in @@ -242,7 +246,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in applist(lift i fk,realargs@[arg]) | _ -> - let t' = whd_all env sigma p in + let t' = whd_all env sigma (EConstr.of_constr p) in if Term.eq_constr t' p' then assert false else prec env i hyps t' in @@ -261,7 +265,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = | None -> mkLambda_name env (n,t,process_constr (push_rel d env) (i+1) - (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1)]))) + (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)])))) (cprest,rest)) | Some(_,f_0) -> let nF = lift (i+1+decF) f_0 in @@ -269,7 +273,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let arg = process_pos env' nF (lift 1 t) in mkLambda_name env (n,t,process_constr env' (i+1) - (whd_beta Evd.empty (applist (lift 1 f, [(mkRel 1); arg]))) + (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg])))) (cprest,rest))) | (LocalDef (n,c,t) as d)::cprest, rest -> mkLetIn diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 29f57144a9..a3cca2ad87 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -444,15 +444,17 @@ let build_branch_type env dep p cs = (**************************************************) -let extract_mrectype t = - let (t, l) = decompose_app t in - match kind_of_term t with - | Ind ind -> (ind, l) +let extract_mrectype sigma t = + let open EConstr in + let (t, l) = decompose_app sigma t in + match EConstr.kind sigma t with + | Ind ind -> (ind, List.map EConstr.Unsafe.to_constr l) | _ -> raise Not_found let find_mrectype_vect env sigma c = - let (t, l) = decompose_appvect (whd_all env sigma c) in - match kind_of_term t with + let open EConstr in + let (t, l) = Termops.decompose_app_vect sigma (EConstr.of_constr (whd_all env sigma c)) in + match EConstr.kind sigma (EConstr.of_constr t) with | Ind ind -> (ind, l) | _ -> raise Not_found @@ -460,28 +462,34 @@ let find_mrectype env sigma c = let (ind, v) = find_mrectype_vect env sigma c in (ind, Array.to_list v) let find_rectype env sigma c = - let (t, l) = decompose_app (whd_all env sigma c) in - match kind_of_term t with + let open EConstr in + let (t, l) = decompose_app sigma (EConstr.of_constr (whd_all env sigma c)) in + match EConstr.kind sigma t with | Ind (ind,u as indu) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in if mib.mind_nparams > List.length l then raise Not_found; + let l = List.map EConstr.Unsafe.to_constr l in let (par,rargs) = List.chop mib.mind_nparams l in IndType((indu, par),rargs) | _ -> raise Not_found let find_inductive env sigma c = - let (t, l) = decompose_app (whd_all env sigma c) in - match kind_of_term t with + let open EConstr in + let (t, l) = decompose_app sigma (EConstr.of_constr (whd_all env sigma c)) in + match EConstr.kind sigma t with | Ind ind when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> Decl_kinds.CoFinite -> + let l = List.map EConstr.Unsafe.to_constr l in (ind, l) | _ -> raise Not_found let find_coinductive env sigma c = - let (t, l) = decompose_app (whd_all env sigma c) in - match kind_of_term t with + let open EConstr in + let (t, l) = decompose_app sigma (EConstr.of_constr (whd_all env sigma c)) in + match EConstr.kind sigma t with | Ind ind when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == Decl_kinds.CoFinite -> + let l = List.map EConstr.Unsafe.to_constr l in (ind, l) | _ -> raise Not_found @@ -490,12 +498,12 @@ let find_coinductive env sigma c = (* find appropriate names for pattern variables. Useful in the Case and Inversion (case_then_using et case_nodep_then_using) tactics. *) -let is_predicate_explicitly_dep env pred arsign = +let is_predicate_explicitly_dep env sigma pred arsign = let rec srec env pval arsign = - let pv' = whd_all env Evd.empty pval in - match kind_of_term pv', arsign with + let pv' = EConstr.of_constr (whd_all env sigma pval) in + match EConstr.kind sigma pv', arsign with | Lambda (na,t,b), (LocalAssum _)::arsign -> - srec (push_rel_assum (na,t) env) b arsign + srec (push_rel_assum (na, EConstr.Unsafe.to_constr t) env) b arsign | Lambda (na,_,t), _ -> (* The following code has an impact on the introduction names @@ -525,11 +533,11 @@ let is_predicate_explicitly_dep env pred arsign = | _ -> anomaly (Pp.str "Non eta-expanded dep-expanded \"match\" predicate") in - srec env pred arsign + srec env (EConstr.of_constr pred) arsign -let is_elim_predicate_explicitly_dependent env pred indf = +let is_elim_predicate_explicitly_dependent env sigma pred indf = let arsign,_ = get_arity env indf in - is_predicate_explicitly_dep env pred arsign + is_predicate_explicitly_dep env sigma pred arsign let set_names env n brty = let (ctxt,cl) = decompose_prod_n_assum n brty in @@ -545,7 +553,7 @@ let set_pattern_names env ind brv = mip.mind_nf_lc in Array.map2 (set_names env) arities brv -let type_case_branches_with_names env indspec p c = +let type_case_branches_with_names env sigma indspec p c = let (ind,args) = indspec in let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in @@ -554,7 +562,7 @@ let type_case_branches_with_names env indspec p c = (* Build case type *) let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in (* Adjust names *) - if is_elim_predicate_explicitly_dependent env p (ind,params) then + if is_elim_predicate_explicitly_dependent env sigma p (ind,params) then (set_pattern_names env (fst ind) lbrty, conclty) else (lbrty, conclty) @@ -600,7 +608,7 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = match mip.mind_arity with | RegularArity s -> sigma, subst_instance_constr u s.mind_user_arity | TemplateArity ar -> - let _,scl = Reduction.dest_arity env conclty in + let _,scl = splay_arity env sigma conclty in let ctx = List.rev mip.mind_arity_ctxt in let evdref = ref sigma in let ctx = @@ -609,6 +617,7 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = !evdref, mkArity (List.rev ctx,scl) let type_of_projection_knowing_arg env sigma p c ty = + let c = EConstr.Unsafe.to_constr c in let IndType(pars,realargs) = try find_rectype env sigma ty with Not_found -> diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 7bd616591f..1cfdef6e58 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -130,7 +130,7 @@ val has_dependent_elim : mutual_inductive_body -> bool val projection_nparams : projection -> int val projection_nparams_env : env -> projection -> int val type_of_projection_knowing_arg : env -> evar_map -> Projection.t -> - constr -> types -> types + EConstr.t -> EConstr.types -> types (** Extract information from an inductive family *) @@ -161,12 +161,12 @@ val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given a valid inductive type *) -val extract_mrectype : constr -> pinductive * constr list -val find_mrectype : env -> evar_map -> types -> pinductive * constr list -val find_mrectype_vect : env -> evar_map -> types -> pinductive * constr array -val find_rectype : env -> evar_map -> types -> inductive_type -val find_inductive : env -> evar_map -> types -> pinductive * constr list -val find_coinductive : env -> evar_map -> types -> pinductive * constr list +val extract_mrectype : evar_map -> EConstr.t -> pinductive * constr list +val find_mrectype : env -> evar_map -> EConstr.types -> pinductive * constr list +val find_mrectype_vect : env -> evar_map -> EConstr.types -> pinductive * constr array +val find_rectype : env -> evar_map -> EConstr.types -> inductive_type +val find_inductive : env -> evar_map -> EConstr.types -> pinductive * constr list +val find_coinductive : env -> evar_map -> EConstr.types -> pinductive * constr list (********************) @@ -175,7 +175,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : - env -> pinductive * constr list -> constr -> constr -> types array * types + env -> evar_map -> pinductive * constr list -> constr -> constr -> types array * types (** Annotation for cases *) val make_case_info : env -> inductive -> case_style -> case_info @@ -195,7 +195,7 @@ i*) (********************) val type_of_inductive_knowing_conclusion : - env -> evar_map -> Inductive.mind_specif puniverses -> types -> evar_map * types + env -> evar_map -> Inductive.mind_specif puniverses -> EConstr.types -> evar_map * types (********************) val control_only_guard : env -> types -> unit diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index 1e5f12b209..e45c920a32 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -92,13 +92,13 @@ let construct_of_constr_const env tag typ = let construct_of_constr_block = construct_of_constr false -let build_branches_type env (mind,_ as _ind) mib mip u params dep p = +let build_branches_type env sigma (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = let typi = type_constructor mind mib u cty params in - let decl,indapp = Reductionops.splay_prod env Evd.empty typi in + let decl,indapp = Reductionops.splay_prod env sigma (EConstr.of_constr typi) in let decl_with_letin,_ = decompose_prod_assum typi in let ind,cargs = find_rectype_a env indapp in let nparams = Array.length params in @@ -172,9 +172,9 @@ let branch_of_switch lvl ans bs = bs ci in Array.init (Array.length tbl) branch -let rec nf_val env v typ = +let rec nf_val env sigma v typ = match kind_of_value v with - | Vaccu accu -> nf_accu env accu + | Vaccu accu -> nf_accu env sigma accu | Vfun f -> let lvl = nb_rel env in let name,dom,codom = @@ -184,44 +184,44 @@ let rec nf_val env v typ = (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in let env = push_rel (LocalAssum (name,dom)) env in - let body = nf_val env (f (mk_rel_accu lvl)) codom in + let body = nf_val env sigma (f (mk_rel_accu lvl)) codom in mkLambda(name,dom,body) | Vconst n -> construct_of_constr_const env n typ | Vblock b -> let capp,ctyp = construct_of_constr_block env (block_tag b) typ in - let args = nf_bargs env b ctyp in + let args = nf_bargs env sigma b ctyp in mkApp(capp,args) -and nf_type env v = +and nf_type env sigma v = match kind_of_value v with - | Vaccu accu -> nf_accu env accu + | Vaccu accu -> nf_accu env sigma accu | _ -> assert false -and nf_type_sort env v = +and nf_type_sort env sigma v = match kind_of_value v with | Vaccu accu -> - let t,s = nf_accu_type env accu in + let t,s = nf_accu_type env sigma accu in let s = try destSort s with DestKO -> assert false in t, s | _ -> assert false -and nf_accu env accu = +and nf_accu env sigma accu = let atom = atom_of_accu accu in - if Int.equal (accu_nargs accu) 0 then nf_atom env atom + if Int.equal (accu_nargs accu) 0 then nf_atom env sigma atom else - let a,typ = nf_atom_type env atom in - let _, args = nf_args env accu typ in + let a,typ = nf_atom_type env sigma atom in + let _, args = nf_args env sigma accu typ in mkApp(a,Array.of_list args) -and nf_accu_type env accu = +and nf_accu_type env sigma accu = let atom = atom_of_accu accu in - if Int.equal (accu_nargs accu) 0 then nf_atom_type env atom + if Int.equal (accu_nargs accu) 0 then nf_atom_type env sigma atom else - let a,typ = nf_atom_type env atom in - let t, args = nf_args env accu typ in + let a,typ = nf_atom_type env sigma atom in + let t, args = nf_args env sigma accu typ in mkApp(a,Array.of_list args), t -and nf_args env accu t = +and nf_args env sigma accu t = let aux arg (t,l) = let _,dom,codom = try decompose_prod env t with @@ -229,13 +229,13 @@ and nf_args env accu t = CErrors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in - let c = nf_val env arg dom in + let c = nf_val env sigma arg dom in (subst1 c codom, c::l) in let t,l = List.fold_right aux (args_of_accu accu) (t,[]) in t, List.rev l -and nf_bargs env b t = +and nf_bargs env sigma b t = let t = ref t in let len = block_size b in Array.init len @@ -246,10 +246,10 @@ and nf_bargs env b t = CErrors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in - let c = nf_val env (block_field b i) dom in + let c = nf_val env sigma (block_field b i) dom in t := subst1 c codom; c) -and nf_atom env atom = +and nf_atom env sigma atom = match atom with | Arel i -> mkRel (nb_rel env - i) | Aconstant cst -> mkConstU cst @@ -257,19 +257,19 @@ and nf_atom env atom = | Asort s -> mkSort s | Avar id -> mkVar id | Aprod(n,dom,codom) -> - let dom = nf_type env dom in + let dom = nf_type env sigma dom in let vn = mk_rel_accu (nb_rel env) in let env = push_rel (LocalAssum (n,dom)) env in - let codom = nf_type env (codom vn) in + let codom = nf_type env sigma (codom vn) in mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv | Aevar (ev,_) -> mkEvar ev | Aproj(p,c) -> - let c = nf_accu env c in + let c = nf_accu env sigma c in mkProj(Projection.make p true,c) - | _ -> fst (nf_atom_type env atom) + | _ -> fst (nf_atom_type env sigma atom) -and nf_atom_type env atom = +and nf_atom_type env sigma atom = match atom with | Arel i -> let n = (nb_rel env - i) in @@ -283,7 +283,7 @@ and nf_atom_type env atom = | Avar id -> mkVar id, type_of_var env id | Acase(ans,accu,p,bs) -> - let a,ta = nf_accu_type env accu in + let a,ta = nf_accu_type env sigma accu in let ((mind,_),u as ind),allargs = find_rectype_a env ta in let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in @@ -292,14 +292,14 @@ and nf_atom_type env atom = hnf_prod_applist env (Inductiveops.type_of_inductive env ind) (Array.to_list params) in let pT = whd_all env pT in - let dep, p = nf_predicate env ind mip params p pT in + let dep, p = nf_predicate env sigma ind mip params p pT in (* Calcul du type des branches *) - let btypes = build_branches_type env (fst ind) mib mip u params dep p in + let btypes = build_branches_type env sigma (fst ind) mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = let decl,decl_with_letin,codom = btypes.(i) in - let b = nf_val (Termops.push_rels_assum decl env) v codom in + let b = nf_val (Termops.push_rels_assum decl env) sigma v codom in Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin in let branchs = Array.mapi mkbranch bsw in @@ -307,7 +307,7 @@ and nf_atom_type env atom = let ci = ans.asw_ci in mkCase(ci, p, a, branchs), tcase | Afix(tt,ft,rp,s) -> - let tt = Array.map (fun t -> nf_type env t) tt in + let tt = Array.map (fun t -> nf_type env sigma t) tt in let name = Array.map (fun _ -> (Name (id_of_string "Ffix"))) tt in let lvl = nb_rel env in let nbfix = Array.length ft in @@ -316,37 +316,37 @@ and nf_atom_type env atom = let env = push_rec_types (name,tt,[||]) env in (* We lift here because the types of arguments (in tt) will be evaluated in an environment where the fixpoints have been pushed *) - let norm_body i v = nf_val env (napply v fargs) (lift nbfix tt.(i)) in + let norm_body i v = nf_val env sigma (napply v fargs) (lift nbfix tt.(i)) in let ft = Array.mapi norm_body ft in mkFix((rp,s),(name,tt,ft)), tt.(s) | Acofix(tt,ft,s,_) | Acofixe(tt,ft,s,_) -> - let tt = Array.map (nf_type env) tt in + let tt = Array.map (nf_type env sigma) tt in let name = Array.map (fun _ -> (Name (id_of_string "Fcofix"))) tt in let lvl = nb_rel env in let fargs = mk_rels_accu lvl (Array.length ft) in let env = push_rec_types (name,tt,[||]) env in - let ft = Array.mapi (fun i v -> nf_val env (napply v fargs) tt.(i)) ft in + let ft = Array.mapi (fun i v -> nf_val env sigma (napply v fargs) tt.(i)) ft in mkCoFix(s,(name,tt,ft)), tt.(s) | Aprod(n,dom,codom) -> - let dom,s1 = nf_type_sort env dom in + let dom,s1 = nf_type_sort env sigma dom in let vn = mk_rel_accu (nb_rel env) in let env = push_rel (LocalAssum (n,dom)) env in - let codom,s2 = nf_type_sort env (codom vn) in + let codom,s2 = nf_type_sort env sigma (codom vn) in mkProd(n,dom,codom), mkSort (sort_of_product env s1 s2) | Aevar(ev,ty) -> - let ty = nf_type env ty in + let ty = nf_type env sigma ty in mkEvar ev, ty | Ameta(mv,ty) -> - let ty = nf_type env ty in + let ty = nf_type env sigma ty in mkMeta mv, ty | Aproj(p,c) -> - let c,tc = nf_accu_type env c in + let c,tc = nf_accu_type env sigma c in let cj = make_judge c tc in let uj = Typeops.judge_of_projection env (Projection.make p true) cj in uj.uj_val, uj.uj_type -and nf_predicate env ind mip params v pT = +and nf_predicate env sigma ind mip params v pT = match kind_of_value v, kind_of_term pT with | Vfun f, Prod _ -> let k = nb_rel env in @@ -358,7 +358,7 @@ and nf_predicate env ind mip params v pT = (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in let dep,body = - nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in @@ -368,9 +368,9 @@ and nf_predicate env ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in - let body = nf_type (push_rel (LocalAssum (name,dom)) env) vb in + let body = nf_type (push_rel (LocalAssum (name,dom)) env) sigma vb in true, mkLambda(name,dom,body) - | _, _ -> false, nf_type env v + | _, _ -> false, nf_type env sigma v let evars_of_evar_map sigma = { Nativelambda.evars_val = Evd.existential_opt_value sigma; @@ -382,13 +382,12 @@ let native_norm env sigma c ty = error "Native_compute reduction has been disabled at configure time." else let penv = Environ.pre_env env in - let sigma = evars_of_evar_map sigma in (* Format.eprintf "Numbers of free variables (named): %i\n" (List.length vl1); Format.eprintf "Numbers of free variables (rel): %i\n" (List.length vl2); *) let ml_filename, prefix = Nativelib.get_ml_filename () in - let code, upd = mk_norm_code penv sigma prefix c in + let code, upd = mk_norm_code penv (evars_of_evar_map sigma) prefix c in match Nativelib.compile ml_filename code with | true, fn -> if !Flags.debug then Feedback.msg_debug (Pp.str "Running norm ..."); @@ -397,7 +396,7 @@ let native_norm env sigma c ty = let t1 = Sys.time () in let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - let res = nf_val env !Nativelib.rt1 ty in + let res = nf_val env sigma !Nativelib.rt1 ty in let t2 = Sys.time () in let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 9b572f376d..3a6d4f36cc 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -700,7 +700,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if Int.equal npars 0 then [] else try - let IndType (indf, args) = find_rectype env.ExtraEnv.env !evdref ty in + let IndType (indf, args) = find_rectype env.ExtraEnv.env !evdref (EConstr.of_constr ty) in let ((ind',u'),pars) = dest_ind_family indf in if eq_ind ind ind' then pars else (* Let the usual code throw an error *) [] @@ -723,7 +723,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | c::rest -> let argloc = loc_of_glob_constr c in let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in - let resty = whd_all env.ExtraEnv.env !evdref resj.uj_type in + let resty = whd_all env.ExtraEnv.env !evdref (EConstr.of_constr resj.uj_type) in match kind_of_term resty with | Prod (na,c1,c2) -> let tycon = Some c1 in @@ -834,7 +834,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | GLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = - try find_rectype env.ExtraEnv.env !evdref cj.uj_type + try find_rectype env.ExtraEnv.env !evdref (EConstr.of_constr cj.uj_type) with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj @@ -894,7 +894,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (Array.to_list cs.cs_concl_realargs) @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env.ExtraEnv.env !evdref lp inst in + let fty = hnf_lam_applist env.ExtraEnv.env !evdref (EConstr.of_constr lp) (List.map EConstr.of_constr inst) in let fj = pretype (mk_tycon fty) env_f evdref lvar d in let v = let ind,_ = dest_ind_family indf in @@ -924,7 +924,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | GIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = - try find_rectype env.ExtraEnv.env !evdref cj.uj_type + try find_rectype env.ExtraEnv.env !evdref (EConstr.of_constr cj.uj_type) with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in @@ -948,7 +948,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in + let typ = lift (- nar) (beta_applist !evdref (EConstr.of_constr pred,[EConstr.of_constr cj.uj_val])) in pred, typ | None -> let p = match tycon with @@ -963,7 +963,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let f cs b = let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let pi = beta_applist !evdref (EConstr.of_constr pi, [EConstr.of_constr (build_dependent_constructor cs)]) in let csgn = if not !allow_anonymous_refs then List.map (set_name Anonymous) cs.cs_args @@ -1046,11 +1046,11 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = with Not_found -> try let (n,_,t') = lookup_rel_id id (rel_context env) in - if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found + if is_conv env.ExtraEnv.env !evdref (EConstr.of_constr t) (EConstr.of_constr t') then mkRel n, update else raise Not_found with Not_found -> try let t' = env |> lookup_named id |> NamedDecl.get_type in - if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found + if is_conv env.ExtraEnv.env !evdref (EConstr.of_constr t) (EConstr.of_constr t') then mkVar id, update else raise Not_found with Not_found -> user_err ~loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ @@ -1068,7 +1068,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let s = let sigma = !evdref in let t = Retyping.get_type_of env.ExtraEnv.env sigma v in - match kind_of_term (whd_all env.ExtraEnv.env sigma t) with + match kind_of_term (whd_all env.ExtraEnv.env sigma (EConstr.of_constr t)) with | Sort s -> s | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index e897d5f5c5..062e4a0683 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -202,7 +202,7 @@ let compute_canonical_projections warn (con,ind) = let v = (mkConstU (con,u)) in let ctx = Univ.ContextSet.of_context ctx in let c = Environ.constant_value_in env (con,u) in - let lt,t = Reductionops.splay_lam env Evd.empty c in + let lt,t = Reductionops.splay_lam env Evd.empty (EConstr.of_constr c) in let lt = List.rev_map snd lt in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = @@ -302,7 +302,7 @@ let check_and_decompose_canonical_structure ref = let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref in - let body = snd (splay_lam (Global.env()) Evd.empty vc) in + let body = snd (splay_lam (Global.env()) Evd.empty (EConstr.of_constr vc)) (** FIXME *) in let f,args = match kind_of_term body with | App (f,args) -> f,args | _ -> error_not_structure ref in @@ -323,6 +323,7 @@ let lookup_canonical_conversion (proj,pat) = let is_open_canonical_projection env sigma (c,args) = try + let c = EConstr.Unsafe.to_constr c in let ref = global_of_constr c in let n = find_projection_nparams ref in (** Check if there is some canonical projection attached to this structure *) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 4a176760c2..405963a9ca 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -72,6 +72,6 @@ val pr_cs_pattern : cs_pattern -> Pp.std_ppcmds val lookup_canonical_conversion : (global_reference * cs_pattern) -> constr * obj_typ val declare_canonical_structure : global_reference -> unit val is_open_canonical_projection : - Environ.env -> Evd.evar_map -> (constr * constr Reductionops.Stack.t) -> bool + Environ.env -> Evd.evar_map -> Reductionops.state -> bool val canonical_projections : unit -> ((global_reference * cs_pattern) * obj_typ) list diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 820974888e..69d47e8e69 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -156,6 +156,7 @@ end (** Machinery about stack of unfolded constants *) module Cst_stack = struct + open EConstr (** constant * params * args - constant applied to params = term in head applied to args @@ -191,8 +192,8 @@ module Cst_stack = struct | (cst,params,[])::_ -> Some(cst,params) | _ -> None - let reference t = match best_cst t with - | Some (c, _) when Term.isConst c -> Some (fst (Term.destConst c)) + let reference sigma t = match best_cst t with + | Some (c, _) when isConst sigma c -> Some (fst (destConst sigma c)) | _ -> None (** [best_replace d cst_l c] makes the best replacement for [d] @@ -201,14 +202,14 @@ module Cst_stack = struct let reconstruct_head = List.fold_left (fun t (i,args) -> mkApp (t,Array.sub args i (Array.length args - i))) in List.fold_right - (fun (cst,params,args) t -> Termops.replace_term sigma - (EConstr.of_constr (reconstruct_head d args)) - (EConstr.of_constr (applist (cst, List.rev params))) - (EConstr.of_constr t)) cst_l c + (fun (cst,params,args) t -> EConstr.of_constr (Termops.replace_term sigma + (reconstruct_head d args) + (applist (cst, List.rev params)) + t)) cst_l c let pr l = let open Pp in - let p_c = Termops.print_constr in + let p_c c = Termops.print_constr (EConstr.Unsafe.to_constr c) in prlist_with_sep pr_semicolon (fun (c,params,args) -> hov 1 (str"(" ++ p_c c ++ str ")" ++ spc () ++ pr_sequence p_c params ++ spc () ++ str "(args:" ++ @@ -220,6 +221,7 @@ end (** The type of (machine) stacks (= lambda-bar-calculus' contexts) *) module Stack : sig + open EConstr type 'a app_node val pr_app_node : ('a -> Pp.std_ppcmds) -> 'a app_node -> Pp.std_ppcmds @@ -231,7 +233,7 @@ sig | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t | Proj of int * int * projection * Cst_stack.t - | Fix of fixpoint * 'a t * Cst_stack.t + | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t | Shift of int | Update of 'a @@ -242,10 +244,10 @@ sig val append_app : 'a array -> 'a t -> 'a t val decomp : 'a t -> ('a * 'a t) option val decomp_node_last : 'a app_node -> 'a t -> ('a * 'a t) - val equal : ('a * int -> 'a * int -> bool) -> (fixpoint * int -> fixpoint * int -> bool) + val equal : ('a * int -> 'a * int -> bool) -> (('a, 'a) pfixpoint * int -> ('a, 'a) pfixpoint * int -> bool) -> 'a t -> 'a t -> (int * int) option val compare_shape : 'a t -> 'a t -> bool - val map : (constr -> constr) -> constr t -> constr t + val map : ('a -> 'a) -> 'a t -> 'a t val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> constr t -> constr t -> 'a * int * int val append_app_list : 'a list -> 'a t -> 'a t @@ -258,10 +260,11 @@ sig val args_size : 'a t -> int val tail : int -> 'a t -> 'a t val nth : 'a t -> int -> 'a - val best_state : constr * constr t -> Cst_stack.t -> constr * constr t - val zip : ?refold:bool -> constr * constr t -> constr + val best_state : evar_map -> constr * constr t -> Cst_stack.t -> constr * constr t + val zip : ?refold:bool -> evar_map -> constr * constr t -> constr end = struct + open EConstr type 'a app_node = int * 'a array * int (* first releavnt position, arguments, last relevant position *) @@ -286,7 +289,7 @@ struct | App of 'a app_node | Case of Term.case_info * 'a * 'a array * Cst_stack.t | Proj of int * int * projection * Cst_stack.t - | Fix of fixpoint * 'a t * Cst_stack.t + | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int * int list * 'a t * Cst_stack.t | Shift of int | Update of 'a @@ -305,7 +308,7 @@ struct str "ZProj(" ++ int n ++ pr_comma () ++ int m ++ pr_comma () ++ pr_con (Projection.constant p) ++ str ")" | Fix (f,args,cst) -> - str "ZFix(" ++ Termops.pr_fix Termops.print_constr f + str "ZFix(" ++ Termops.pr_fix pr_c f ++ pr_comma () ++ pr pr_c args ++ str ")" | Cst (mem,curr,remains,params,cst_l) -> str "ZCst(" ++ pr_cst_member pr_c mem ++ pr_comma () ++ int curr @@ -533,11 +536,11 @@ struct | None -> raise Not_found (** This function breaks the abstraction of Cst_stack ! *) - let best_state (_,sk as s) l = + let best_state sigma (_,sk as s) l = let rec aux sk def = function |(cst, params, []) -> (cst, append_app_list (List.rev params) sk) |(cst, params, (i,t)::q) -> match decomp sk with - | Some (el,sk') when Constr.equal el t.(i) -> + | Some (el,sk') when EConstr.eq_constr sigma el t.(i) -> if i = pred (Array.length t) then aux sk' def (cst, params, q) else aux sk' def (cst, params, (succ i,t)::q) @@ -552,53 +555,66 @@ struct | Some (hd, sk) -> mkProj (p, hd), sk | None -> assert false - let rec zip ?(refold=false) = function + let zip ?(refold=false) sigma s = + let rec zip = function | f, [] -> f | f, (App (i,a,j) :: s) -> let a' = if Int.equal i 0 && Int.equal j (Array.length a - 1) then a else Array.sub a i (j - i + 1) in - zip ~refold (mkApp (f, a'), s) + zip (mkApp (f, a'), s) | f, (Case (ci,rt,br,cst_l)::s) when refold -> - zip ~refold (best_state (mkCase (ci,rt,f,br), s) cst_l) - | f, (Case (ci,rt,br,_)::s) -> zip ~refold (mkCase (ci,rt,f,br), s) + zip (best_state sigma (mkCase (ci,rt,f,br), s) cst_l) + | f, (Case (ci,rt,br,_)::s) -> zip (mkCase (ci,rt,f,br), s) | f, (Fix (fix,st,cst_l)::s) when refold -> - zip ~refold (best_state (mkFix fix, st @ (append_app [|f|] s)) cst_l) - | f, (Fix (fix,st,_)::s) -> zip ~refold + zip (best_state sigma (mkFix fix, st @ (append_app [|f|] s)) cst_l) + | f, (Fix (fix,st,_)::s) -> zip (mkFix fix, st @ (append_app [|f|] s)) | f, (Cst (cst,_,_,params,cst_l)::s) when refold -> - zip ~refold (best_state (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) + zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) | f, (Cst (cst,_,_,params,_)::s) -> - zip ~refold (constr_of_cst_member cst (params @ (append_app [|f|] s))) - | f, (Shift n::s) -> zip ~refold (lift n f, s) + zip (constr_of_cst_member cst (params @ (append_app [|f|] s))) + | f, (Shift n::s) -> zip (Vars.lift n f, s) | f, (Proj (n,m,p,cst_l)::s) when refold -> - zip ~refold (best_state (mkProj (p,f),s) cst_l) - | f, (Proj (n,m,p,_)::s) -> zip ~refold (mkProj (p,f),s) + zip (best_state sigma (mkProj (p,f),s) cst_l) + | f, (Proj (n,m,p,_)::s) -> zip (mkProj (p,f),s) | _, (Update _::_) -> assert false + in + zip s + end (** The type of (machine) states (= lambda-bar-calculus' cuts) *) -type state = constr * constr Stack.t +type state = EConstr.t * EConstr.t Stack.t -type contextual_reduction_function = env -> evar_map -> constr -> constr -type reduction_function = contextual_reduction_function -type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } +type contextual_reduction_function = env -> evar_map -> EConstr.t -> constr +type reduction_function = contextual_reduction_function +type local_reduction_function = evar_map -> EConstr.t -> constr +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> EConstr.t -> (constr, 'r) Sigma.sigma } -type contextual_stack_reduction_function = - env -> evar_map -> constr -> constr * constr list -type stack_reduction_function = contextual_stack_reduction_function +type contextual_stack_reduction_function = + env -> evar_map -> EConstr.t -> EConstr.t * EConstr.t list +type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = - evar_map -> constr -> constr * constr list + evar_map -> EConstr.t -> EConstr.t * EConstr.t list -type contextual_state_reduction_function = - env -> evar_map -> state -> state -type state_reduction_function = contextual_state_reduction_function +type contextual_state_reduction_function = + env -> evar_map -> state -> state +type state_reduction_function = contextual_state_reduction_function type local_state_reduction_function = evar_map -> state -> state let pr_state (tm,sk) = let open Pp in - h 0 (Termops.print_constr tm ++ str "|" ++ cut () ++ Stack.pr Termops.print_constr sk) + let pr c = Termops.print_constr (EConstr.Unsafe.to_constr c) in + h 0 (pr tm ++ str "|" ++ cut () ++ Stack.pr pr sk) + +let local_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) (*************************************) (*** Reduction Functions Operators ***) @@ -612,19 +628,19 @@ let safe_meta_value sigma ev = let strong whdfun env sigma t = let rec strongrec env t = - let t = EConstr.of_constr (whdfun env sigma (EConstr.Unsafe.to_constr t)) in + let t = EConstr.of_constr (whdfun env sigma t) in map_constr_with_full_binders sigma push_rel strongrec env t in - EConstr.Unsafe.to_constr (strongrec env (EConstr.of_constr t)) + EConstr.Unsafe.to_constr (strongrec env t) let local_strong whdfun sigma = - let rec strongrec t = Constr.map strongrec (whdfun sigma t) in - strongrec + let rec strongrec t = EConstr.map sigma strongrec (EConstr.of_constr (whdfun sigma t)) in + fun c -> EConstr.Unsafe.to_constr (strongrec c) let rec strong_prodspine redfun sigma c = - let x = redfun sigma c in - match kind_of_term x with - | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun sigma b) - | _ -> x + let x = EConstr.of_constr (redfun sigma c) in + match EConstr.kind sigma x with + | Prod (na,a,b) -> mkProd (na, EConstr.Unsafe.to_constr a,strong_prodspine redfun sigma b) + | _ -> EConstr.Unsafe.to_constr x (*************************************) (*** Reduction using bindingss ***) @@ -634,31 +650,36 @@ let eta = CClosure.RedFlags.mkflags [CClosure.RedFlags.fETA] (* Beta Reduction tools *) -let apply_subst recfun env refold cst_l t stack = +let apply_subst recfun env sigma refold cst_l t stack = let rec aux env cst_l t stack = - match (Stack.decomp stack,kind_of_term t) with + match (Stack.decomp stack, EConstr.kind sigma t) with | Some (h,stacktl), Lambda (_,_,c) -> let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in aux (h::env) cst_l' c stacktl - | _ -> recfun cst_l (substl env t, stack) + | _ -> recfun sigma cst_l (EConstr.Vars.substl env t, stack) in aux env cst_l t stack -let stacklam recfun env t stack = - apply_subst (fun _ -> recfun) env false Cst_stack.empty t stack +let stacklam recfun env sigma t stack = + apply_subst (fun _ _ s -> recfun s) env sigma false Cst_stack.empty t stack + +let beta_app sigma (c,l) = + let zip s = Stack.zip sigma s in + stacklam zip [] sigma c (Stack.append_app l Stack.empty) -let beta_applist (c,l) = - stacklam Stack.zip [] c (Stack.append_app_list l Stack.empty) +let beta_applist sigma (c,l) = + let zip s = Stack.zip sigma s in + EConstr.Unsafe.to_constr (stacklam zip [] sigma c (Stack.append_app_list l Stack.empty)) (* Iota reduction tools *) type 'a miota_args = { - mP : constr; (* the result type *) - mconstr : constr; (* the constructor *) + mP : EConstr.t; (* the result type *) + mconstr : EConstr.t; (* the constructor *) mci : case_info; (* special info to re-build pattern *) mcargs : 'a list; (* the constructor's arguments *) mlf : 'a array } (* the branch code vector *) -let reducible_mind_case c = match kind_of_term c with +let reducible_mind_case sigma c = match EConstr.kind sigma c with | Construct _ | CoFix _ -> true | _ -> false @@ -672,9 +693,10 @@ let reducible_mind_case c = match kind_of_term c with f x := t. End M. Definition f := u. and say goodbye to any hope of refolding M.f this way ... *) -let magicaly_constant_of_fixbody env reference bd = function +let magicaly_constant_of_fixbody env sigma reference bd = function | Name.Anonymous -> bd | Name.Name id -> + let open EConstr in try let (cst_mod,cst_sect,_) = Constant.repr3 reference in let cst = Constant.make3 cst_mod cst_sect (Label.of_id id) in @@ -682,7 +704,7 @@ let magicaly_constant_of_fixbody env reference bd = function match constant_opt_value_in env (cst,u) with | None -> bd | Some t -> - let csts = Universes.eq_constr_universes t bd in + let csts = EConstr.eq_constr_universes sigma (EConstr.of_constr t) bd in begin match csts with | Some csts -> let subst = Universes.Constraints.fold (fun (l,d,r) acc -> @@ -696,7 +718,8 @@ let magicaly_constant_of_fixbody env reference bd = function with | Not_found -> bd -let contract_cofix ?env ?reference (bodynum,(names,types,bodies as typedbodies)) = +let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbodies)) = + let open EConstr in let nbodies = Array.length bodies in let make_Fi j = let ind = nbodies-j-1 in @@ -708,37 +731,40 @@ let contract_cofix ?env ?reference (bodynum,(names,types,bodies as typedbodies)) | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e r bd names.(ind) in + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in let closure = List.init nbodies make_Fi in - substl closure bodies.(bodynum) + Vars.substl closure bodies.(bodynum) (** Similar to the "fix" case below *) let reduce_and_refold_cofix recfun env sigma refold cst_l cofix sk = + let open EConstr in let raw_answer = let env = if refold then Some env else None in - contract_cofix ?env ?reference:(Cst_stack.reference cst_l) cofix in + contract_cofix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) cofix in apply_subst - (fun x (t,sk') -> + (fun sigma x (t,sk') -> let t' = if refold then Cst_stack.best_replace sigma (mkCoFix cofix) cst_l t else t in recfun x (t',sk')) - [] refold Cst_stack.empty raw_answer sk + [] sigma refold Cst_stack.empty raw_answer sk -let reduce_mind_case mia = - match kind_of_term mia.mconstr with +let reduce_mind_case sigma mia = + let open EConstr in + match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> (* let ncargs = (fst mia.mci).(i-1) in*) let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) | CoFix cofix -> - let cofix_def = contract_cofix cofix in + let cofix_def = contract_cofix sigma cofix in mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false (* contracts fix==FIX[nl;i](A1...Ak;[F1...Fk]{B1....Bk}) to produce Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) -let contract_fix ?env ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) = +let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) = + let open EConstr in let nbodies = Array.length recindices in let make_Fi j = let ind = nbodies-j-1 in @@ -750,26 +776,27 @@ let contract_fix ?env ?reference ((recindices,bodynum),(names,types,bodies as ty | Some e -> match reference with | None -> bd - | Some r -> magicaly_constant_of_fixbody e r bd names.(ind) in + | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in let closure = List.init nbodies make_Fi in - substl closure bodies.(bodynum) + Vars.substl closure bodies.(bodynum) (** First we substitute the Rel bodynum by the fixpoint and then we try to replace the fixpoint by the best constant from [cst_l] Other rels are directly substituted by constants "magically found from the context" in contract_fix *) let reduce_and_refold_fix recfun env sigma refold cst_l fix sk = + let open EConstr in let raw_answer = let env = if refold then None else Some env in - contract_fix ?env ?reference:(Cst_stack.reference cst_l) fix in + contract_fix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in apply_subst - (fun x (t,sk') -> + (fun sigma x (t,sk') -> let t' = if refold then Cst_stack.best_replace sigma (mkFix fix) cst_l t else t in recfun x (t',sk')) - [] refold Cst_stack.empty raw_answer sk + [] sigma refold Cst_stack.empty raw_answer sk let fix_recarg ((recindices,bodynum),_) stack = assert (0 <= bodynum && bodynum < Array.length recindices); @@ -802,51 +829,53 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> debug_RAKAM:=a); } -let equal_stacks (x, l) (y, l') = - let f_equal (x,lft1) (y,lft2) = Constr.equal (Vars.lift lft1 x) (Vars.lift lft2 y) in - let eq_fix (a,b) (c,d) = f_equal (Constr.mkFix a, b) (Constr.mkFix c, d) in +let equal_stacks sigma (x, l) (y, l') = + let open EConstr in + let f_equal (x,lft1) (y,lft2) = eq_constr sigma (Vars.lift lft1 x) (Vars.lift lft2 y) in + let eq_fix (a,b) (c,d) = f_equal (mkFix a, b) (mkFix c, d) in match Stack.equal f_equal eq_fix l l' with | None -> false | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = + let open EConstr in let open Context.Named.Declaration in - let rec whrec cst_l (x, stack as s) = + let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then let open Pp in + let pr c = Termops.print_constr (EConstr.Unsafe.to_constr c) in Feedback.msg_notice - (h 0 (str "<<" ++ Termops.print_constr x ++ + (h 0 (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr cst_l ++ - str "|" ++ cut () ++ Stack.pr Termops.print_constr stack ++ + str "|" ++ cut () ++ Stack.pr pr stack ++ str ">>")) in + let c0 = EConstr.kind sigma x in let fold () = let () = if !debug_RAKAM then let open Pp in Feedback.msg_notice (str "<><><><><>") in - (s,cst_l) + ((EConstr.of_kind c0, stack),cst_l) in - match kind_of_term x with + match c0 with | Rel n when CClosure.RedFlags.red_set flags CClosure.RedFlags.fDELTA -> (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack) + | LocalDef (_,body,_) -> whrec Cst_stack.empty (EConstr.of_constr (lift n body), stack) | _ -> fold ()) | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) -> (match lookup_named id env with | LocalDef (_,body,_) -> - whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack) + whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (EConstr.of_constr body, stack) | _ -> fold ()) - | Evar ev -> - (match safe_evar_value sigma ev with - | Some body -> whrec cst_l (body, stack) - | None -> fold ()) + | Evar ev -> fold () | Meta ev -> (match safe_meta_value sigma ev with - | Some body -> whrec cst_l (body, stack) + | Some body -> whrec cst_l (EConstr.of_constr body, stack) | None -> fold ()) | Const (c,u as const) when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) -> (match constant_opt_value_in env const with | None -> fold () | Some body -> + let body = EConstr.of_constr body in if not tactic_mode then whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) (body, stack) @@ -863,12 +892,12 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let (tm',sk'),cst_l' = whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) in - let rec is_case x = match kind_of_term x with + let rec is_case x = match EConstr.kind sigma x with | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x | App (hd, _) -> is_case hd | Case _ -> true | _ -> false in - if equal_stacks (x, app_sk) (tm', sk') + if equal_stacks sigma (x, app_sk) (tm', sk') || Stack.will_expose_iota sk' || is_case tm' then fold () @@ -896,7 +925,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | None -> let stack' = (c, Stack.Proj (npars, arg, p, cst_l) :: stack) in let stack'', csts = whrec Cst_stack.empty stack' in - if equal_stacks stack' stack'' then fold () + if equal_stacks sigma stack' stack'' then fold () else stack'', csts | Some (recargs, nargs, flags) -> if (List.mem `ReductionNeverUnfold flags @@ -926,7 +955,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = Stack.append_app [|c|] bef,cst_l)::s')) | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> - apply_subst whrec [b] refold cst_l c stack + apply_subst (fun _ -> whrec) [b] sigma refold cst_l c stack | Cast (c,_,_) -> whrec cst_l (c, stack) | App (f,cl) -> whrec @@ -935,20 +964,20 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Lambda (na,t,c) -> (match Stack.decomp stack with | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> - apply_subst whrec [] refold cst_l x stack + apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> - let env' = push_rel (LocalAssum (na,t)) env in + let env' = push_rel (local_assum (na, t)) env in let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in - (match kind_of_term (Stack.zip ~refold (fst (whrec' (c, Stack.empty)))) with + (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with | App (f,cl) -> let napp = Array.length cl in if napp > 0 then let (x', l'),_ = whrec' (Array.last cl, Stack.empty) in - match kind_of_term x', l' with + match EConstr.kind sigma x', l' with | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in - let u = if Int.equal napp 1 then f else appvect (f,lc) in - if noccurn 1 u then (pop (EConstr.of_constr u),Stack.empty),Cst_stack.empty else fold () + let u = if Int.equal napp 1 then f else mkApp (f,lc) in + if Vars.noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty),Cst_stack.empty else fold () | _ -> fold () else fold () | _ -> fold ()) @@ -973,11 +1002,11 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = |args, (Stack.Proj (n,m,p,_)::s') when use_match -> whrec Cst_stack.empty (Stack.nth args (n+m), s') |args, (Stack.Fix (f,s',cst_l)::s'') when use_fix -> - let x' = Stack.zip(x,args) in + let x' = Stack.zip sigma (x, args) in let out_sk = s' @ (Stack.append_app [|x'|] s'') in reduce_and_refold_fix whrec env sigma refold cst_l f out_sk |args, (Stack.Cst (const,curr,remains,s',cst_l) :: s'') -> - let x' = Stack.zip(x,args) in + let x' = Stack.zip sigma (x, args) in begin match remains with | [] -> (match const with @@ -985,6 +1014,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (match constant_opt_value_in env const with | None -> fold () | Some body -> + let body = EConstr.of_constr body in whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) (body, s' @ (Stack.append_app [|x'|] s''))) | Stack.Cst_proj p -> @@ -1020,31 +1050,34 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = in fun xs -> let (s,cst_l as res) = whrec (Option.default Cst_stack.empty csts) xs in - if tactic_mode then (Stack.best_state s cst_l,Cst_stack.empty) else res + if tactic_mode then (Stack.best_state sigma s cst_l,Cst_stack.empty) else res (** reduction machine without global env and refold machinery *) let local_whd_state_gen flags sigma = - let rec whrec (x, stack as s) = - match kind_of_term x with + let open EConstr in + let rec whrec (x, stack) = + let c0 = EConstr.kind sigma x in + let s = (EConstr.of_kind c0, stack) in + match c0 with | LetIn (_,b,_,c) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fZETA -> - stacklam whrec [b] c stack + stacklam whrec [b] sigma c stack | Cast (c,_,_) -> whrec (c, stack) | App (f,cl) -> whrec (f, Stack.append_app cl stack) | Lambda (_,_,c) -> (match Stack.decomp stack with | Some (a,m) when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> - stacklam whrec [a] c m + stacklam whrec [a] sigma c m | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> - (match kind_of_term (Stack.zip (whrec (c, Stack.empty))) with + (match EConstr.kind sigma (Stack.zip sigma (whrec (c, Stack.empty))) with | App (f,cl) -> let napp = Array.length cl in if napp > 0 then let x', l' = whrec (Array.last cl, Stack.empty) in - match kind_of_term x', l' with + match EConstr.kind sigma x', l' with | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in - let u = if Int.equal napp 1 then f else appvect (f,lc) in - if noccurn 1 u then (pop (EConstr.of_constr u),Stack.empty) else s + let u = if Int.equal napp 1 then f else mkApp (f,lc) in + if Vars.noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty) else s | _ -> s else s | _ -> s) @@ -1064,14 +1097,10 @@ let local_whd_state_gen flags sigma = |None -> s |Some (bef,arg,s') -> whrec (arg, Stack.Fix(f,bef,Cst_stack.empty)::s')) - | Evar ev -> - (match safe_evar_value sigma ev with - Some c -> whrec (c,stack) - | None -> s) - + | Evar ev -> s | Meta ev -> (match safe_meta_value sigma ev with - Some c -> whrec (c,stack) + Some c -> whrec (EConstr.of_constr c,stack) | None -> s) | Construct ((ind,c),u) -> @@ -1084,8 +1113,8 @@ let local_whd_state_gen flags sigma = |args, (Stack.Proj (n,m,p,_) :: s') when use_match -> whrec (Stack.nth args (n+m), s') |args, (Stack.Fix (f,s',cst)::s'') when use_fix -> - let x' = Stack.zip(x,args) in - whrec (contract_fix f, s' @ (Stack.append_app [|x'|] s'')) + let x' = Stack.zip sigma (x,args) in + whrec (contract_fix sigma f, s' @ (Stack.append_app [|x'|] s'')) |_, (Stack.App _|Stack.Update _|Stack.Shift _|Stack.Cst _)::_ -> assert false |_, _ -> s else s @@ -1094,7 +1123,7 @@ let local_whd_state_gen flags sigma = if CClosure.RedFlags.red_set flags CClosure.RedFlags.fCOFIX then match Stack.strip_app stack with |args, ((Stack.Case _ | Stack.Proj _)::s') -> - whrec (contract_cofix cofix, stack) + whrec (contract_cofix sigma cofix, stack) |_ -> s else s @@ -1107,7 +1136,7 @@ let raw_whd_state_gen flags env = f let stack_red_of_state_red f = - let f sigma x = decompose_app (Stack.zip (f sigma (x, Stack.empty))) in + let f sigma x = EConstr.decompose_app sigma (Stack.zip sigma (f sigma (x, Stack.empty))) in f (* Drops the Cst_stack *) @@ -1115,11 +1144,11 @@ let iterate_whd_gen refold flags env sigma s = let rec aux t = let (hd,sk),_ = whd_state_gen refold false flags env sigma (t,Stack.empty) in let whd_sk = Stack.map aux sk in - Stack.zip ~refold (hd,whd_sk) + Stack.zip sigma ~refold (hd,whd_sk) in aux s let red_of_state_red f sigma x = - Stack.zip (f sigma (x,Stack.empty)) + EConstr.Unsafe.to_constr (Stack.zip sigma (f sigma (x,Stack.empty))) (* 0. No Reduction Functions *) @@ -1174,7 +1203,7 @@ let whd_allnolet env = (* 4. Ad-hoc eta reduction, does not subsitute evars *) -let shrink_eta c = Stack.zip (local_whd_state_gen eta Evd.empty (c,Stack.empty)) +let shrink_eta c = EConstr.Unsafe.to_constr (Stack.zip Evd.empty (local_whd_state_gen eta Evd.empty (c,Stack.empty))) (* 5. Zeta Reduction Functions *) @@ -1198,7 +1227,7 @@ let clos_norm_flags flgs env sigma t = let evars ev = safe_evar_value sigma ev in CClosure.norm_val (CClosure.create_clos_infos ~evars flgs env) - (CClosure.inject t) + (CClosure.inject (EConstr.Unsafe.to_constr t)) with e when is_anomaly e -> error "Tried to normalize ill-typed term" let nf_beta = clos_norm_flags CClosure.beta (Global.env ()) @@ -1239,7 +1268,15 @@ let report_anomaly _ = let e = CErrors.push e in iraise e -let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y = +let f_conv ?l2r ?reds env ?evars x y = + let inj = EConstr.Unsafe.to_constr in + Reduction.conv ?l2r ?reds env ?evars (inj x) (inj y) + +let f_conv_leq ?l2r ?reds env ?evars x y = + let inj = EConstr.Unsafe.to_constr in + Reduction.conv_leq ?l2r ?reds env ?evars (inj x) (inj y) + +let test_trans_conversion (f: EConstr.t Reduction.extended_conversion_function) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in @@ -1247,16 +1284,16 @@ let test_trans_conversion (f: constr Reduction.extended_conversion_function) red with Reduction.NotConvertible -> false | e when is_anomaly e -> report_anomaly e -let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv reds env sigma -let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion Reduction.conv_leq reds env sigma +let is_conv ?(reds=full_transparent_state) env sigma = test_trans_conversion f_conv reds env sigma +let is_conv_leq ?(reds=full_transparent_state) env sigma = test_trans_conversion f_conv_leq reds env sigma let is_fconv ?(reds=full_transparent_state) = function | Reduction.CONV -> is_conv ~reds | Reduction.CUMUL -> is_conv_leq ~reds let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = let f = match pb with - | Reduction.CONV -> Reduction.conv - | Reduction.CUMUL -> Reduction.conv_leq + | Reduction.CONV -> f_conv + | Reduction.CUMUL -> f_conv_leq in try f ~reds:ts env ~evars:(safe_evar_value sigma, Evd.universes sigma) x y; true with Reduction.NotConvertible -> false @@ -1320,37 +1357,38 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = (* Special-Purpose Reduction *) (********************************************************************) -let whd_meta sigma c = match kind_of_term c with - | Meta p -> (try meta_value sigma p with Not_found -> c) - | _ -> c +let whd_meta sigma c = match EConstr.kind sigma c with + | Meta p -> (try meta_value sigma p with Not_found -> EConstr.Unsafe.to_constr c) + | _ -> EConstr.Unsafe.to_constr c let default_plain_instance_ident = Id.of_string "H" (* Try to replace all metas. Does not replace metas in the metas' values * Differs from (strong whd_meta). *) -let plain_instance s c = - let rec irec n u = match kind_of_term u with - | Meta p -> (try lift n (Metamap.find p s) with Not_found -> u) - | App (f,l) when isCast f -> - let (f,_,t) = destCast f in +let plain_instance sigma s c = + let open EConstr in + let rec irec n u = match EConstr.kind sigma u with + | Meta p -> (try Vars.lift n (Metamap.find p s) with Not_found -> u) + | App (f,l) when isCast sigma f -> + let (f,_,t) = destCast sigma f in let l' = CArray.Fun1.smartmap irec n l in - (match kind_of_term f with + (match EConstr.kind sigma f with | Meta p -> (* Don't flatten application nodes: this is used to extract a proof-term from a proof-tree and we want to keep the structure of the proof-tree *) (try let g = Metamap.find p s in - match kind_of_term g with + match EConstr.kind sigma g with | App _ -> - let l' = CArray.Fun1.smartmap lift 1 l' in + let l' = CArray.Fun1.smartmap Vars.lift 1 l' in mkLetIn (Name default_plain_instance_ident,g,t,mkApp(mkRel 1, l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) - | Cast (m,_,_) when isMeta m -> - (try lift n (Metamap.find (destMeta m) s) with Not_found -> u) + | Cast (m,_,_) when isMeta sigma m -> + (try Vars.lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) | _ -> - map_constr_with_binders succ irec n u + map_with_binders sigma succ irec n u in if Metamap.is_empty s then c else irec 0 c @@ -1391,7 +1429,7 @@ let plain_instance s c = let instance sigma s c = (* if s = [] then c else *) - local_strong whd_betaiota sigma (plain_instance s c) + local_strong whd_betaiota sigma (plain_instance sigma s c) (* pseudo-reduction rule: * [hnf_prod_app env s (Prod(_,B)) N --> B[N] @@ -1400,34 +1438,40 @@ let instance sigma s c = * error message. *) let hnf_prod_app env sigma t n = - match kind_of_term (whd_all env sigma t) with - | Prod (_,_,b) -> subst1 n b + let open EConstr in + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with + | Prod (_,_,b) -> EConstr.Unsafe.to_constr (Vars.subst1 n b) | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") let hnf_prod_appvect env sigma t nl = - Array.fold_left (hnf_prod_app env sigma) t nl + Array.fold_left (fun acc t -> hnf_prod_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl let hnf_prod_applist env sigma t nl = - List.fold_left (hnf_prod_app env sigma) t nl + List.fold_left (fun acc t -> hnf_prod_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl let hnf_lam_app env sigma t n = - match kind_of_term (whd_all env sigma t) with - | Lambda (_,_,b) -> subst1 n b + let open EConstr in + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with + | Lambda (_,_,b) -> EConstr.Unsafe.to_constr (Vars.subst1 n b) | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction") let hnf_lam_appvect env sigma t nl = - Array.fold_left (hnf_lam_app env sigma) t nl + Array.fold_left (fun acc t -> hnf_lam_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl let hnf_lam_applist env sigma t nl = - List.fold_left (hnf_lam_app env sigma) t nl + List.fold_left (fun acc t -> hnf_lam_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl + +let bind_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + (na, inj t) let splay_prod env sigma = let rec decrec env m c = let t = whd_all env sigma c in - match kind_of_term t with + match EConstr.kind sigma (EConstr.of_constr t) with | Prod (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - ((n,a)::m) c0 + decrec (push_rel (local_assum (n,a)) env) + (bind_assum (n,a)::m) c0 | _ -> m,t in decrec env [] @@ -1435,10 +1479,10 @@ let splay_prod env sigma = let splay_lam env sigma = let rec decrec env m c = let t = whd_all env sigma c in - match kind_of_term t with + match EConstr.kind sigma (EConstr.of_constr t) with | Lambda (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - ((n,a)::m) c0 + decrec (push_rel (local_assum (n,a)) env) + (bind_assum (n,a)::m) c0 | _ -> m,t in decrec env [] @@ -1446,51 +1490,51 @@ let splay_lam env sigma = let splay_prod_assum env sigma = let rec prodec_rec env l c = let t = whd_allnolet env sigma c in - match kind_of_term t with + match EConstr.kind sigma (EConstr.of_constr t) with | Prod (x,t,c) -> - prodec_rec (push_rel (LocalAssum (x,t)) env) - (Context.Rel.add (LocalAssum (x,t)) l) c + prodec_rec (push_rel (local_assum (x,t)) env) + (Context.Rel.add (local_assum (x,t)) l) c | LetIn (x,b,t,c) -> - prodec_rec (push_rel (LocalDef (x,b,t)) env) - (Context.Rel.add (LocalDef (x,b,t)) l) c + prodec_rec (push_rel (local_def (x,b,t)) env) + (Context.Rel.add (local_def (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> - let t' = whd_all env sigma t in + let t' = whd_all env sigma (EConstr.of_constr t) in if Term.eq_constr t t' then l,t - else prodec_rec env l t' + else prodec_rec env l (EConstr.of_constr t') in prodec_rec env Context.Rel.empty let splay_arity env sigma c = let l, c = splay_prod env sigma c in - match kind_of_term c with + match EConstr.kind sigma (EConstr.of_constr c) with | Sort s -> l,s | _ -> invalid_arg "splay_arity" let sort_of_arity env sigma c = snd (splay_arity env sigma c) let splay_prod_n env sigma n = - let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else - match kind_of_term (whd_all env sigma c) with + let rec decrec env m ln c = if Int.equal m 0 then (ln, EConstr.Unsafe.to_constr c) else + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma c)) with | Prod (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + decrec (push_rel (local_assum (n,a)) env) + (m-1) (Context.Rel.add (local_assum (n,a)) ln) c0 | _ -> invalid_arg "splay_prod_n" in decrec env n Context.Rel.empty let splay_lam_n env sigma n = - let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else - match kind_of_term (whd_all env sigma c) with + let rec decrec env m ln c = if Int.equal m 0 then (ln, EConstr.Unsafe.to_constr c) else + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma c)) with | Lambda (n,a,c0) -> - decrec (push_rel (LocalAssum (n,a)) env) - (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 + decrec (push_rel (local_assum (n,a)) env) + (m-1) (Context.Rel.add (local_assum (n,a)) ln) c0 | _ -> invalid_arg "splay_lam_n" in decrec env n Context.Rel.empty let is_sort env sigma t = - match kind_of_term (whd_all env sigma t) with + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with | Sort s -> true | _ -> false @@ -1498,6 +1542,7 @@ let is_sort env sigma t = of case/fix (heuristic used by evar_conv) *) let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = + let open EConstr in let refold = get_refolding_in_reduction () in let tactic_mode = false in let rec whrec csts s = @@ -1506,15 +1551,15 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = |args, (Stack.Case _ :: _ as stack') -> let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if reducible_mind_case t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + if reducible_mind_case sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' |args, (Stack.Fix _ :: _ as stack') -> let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + if isConstruct sigma t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' |args, (Stack.Proj (n,m,p,_) :: stack'') -> let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' ~refold ~tactic_mode (CClosure.RedFlags.red_add_transparent CClosure.all ts) env sigma (t,args) in - if isConstruct t_o then + if isConstruct sigma t_o then whrec Cst_stack.empty (Stack.nth stack_o (n+m), stack'') else s,csts' |_, ((Stack.App _| Stack.Shift _|Stack.Update _|Stack.Cst _) :: _|[]) -> s,csts' @@ -1523,9 +1568,9 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let find_conclusion env sigma = let rec decrec env c = let t = whd_all env sigma c in - match kind_of_term t with - | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 - | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 + match EConstr.kind sigma (EConstr.of_constr t) with + | Prod (x,t,c0) -> decrec (push_rel (local_assum (x,t)) env) c0 + | Lambda (x,t,c0) -> decrec (push_rel (local_assum (x,t)) env) c0 | t -> t in decrec env @@ -1539,11 +1584,12 @@ let is_arity env sigma c = (* Metas *) let meta_value evd mv = + let open EConstr in let rec valrec mv = match meta_opt_fvalue evd mv with | Some (b,_) -> let metas = Metamap.bind valrec b.freemetas in - instance evd metas b.rebus + EConstr.of_constr (instance evd metas (EConstr.of_constr b.rebus)) | None -> mkMeta mv in valrec mv @@ -1553,7 +1599,7 @@ let meta_instance sigma b = if Metaset.is_empty fm then b.rebus else let c_sigma = Metamap.bind (fun mv -> meta_value sigma mv) fm in - instance sigma c_sigma b.rebus + instance sigma c_sigma (EConstr.of_constr b.rebus) let nf_meta sigma c = meta_instance sigma (mk_freelisted c) @@ -1569,7 +1615,7 @@ let meta_reducible_instance evd b = in let metas = Metaset.fold fold fm Metamap.empty in let rec irec u = - let u = whd_betaiota Evd.empty u (** FIXME *) in + let u = whd_betaiota Evd.empty (EConstr.of_constr u) (** FIXME *) in match kind_of_term u with | Case (ci,p,c,bl) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd (EConstr.of_constr c))) -> let m = destMeta (strip_outer_cast evd (EConstr.of_constr c)) in @@ -1615,32 +1661,31 @@ let meta_reducible_instance evd b = else irec b.rebus -let head_unfold_under_prod ts env _ c = +let head_unfold_under_prod ts env sigma c = + let open EConstr in let unfold (cst,u as cstu) = if Cpred.mem cst (snd ts) then match constant_opt_value_in env cstu with - | Some c -> c + | Some c -> EConstr.of_constr c | None -> mkConstU cstu else mkConstU cstu in let rec aux c = - match kind_of_term c with + match EConstr.kind sigma c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) | _ -> - let (h,l) = decompose_app c in - match kind_of_term h with - | Const cst -> beta_applist (unfold cst,l) + let (h,l) = decompose_app_vect sigma c in + match EConstr.kind sigma (EConstr.of_constr h) with + | Const cst -> beta_app sigma (unfold cst, Array.map EConstr.of_constr l) | _ -> c in - aux c + EConstr.Unsafe.to_constr (aux c) let betazetaevar_applist sigma n c l = + let open EConstr in let rec stacklam n env t stack = - if Int.equal n 0 then applist (substl env t, stack) else - match kind_of_term t, stack with + if Int.equal n 0 then applist (Vars.substl env t, stack) else + match EConstr.kind sigma t, stack with | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack - | Evar ev, _ -> - (match safe_evar_value sigma ev with - | Some body -> stacklam n env body stack - | None -> applist (substl env t, stack)) + | LetIn(_,b,_,c), _ -> stacklam (n-1) (Vars.substl env b::env) c stack + | Evar _, _ -> applist (Vars.substl env t, stack) | _ -> anomaly (Pp.str "Not enough lambda/let's") in - stacklam n [] c l + EConstr.Unsafe.to_constr (stacklam n [] c l) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 8dcf5c084e..911dab0b67 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -38,6 +38,7 @@ val set_refolding_in_reduction : bool -> unit cst applied to params must convertible to term of the state applied to args *) module Cst_stack : sig + open EConstr type t val empty : t val add_param : constr -> t -> t @@ -45,12 +46,13 @@ module Cst_stack : sig val add_cst : constr -> t -> t val best_cst : t -> (constr * constr list) option val best_replace : Evd.evar_map -> constr -> t -> constr -> constr - val reference : t -> Constant.t option + val reference : Evd.evar_map -> t -> Constant.t option val pr : t -> Pp.std_ppcmds end module Stack : sig + open EConstr type 'a app_node val pr_app_node : ('a -> Pp.std_ppcmds) -> 'a app_node -> Pp.std_ppcmds @@ -63,7 +65,7 @@ module Stack : sig | App of 'a app_node | Case of case_info * 'a * 'a array * Cst_stack.t | Proj of int * int * projection * Cst_stack.t - | Fix of fixpoint * 'a t * Cst_stack.t + | Fix of ('a, 'a) pfixpoint * 'a t * Cst_stack.t | Cst of cst_member * int (** current foccussed arg *) * int list (** remaining args *) * 'a t * Cst_stack.t | Shift of int @@ -82,9 +84,9 @@ module Stack : sig val compare_shape : 'a t -> 'a t -> bool (** [fold2 f x sk1 sk2] folds [f] on any pair of term in [(sk1,sk2)]. @return the result and the lifts to apply on the terms *) - val fold2 : ('a -> Term.constr -> Term.constr -> 'a) -> 'a -> - Term.constr t -> Term.constr t -> 'a * int * int - val map : (Term.constr -> Term.constr) -> Term.constr t -> Term.constr t + val fold2 : ('a -> constr -> constr -> 'a) -> 'a -> + constr t -> constr t -> 'a * int * int + val map : ('a -> 'a) -> 'a t -> 'a t val append_app_list : 'a list -> 'a t -> 'a t (** if [strip_app s] = [(a,b)], then [s = a @ b] and [b] does not @@ -101,25 +103,25 @@ module Stack : sig val tail : int -> 'a t -> 'a t val nth : 'a t -> int -> 'a - val best_state : constr * constr t -> Cst_stack.t -> constr * constr t - val zip : ?refold:bool -> constr * constr t -> constr + val best_state : evar_map -> constr * constr t -> Cst_stack.t -> constr * constr t + val zip : ?refold:bool -> evar_map -> constr * constr t -> constr end (************************************************************************) -type state = constr * constr Stack.t +type state = EConstr.t * EConstr.t Stack.t -type contextual_reduction_function = env -> evar_map -> constr -> constr +type contextual_reduction_function = env -> evar_map -> EConstr.t -> constr type reduction_function = contextual_reduction_function -type local_reduction_function = evar_map -> constr -> constr +type local_reduction_function = evar_map -> EConstr.t -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> EConstr.t -> (constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = - env -> evar_map -> constr -> constr * constr list + env -> evar_map -> EConstr.t -> EConstr.t * EConstr.t list type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = - evar_map -> constr -> constr * constr list + evar_map -> EConstr.t -> EConstr.t * EConstr.t list type contextual_state_reduction_function = env -> evar_map -> state -> state @@ -137,13 +139,13 @@ val strong_prodspine : local_reduction_function -> local_reduction_function val stack_reduction_of_reduction : 'a reduction_function -> 'a state_reduction_function i*) -val stacklam : (state -> 'a) -> constr list -> constr -> constr Stack.t -> 'a +val stacklam : (state -> 'a) -> EConstr.t list -> evar_map -> EConstr.t -> EConstr.t Stack.t -> 'a val whd_state_gen : ?csts:Cst_stack.t -> refold:bool -> tactic_mode:bool -> CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t val iterate_whd_gen : bool -> CClosure.RedFlags.reds -> - Environ.env -> Evd.evar_map -> Term.constr -> Term.constr + Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr (** {6 Generic Optimized Reduction Function using Closures } *) @@ -196,46 +198,46 @@ val whd_zeta_stack : local_stack_reduction_function val whd_zeta_state : local_state_reduction_function val whd_zeta : local_reduction_function -val shrink_eta : constr -> constr +val shrink_eta : EConstr.t -> constr (** Various reduction functions *) val safe_evar_value : evar_map -> existential -> constr option -val beta_applist : constr * constr list -> constr - -val hnf_prod_app : env -> evar_map -> constr -> constr -> constr -val hnf_prod_appvect : env -> evar_map -> constr -> constr array -> constr -val hnf_prod_applist : env -> evar_map -> constr -> constr list -> constr -val hnf_lam_app : env -> evar_map -> constr -> constr -> constr -val hnf_lam_appvect : env -> evar_map -> constr -> constr array -> constr -val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr - -val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr -val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr -val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts -val sort_of_arity : env -> evar_map -> constr -> sorts -val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr -val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr +val beta_applist : evar_map -> EConstr.t * EConstr.t list -> constr + +val hnf_prod_app : env -> evar_map -> EConstr.t -> EConstr.t -> constr +val hnf_prod_appvect : env -> evar_map -> EConstr.t -> EConstr.t array -> constr +val hnf_prod_applist : env -> evar_map -> EConstr.t -> EConstr.t list -> constr +val hnf_lam_app : env -> evar_map -> EConstr.t -> EConstr.t -> constr +val hnf_lam_appvect : env -> evar_map -> EConstr.t -> EConstr.t array -> constr +val hnf_lam_applist : env -> evar_map -> EConstr.t -> EConstr.t list -> constr + +val splay_prod : env -> evar_map -> EConstr.t -> (Name.t * constr) list * constr +val splay_lam : env -> evar_map -> EConstr.t -> (Name.t * constr) list * constr +val splay_arity : env -> evar_map -> EConstr.t -> (Name.t * constr) list * sorts +val sort_of_arity : env -> evar_map -> EConstr.t -> sorts +val splay_prod_n : env -> evar_map -> int -> EConstr.t -> Context.Rel.t * constr +val splay_lam_n : env -> evar_map -> int -> EConstr.t -> Context.Rel.t * constr val splay_prod_assum : - env -> evar_map -> constr -> Context.Rel.t * constr + env -> evar_map -> EConstr.t -> Context.Rel.t * constr type 'a miota_args = { - mP : constr; (** the result type *) - mconstr : constr; (** the constructor *) + mP : EConstr.t; (** the result type *) + mconstr : EConstr.t; (** the constructor *) mci : case_info; (** special info to re-build pattern *) mcargs : 'a list; (** the constructor's arguments *) mlf : 'a array } (** the branch code vector *) -val reducible_mind_case : constr -> bool -val reduce_mind_case : constr miota_args -> constr +val reducible_mind_case : evar_map -> EConstr.t -> bool +val reduce_mind_case : evar_map -> EConstr.t miota_args -> EConstr.t -val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term -val is_arity : env -> evar_map -> constr -> bool -val is_sort : env -> evar_map -> types -> bool +val find_conclusion : env -> evar_map -> EConstr.t -> (EConstr.t,EConstr.t) kind_of_term +val is_arity : env -> evar_map -> EConstr.t -> bool +val is_sort : env -> evar_map -> EConstr.types -> bool -val contract_fix : ?env:Environ.env -> ?reference:Constant.t -> fixpoint -> constr -val fix_recarg : fixpoint -> constr Stack.t -> (int * constr) option +val contract_fix : ?env:Environ.env -> evar_map -> ?reference:Constant.t -> (EConstr.t, EConstr.t) pfixpoint -> EConstr.t +val fix_recarg : ('a, 'a) pfixpoint -> 'b Stack.t -> (int * 'b) option (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) val is_transparent : Environ.env -> constant tableKey -> bool @@ -247,14 +249,14 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool -val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool +val is_conv : ?reds:transparent_state -> env -> evar_map -> EConstr.t -> EConstr.t -> bool +val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> EConstr.t -> EConstr.t -> bool +val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> EConstr.t -> EConstr.t -> bool (** [check_conv] Checks universe constraints only. pb defaults to CUMUL and ts to a full transparent state. *) -val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool +val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> EConstr.t -> EConstr.t -> bool (** [infer_conv] Adds necessary universe constraints to the evar map. pb defaults to CUMUL and ts to a full transparent state. @@ -280,11 +282,11 @@ val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> (** {6 Special-Purpose Reduction Functions } *) -val whd_meta : evar_map -> constr -> constr -val plain_instance : constr Metamap.t -> constr -> constr -val instance : evar_map -> constr Metamap.t -> constr -> constr +val whd_meta : local_reduction_function +val plain_instance : evar_map -> EConstr.t Metamap.t -> EConstr.t -> EConstr.t +val instance : evar_map -> EConstr.t Metamap.t -> EConstr.t -> constr val head_unfold_under_prod : transparent_state -> reduction_function -val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr +val betazetaevar_applist : evar_map -> int -> EConstr.t -> EConstr.t list -> constr (** {6 Heuristic for Conversion with Evar } *) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index ac3b5ef639..353bdbb899 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -53,8 +53,8 @@ let get_type_from_constraints env sigma t = if isEvar (fst (decompose_app t)) then match List.map_filter (fun (pbty,env,t1,t2) -> - if is_fconv Reduction.CONV env sigma t t1 then Some t2 - else if is_fconv Reduction.CONV env sigma t t2 then Some t1 + if is_fconv Reduction.CONV env sigma (EConstr.of_constr t) (EConstr.of_constr t1) then Some t2 + else if is_fconv Reduction.CONV env sigma (EConstr.of_constr t) (EConstr.of_constr t2) then Some t1 else None) (snd (Evd.extract_all_conv_pbs sigma)) with @@ -65,7 +65,7 @@ let get_type_from_constraints env sigma t = let rec subst_type env sigma typ = function | [] -> typ | h::rest -> - match kind_of_term (whd_all env sigma typ) with + match kind_of_term (whd_all env sigma (EConstr.of_constr typ)) with | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest | _ -> retype_error NonFunctionalConstruction @@ -74,7 +74,7 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = - match kind_of_term (whd_all env sigma ar), args with + match kind_of_term (whd_all env sigma (EConstr.of_constr ar)), args with | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> s | _ -> retype_error NotASort @@ -106,17 +106,17 @@ let retype ?(polyprop=true) sigma = | Case (_,p,c,lf) -> let Inductiveops.IndType(indf,realargs) = let t = type_of env c in - try Inductiveops.find_rectype env sigma t + try Inductiveops.find_rectype env sigma (EConstr.of_constr t) with Not_found -> try let t = get_type_from_constraints env sigma t in - Inductiveops.find_rectype env sigma t + Inductiveops.find_rectype env sigma (EConstr.of_constr t) with Not_found -> retype_error BadRecursiveType in let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in - let t = betazetaevar_applist sigma n p realargs in - (match kind_of_term (whd_all env sigma (type_of env t)) with - | Prod _ -> whd_beta sigma (applist (t, [c])) + let t = betazetaevar_applist sigma n (EConstr.of_constr p) (List.map EConstr.of_constr realargs) in + (match kind_of_term (whd_all env sigma (EConstr.of_constr (type_of env t))) with + | Prod _ -> whd_beta sigma (EConstr.of_constr (applist (t, [c]))) | _ -> t) | Lambda (name,c1,c2) -> mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2) @@ -134,7 +134,7 @@ let retype ?(polyprop=true) sigma = | Proj (p,c) -> let ty = type_of env c in (try - Inductiveops.type_of_projection_knowing_arg env sigma p c ty + Inductiveops.type_of_projection_knowing_arg env sigma p (EConstr.of_constr c) (EConstr.of_constr ty) with Invalid_argument _ -> retype_error BadRecursiveType) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) @@ -159,7 +159,7 @@ let retype ?(polyprop=true) sigma = sort_of_atomic_type env sigma t args | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | Lambda _ | Fix _ | Construct _ -> retype_error NotAType - | _ -> decomp_sort env sigma (type_of env t) + | _ -> decomp_sort env sigma (EConstr.of_constr (type_of env t)) and sort_family_of env t = match kind_of_term t with @@ -178,7 +178,7 @@ let retype ?(polyprop=true) sigma = family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> - family_of_sort (decomp_sort env sigma (type_of env t)) + family_of_sort (decomp_sort env sigma (EConstr.of_constr (type_of env t))) and type_of_global_reference_knowing_parameters env c args = let argtyps = @@ -207,11 +207,10 @@ let type_of_global_reference_knowing_parameters env sigma c args = let _,_,_,f = retype sigma in anomaly_on_error (f env c) args let type_of_global_reference_knowing_conclusion env sigma c conclty = - let conclty = nf_evar sigma conclty in match kind_of_term c with | Ind (ind,u) -> let spec = Inductive.lookup_mind_specif env ind in - type_of_inductive_knowing_conclusion env sigma (spec,u) conclty + type_of_inductive_knowing_conclusion env sigma (spec,u) (EConstr.of_constr conclty) | Const cst -> let t = constant_type_in env cst in (* TODO *) @@ -251,7 +250,7 @@ let sorts_of_context env evc ctxt = let expand_projection env sigma pr c args = let ty = get_type_of ~lax:true env sigma c in let (i,u), ind_args = - try Inductiveops.find_mrectype env sigma ty + try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with Not_found -> retype_error BadRecursiveType in mkApp (mkConstU (Projection.constant pr,u), diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index ff76abe372..357a80f441 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -88,11 +88,12 @@ let evaluable_reference_eq r1 r2 = match r1, r2 with | _ -> false let mkEvalRef ref u = + let open EConstr in match ref with | EvalConst cst -> mkConstU (cst,u) | EvalVar id -> mkVar id | EvalRel n -> mkRel n - | EvalEvar ev -> mkEvar ev + | EvalEvar ev -> EConstr.of_constr (Constr.mkEvar ev) let isEvalRef env c = match kind_of_term c with | Const (sp,_) -> is_evaluable env (EvalConstRef sp) @@ -132,18 +133,18 @@ exception NotEvaluable let reference_value env sigma c u = match reference_opt_value env sigma c u with | None -> raise NotEvaluable - | Some d -> d + | Some d -> EConstr.of_constr d (************************************************************************) (* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic). *) (* One reuses the name of the function after reduction of the fixpoint *) type constant_evaluation = - | EliminationFix of int * int * (int * (int * constr) list * int) + | EliminationFix of int * int * (int * (int * EConstr.t) list * int) | EliminationMutualFix of int * evaluable_reference * ((int*evaluable_reference) option array * - (int * (int * constr) list * int)) + (int * (int * EConstr.t) list * int)) | EliminationCases of int | EliminationProj of int | NotAnElimination @@ -184,7 +185,7 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = let nbfix = Array.length bds in let li = List.map - (function d -> match kind_of_term d with + (function d -> match EConstr.kind sigma d with | Rel k -> if Array.for_all (noccurn k) tys @@ -202,7 +203,7 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = raise Elimconst; List.iteri (fun i t_i -> if not (Int.List.mem_assoc (i+1) li) then - let fvs = List.map ((+) (i+1)) (Int.Set.elements (free_rels sigma (EConstr.of_constr t_i))) in + let fvs = List.map ((+) (i+1)) (Int.Set.elements (free_rels sigma t_i)) in match List.intersect Int.equal fvs reversible_rels with | [] -> () | _ -> raise Elimconst) @@ -239,11 +240,11 @@ let invert_name labs l na0 env sigma ref = function | None -> None | Some c -> let labs',ccl = decompose_lam c in - let _, l' = whd_betalet_stack sigma ccl in + let _, l' = whd_betalet_stack sigma (EConstr.of_constr ccl) in let labs' = List.map snd labs' in (** ppedrot: there used to be generic equality on terms here *) if List.equal eq_constr labs' labs && - List.equal eq_constr l l' then Some (minfxargs,ref) + List.equal (fun c1 c2 -> EConstr.eq_constr sigma c1 c2) l l' then Some (minfxargs,ref) else None with Not_found (* Undefined ref *) -> None end @@ -255,11 +256,12 @@ let invert_name labs l na0 env sigma ref = function let compute_consteval_direct env sigma ref = let rec srec env n labs onlyproj c = - let c',l = whd_betadeltazeta_stack env sigma c in + let c',l = whd_betadeltazeta_stack env sigma (EConstr.of_constr c) in + let c' = EConstr.Unsafe.to_constr c' in match kind_of_term c' with | Lambda (id,t,g) when List.is_empty l && not onlyproj -> let open Context.Rel.Declaration in - srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g + srec (push_rel (LocalAssum (id,t)) env) (n+1) (EConstr.of_constr t::labs) onlyproj g | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) @@ -274,8 +276,9 @@ let compute_consteval_direct env sigma ref = let compute_consteval_mutual_fix env sigma ref = let rec srec env minarg labs ref c = - let c',l = whd_betalet_stack sigma c in + let c',l = whd_betalet_stack sigma (EConstr.of_constr c) in let nargs = List.length l in + let c' = EConstr.Unsafe.to_constr c' in match kind_of_term c' with | Lambda (na,t,g) when List.is_empty l -> let open Context.Rel.Declaration in @@ -345,6 +348,7 @@ let reference_eval env sigma = function let x = Name default_dependent_ident let make_elim_fun (names,(nbfix,lv,n)) u largs = + let open EConstr in let lu = List.firstn n largs in let p = List.length lv in let lyi = List.map fst lv in @@ -353,17 +357,17 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs = (* k from the comment is q+1 *) try mkRel (p+1-(List.index Int.equal (n-q) lyi)) with Not_found -> aq) - 0 (List.map (lift p) lu) + 0 (List.map (Vars.lift p) lu) in fun i -> match names.(i) with | None -> None | Some (minargs,ref) -> - let body = applistc (mkEvalRef ref u) la in + let body = applist (mkEvalRef ref u, la) in let g = List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> - let subst = List.map (lift (-q)) (List.firstn (n-ij) la) in - let tij' = substl (List.rev subst) tij in + let subst = List.map (Vars.lift (-q)) (List.firstn (n-ij) la) in + let tij' = Vars.substl (List.rev subst) tij in mkLambda (x,tij',c)) 1 body (List.rev lv) in Some (minargs,g) @@ -380,10 +384,11 @@ let venv = let open Context.Named.Declaration in as a problem variable: an evar that can be instantiated either by vfx (expanded fixpoint) or vfun (named function). *) let substl_with_function subst sigma constr = + let open EConstr in let evd = ref sigma in let minargs = ref Evar.Map.empty in let v = Array.of_list subst in - let rec subst_total k c = match kind_of_term c with + let rec subst_total k c = match EConstr.kind sigma c with | Rel i when k < i -> if i <= k + Array.length v then match v.(i-k-1) with @@ -393,11 +398,11 @@ let substl_with_function subst sigma constr = let sigma = Sigma.to_evar_map sigma in evd := sigma; minargs := Evar.Map.add evk min !minargs; - lift k (mkEvar (evk, [|fx;ref|])) - | (fx, None) -> lift k fx + Vars.lift k (mkEvar (evk, [|fx;ref|])) + | (fx, None) -> Vars.lift k fx else mkRel (i - Array.length v) | _ -> - map_constr_with_binders succ subst_total k c in + map_with_binders sigma succ subst_total k c in let c = subst_total 0 constr in (c, !evd, !minargs) @@ -408,27 +413,28 @@ exception Partial let solve_arity_problem env sigma fxminargs c = let evm = ref sigma in let set_fix i = evm := Evd.define i (mkVar vfx) !evm in + let open EConstr in let rec check strict c = - let c' = whd_betaiotazeta sigma c in - let (h,rcargs) = decompose_app c' in + let c' = EConstr.of_constr (whd_betaiotazeta sigma c) in + let (h,rcargs) = decompose_app_vect sigma c' in match kind_of_term h with Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> let minargs = Evar.Map.find i fxminargs in - if List.length rcargs < minargs then + if Array.length rcargs < minargs then if strict then set_fix i else raise Partial; - List.iter (check strict) rcargs + Array.iter (EConstr.of_constr %> check strict) rcargs | (Var _|Const _) when isEvalRef env h -> (let ev, u = destEvalRefU h in match reference_opt_value env sigma ev u with | Some h' -> let bak = !evm in - (try List.iter (check false) rcargs + (try Array.iter (EConstr.of_constr %> check false) rcargs with Partial -> evm := bak; - check strict (applist(h',rcargs))) - | None -> List.iter (check strict) rcargs) - | _ -> iter_constr (check strict) c' in + check strict (EConstr.of_constr (Constr.mkApp(h',rcargs)))) + | None -> Array.iter (EConstr.of_constr %> check strict) rcargs) + | _ -> EConstr.iter sigma (check strict) c' in check true c; !evm @@ -446,59 +452,62 @@ let substl_checking_arity env subst sigma c = Some c' -> c' | None -> f) | _ -> map_constr nf_fix c in - nf_fix body + EConstr.of_constr (nf_fix (EConstr.Unsafe.to_constr body)) -type fix_reduction_result = NotReducible | Reduced of (constr*constr list) +type fix_reduction_result = NotReducible | Reduced of (EConstr.t * EConstr.t list) let reduce_fix whdfun sigma fix stack = match fix_recarg fix (Stack.append_app_list stack Stack.empty) with | None -> NotReducible | Some (recargnum,recarg) -> let (recarg'hd,_ as recarg') = whdfun sigma recarg in - let stack' = List.assign stack recargnum (applist recarg') in - (match kind_of_term recarg'hd with - | Construct _ -> Reduced (contract_fix fix, stack') + let stack' = List.assign stack recargnum (EConstr.applist recarg') in + (match EConstr.kind sigma recarg'hd with + | Construct _ -> Reduced (contract_fix sigma fix, stack') | _ -> NotReducible) let contract_fix_use_function env sigma f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = + let open EConstr in let nbodies = Array.length recindices in let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = List.init nbodies make_Fi in - substl_checking_arity env (List.rev lbodies) sigma (nf_beta sigma bodies.(bodynum)) + substl_checking_arity env (List.rev lbodies) sigma (EConstr.of_constr (nf_beta sigma bodies.(bodynum))) let reduce_fix_use_function env sigma f whfun fix stack = match fix_recarg fix (Stack.append_app_list stack Stack.empty) with | None -> NotReducible | Some (recargnum,recarg) -> let (recarg'hd,_ as recarg') = - if isRel recarg then + if EConstr.isRel sigma recarg then (* The recarg cannot be a local def, no worry about the right env *) (recarg, []) else whfun recarg in - let stack' = List.assign stack recargnum (applist recarg') in - (match kind_of_term recarg'hd with + let stack' = List.assign stack recargnum (EConstr.applist recarg') in + (match EConstr.kind sigma recarg'hd with | Construct _ -> Reduced (contract_fix_use_function env sigma f fix,stack') | _ -> NotReducible) let contract_cofix_use_function env sigma f (bodynum,(_names,_,bodies as typedbodies)) = + let open EConstr in let nbodies = Array.length bodies in let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = List.init nbodies make_Fi in substl_checking_arity env (List.rev subbodies) - sigma (nf_beta sigma bodies.(bodynum)) + sigma (EConstr.of_constr (nf_beta sigma bodies.(bodynum))) let reduce_mind_case_use_function func env sigma mia = - match kind_of_term mia.mconstr with + let open EConstr in + match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1), real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> let build_cofix_name = - if isConst func then + if isConst sigma func then let minargs = List.length mia.mcargs in fun i -> if Int.equal i bodynum then Some (minargs,func) @@ -510,7 +519,7 @@ let reduce_mind_case_use_function func env sigma mia = the block was indeed initially built as a global definition *) let kn = map_puniverses (fun x -> con_with_label x (Label.of_id id)) - (destConst func) + (destConst sigma func) in try match constant_opt_value_in env kn with | None -> None @@ -525,13 +534,13 @@ let reduce_mind_case_use_function func env sigma mia = | _ -> assert false -let match_eval_ref env constr = - match kind_of_term constr with +let match_eval_ref env sigma constr = + match EConstr.kind sigma constr with | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> Some (EvalConst sp, u) | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty) | Rel i -> Some (EvalRel i, Univ.Instance.empty) - | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty) + | Evar (evk, args) -> Some (EvalEvar (evk, Array.map EConstr.Unsafe.to_constr args), Univ.Instance.empty) | _ -> None let match_eval_ref_value env sigma constr = @@ -548,20 +557,21 @@ let match_eval_ref_value env sigma constr = let special_red_case env sigma whfun (ci, p, c, lf) = let rec redrec s = let (constr, cargs) = whfun s in - match match_eval_ref env constr with + match match_eval_ref env sigma constr with | Some (ref, u) -> (match reference_opt_value env sigma ref u with | None -> raise Redelimination | Some gvalue -> - if reducible_mind_case gvalue then + let gvalue = EConstr.of_constr gvalue in + if reducible_mind_case sigma gvalue then reduce_mind_case_use_function constr env sigma {mP=p; mconstr=gvalue; mcargs=cargs; mci=ci; mlf=lf} else - redrec (applist(gvalue, cargs))) + redrec (EConstr.applist(gvalue, cargs))) | None -> - if reducible_mind_case constr then - reduce_mind_case + if reducible_mind_case sigma constr then + reduce_mind_case sigma {mP=p; mconstr=constr; mcargs=cargs; mci=ci; mlf=lf} else @@ -574,7 +584,7 @@ let recargs = function | EvalConst c -> ReductionBehaviour.get (ConstRef c) let reduce_projection env sigma pb (recarg'hd,stack') stack = - (match kind_of_term recarg'hd with + (match EConstr.kind sigma recarg'hd with | Construct _ -> let proj_narg = pb.Declarations.proj_npars + pb.Declarations.proj_arg @@ -582,12 +592,13 @@ let reduce_projection env sigma pb (recarg'hd,stack') stack = | _ -> NotReducible) let reduce_proj env sigma whfun whfun' c = + let open EConstr in let rec redrec s = - match kind_of_term s with + match EConstr.kind sigma s with | Proj (proj, c) -> let c' = try redrec c with Redelimination -> c in let constr, cargs = whfun c' in - (match kind_of_term constr with + (match EConstr.kind sigma constr with | Construct _ -> let proj_narg = let pb = lookup_projection proj env in @@ -604,44 +615,43 @@ let reduce_proj env sigma whfun whfun' c = let whd_nothing_for_iota env sigma s = let rec whrec (x, stack as s) = - match kind_of_term x with + match EConstr.kind sigma x with | Rel n -> let open Context.Rel.Declaration in (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec (lift n body, stack) + | LocalDef (_,body,_) -> whrec (EConstr.of_constr (lift n body), stack) | _ -> s) | Var id -> let open Context.Named.Declaration in (match lookup_named id env with - | LocalDef (_,body,_) -> whrec (body, stack) + | LocalDef (_,body,_) -> whrec (EConstr.of_constr body, stack) | _ -> s) - | Evar ev -> - (try whrec (Evd.existential_value sigma ev, stack) - with Evd.NotInstantiatedEvar | Not_found -> s) + | Evar ev -> s | Meta ev -> - (try whrec (Evd.meta_value sigma ev, stack) + (try whrec (EConstr.of_constr (Evd.meta_value sigma ev), stack) with Not_found -> s) | Const const when is_transparent_constant full_transparent_state (fst const) -> (match constant_opt_value_in env const with - | Some body -> whrec (body, stack) + | Some body -> whrec (EConstr.of_constr body, stack) | None -> s) - | LetIn (_,b,_,c) -> stacklam whrec [b] c stack + | LetIn (_,b,_,c) -> stacklam whrec [b] sigma c stack | Cast (c,_,_) -> whrec (c, stack) | App (f,cl) -> whrec (f, Stack.append_app cl stack) | Lambda (na,t,c) -> (match Stack.decomp stack with - | Some (a,m) -> stacklam whrec [a] c m + | Some (a,m) -> stacklam whrec [a] sigma c m | _ -> s) | x -> s in - decompose_app (Stack.zip (whrec (s,Stack.empty))) + EConstr.decompose_app sigma (Stack.zip sigma (whrec (s,Stack.empty))) (* [red_elim_const] contracts iota/fix/cofix redexes hidden behind constants by keeping the name of the constants in the recursive calls; it fails if no redex is around *) let rec red_elim_const env sigma ref u largs = + let open EConstr in let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim, nocase = match recargs ref with @@ -660,7 +670,7 @@ let rec red_elim_const env sigma ref u largs = let c = reference_value env sigma ref u in let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in let whfun = whd_simpl_stack env sigma in - (special_red_case env sigma whfun (destCase c'), lrest), nocase + (special_red_case env sigma whfun (EConstr.destCase sigma c'), lrest), nocase | EliminationProj n when nargs >= n -> let c = reference_value env sigma ref u in let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in @@ -672,9 +682,9 @@ let rec red_elim_const env sigma ref u largs = let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in let whfun = whd_construct_stack env sigma in - (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with + (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase) + | Reduced (c,rest) -> (EConstr.of_constr (nf_beta sigma c), rest), nocase) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> let rec descend (ref,u) args = let c = reference_value env sigma ref u in @@ -682,21 +692,21 @@ let rec red_elim_const env sigma ref u largs = (c,args) else let c', lrest = whd_betalet_stack sigma (applist(c,args)) in - descend (destEvalRefU c') lrest in + descend (destEvalRefU (EConstr.Unsafe.to_constr c')) lrest in let (_, midargs as s) = descend (ref,u) largs in let d, lrest = whd_nothing_for_iota env sigma (applist s) in let f = make_elim_fun refinfos u midargs in let whfun = whd_construct_stack env sigma in - (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with + (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase) + | Reduced (c,rest) -> (EConstr.of_constr (nf_beta sigma c), rest), nocase) | NotAnElimination when unfold_nonelim -> let c = reference_value env sigma ref u in - (whd_betaiotazeta sigma (applist (c, largs)), []), nocase + (EConstr.of_constr (whd_betaiotazeta sigma (applist (c, largs))), []), nocase | _ -> raise Redelimination with Redelimination when unfold_anyway -> let c = reference_value env sigma ref u in - (whd_betaiotazeta sigma (applist (c, largs)), []), nocase + (EConstr.of_constr (whd_betaiotazeta sigma (applist (c, largs))), []), nocase and reduce_params env sigma stack l = let len = List.length stack in @@ -705,8 +715,8 @@ and reduce_params env sigma stack l = else let arg = List.nth stack i in let rarg = whd_construct_stack env sigma arg in - match kind_of_term (fst rarg) with - | Construct _ -> List.assign stack i (applist rarg) + match EConstr.kind sigma (fst rarg) with + | Construct _ -> List.assign stack i (EConstr.applist rarg) | _ -> raise Redelimination) stack l @@ -715,14 +725,18 @@ and reduce_params env sigma stack l = a reducible iota/fix/cofix redex (the "simpl" tactic) *) and whd_simpl_stack env sigma = + let open EConstr in let rec redrec s = - let (x, stack as s') = decompose_app s in - match kind_of_term x with + let (x, stack) = decompose_app_vect sigma s in + let stack = Array.map_to_list EConstr.of_constr stack in + let x = EConstr.of_constr x in + let s' = (x, stack) in + match EConstr.kind sigma x with | Lambda (na,t,c) -> (match stack with | [] -> s' - | a :: rest -> redrec (beta_applist (x,stack))) - | LetIn (n,b,t,c) -> redrec (applist (substl [b] c, stack)) + | a :: rest -> redrec (EConstr.of_constr (beta_applist sigma (x, stack)))) + | LetIn (n,b,t,c) -> redrec (applist (Vars.substl [b] c, stack)) | App (f,cl) -> redrec (applist(f, (Array.to_list cl)@stack)) | Cast (c,_,_) -> redrec (applist(c, stack)) | Case (ci,p,c,lf) -> @@ -762,12 +776,12 @@ and whd_simpl_stack env sigma = with Redelimination -> s') | _ -> - match match_eval_ref env x with + match match_eval_ref env sigma x with | Some (ref, u) -> (try let sapp, nocase = red_elim_const env sigma ref u stack in let hd, _ as s'' = redrec (applist(sapp)) in - let rec is_case x = match kind_of_term x with + let rec is_case x = match EConstr.kind sigma x with | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x | App (hd, _) -> is_case hd | Case _ -> true @@ -782,13 +796,14 @@ and whd_simpl_stack env sigma = (* reduce until finding an applied constructor or fail *) and whd_construct_stack env sigma s = + let open EConstr in let (constr, cargs as s') = whd_simpl_stack env sigma s in - if reducible_mind_case constr then s' - else match match_eval_ref env constr with + if reducible_mind_case sigma constr then s' + else match match_eval_ref env sigma constr with | Some (ref, u) -> (match reference_opt_value env sigma ref u with | None -> raise Redelimination - | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs))) + | Some gvalue -> whd_construct_stack env sigma (applist(EConstr.of_constr gvalue, cargs))) | _ -> raise Redelimination (************************************************************************) @@ -800,12 +815,14 @@ and whd_construct_stack env sigma s = *) let try_red_product env sigma c = - let simpfun = clos_norm_flags betaiotazeta env sigma in + let simpfun c = EConstr.of_constr (clos_norm_flags betaiotazeta env sigma c) in + let inj = EConstr.Unsafe.to_constr in + let open EConstr in let rec redrec env x = - let x = whd_betaiota sigma x in - match kind_of_term x with + let x = EConstr.of_constr (whd_betaiota sigma x) in + match EConstr.kind sigma x with | App (f,l) -> - (match kind_of_term f with + (match EConstr.kind sigma f with | Fix fix -> let stack = Stack.append_app l Stack.empty in (match fix_recarg fix stack with @@ -813,17 +830,17 @@ let try_red_product env sigma c = | Some (recargnum,recarg) -> let recarg' = redrec env recarg in let stack' = Stack.assign stack recargnum recarg' in - simpfun (Stack.zip (f,stack'))) - | _ -> simpfun (appvect (redrec env f, l))) + simpfun (Stack.zip sigma (f,stack'))) + | _ -> simpfun (mkApp (redrec env f, l))) | Cast (c,_,_) -> redrec env c | Prod (x,a,b) -> let open Context.Rel.Declaration in - mkProd (x, a, redrec (push_rel (LocalAssum (x,a)) env) b) - | LetIn (x,a,b,t) -> redrec env (subst1 a t) + mkProd (x, a, redrec (push_rel (LocalAssum (x, inj a)) env) b) + | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | Proj (p, c) -> let c' = - match kind_of_term c with + match EConstr.kind sigma c with | Construct _ -> c | _ -> redrec env c in @@ -832,15 +849,15 @@ let try_red_product env sigma c = | Reduced s -> simpfun (applist s) | NotReducible -> raise Redelimination) | _ -> - (match match_eval_ref env x with + (match match_eval_ref env sigma x with | Some (ref, u) -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) (match reference_opt_value env sigma ref u with | None -> raise Redelimination - | Some c -> c) + | Some c -> EConstr.of_constr c) | _ -> raise Redelimination) - in redrec env c + in EConstr.Unsafe.to_constr (redrec env c) let red_product env sigma c = try try_red_product env sigma c @@ -911,22 +928,23 @@ let whd_simpl_stack = immediately hides a non reducible fix or a cofix *) let whd_simpl_orelse_delta_but_fix env sigma c = + let open EConstr in let rec redrec s = let (constr, stack as s') = whd_simpl_stack env sigma s in - match match_eval_ref_value env sigma constr with + match match_eval_ref_value env sigma (EConstr.Unsafe.to_constr constr) with | Some c -> (match kind_of_term (strip_lam c) with | CoFix _ | Fix _ -> s' | Proj (p,t) when - (match kind_of_term constr with + (match EConstr.kind sigma constr with | Const (c', _) -> eq_constant (Projection.constant p) c' | _ -> false) -> let pb = Environ.lookup_projection p env in if List.length stack <= pb.Declarations.proj_npars then (** Do not show the eta-expanded form *) s' - else redrec (applist (c, stack)) - | _ -> redrec (applist(c, stack))) + else redrec (applist (EConstr.of_constr c, stack)) + | _ -> redrec (applist(EConstr.of_constr c, stack))) | None -> s' in let simpfun = clos_norm_flags betaiota env sigma in @@ -937,7 +955,7 @@ let hnf_constr = whd_simpl_orelse_delta_but_fix (* The "simpl" reduction tactic *) let whd_simpl env sigma c = - applist (whd_simpl_stack env sigma c) + EConstr.Unsafe.to_constr (EConstr.applist (whd_simpl_stack env sigma c)) let simpl env sigma c = strong whd_simpl env sigma c @@ -993,7 +1011,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); - let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in + let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) (EConstr.of_constr t) in (evd := Sigma.to_evar_map evm; t) end else @@ -1011,7 +1029,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> (fun d (env,c) -> (push_rel d env,lift_pattern 1 c)) (traverse nested) envc sigma t in - let t' = traverse None (env,c) t in + let t' = traverse None (env,c) (EConstr.Unsafe.to_constr t) in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; Sigma.Unsafe.of_pair (t', !evd) end } @@ -1028,7 +1046,7 @@ let contextually byhead occs f env sigma t = * ol is the occurrence list to find. *) let match_constr_evaluable_ref sigma c evref = - match kind_of_term c, evref with + match EConstr.kind sigma c, evref with | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u | Var id, EvalVarRef id' when id_eq id id' -> Some Univ.Instance.empty | _, _ -> None @@ -1037,7 +1055,7 @@ let substlin env sigma evalref n (nowhere_except_in,locs) c = let maxocc = List.fold_right max locs 0 in let pos = ref n in assert (List.for_all (fun x -> x >= 0) locs); - let value u = value_of_evaluable_ref env evalref u in + let value u = EConstr.of_constr (value_of_evaluable_ref env evalref u) in let rec substrec () c = if nowhere_except_in && !pos > maxocc then c else @@ -1049,9 +1067,10 @@ let substlin env sigma evalref n (nowhere_except_in,locs) c = incr pos; if ok then value u else c | None -> - map_constr_with_binders_left_to_right + let self () c = EConstr.Unsafe.to_constr (substrec () (EConstr.of_constr c)) in + EConstr.of_constr (map_constr_with_binders_left_to_right (fun _ () -> ()) - substrec () c + self () (EConstr.Unsafe.to_constr c)) in let t' = substrec () c in (!pos, t') @@ -1085,39 +1104,39 @@ let unfoldoccs env sigma (occs,name) c = nf_betaiotazeta sigma uc in match occs with - | NoOccurrences -> c + | NoOccurrences -> EConstr.Unsafe.to_constr c | AllOccurrences -> unfold env sigma name c | OnlyOccurrences l -> unfo true l | AllOccurrencesBut l -> unfo false l (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = - List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname + EConstr.Unsafe.to_constr (List.fold_left (fun c occname -> EConstr.of_constr (unfoldoccs env sigma occname c)) c loccname) (* Re-folding constants tactics: refold com in term c *) let fold_one_com com env sigma c = let rcom = - try red_product env sigma com + try red_product env sigma (EConstr.of_constr com) with Redelimination -> error "Not reducible." in (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) - let a = subst_term sigma (EConstr.of_constr (clos_norm_flags unfold_side_red env sigma rcom)) (EConstr.of_constr c) in - if not (eq_constr a c) then + let a = subst_term sigma (EConstr.of_constr (clos_norm_flags unfold_side_red env sigma (EConstr.of_constr rcom))) c in + if not (eq_constr a (EConstr.Unsafe.to_constr c)) then subst1 com a else (* Then reason on the non beta-iota-zeta form for compatibility - even if it is probably a useless configuration *) - let a = subst_term sigma (EConstr.of_constr rcom) (EConstr.of_constr c) in + let a = subst_term sigma (EConstr.of_constr rcom) c in subst1 com a let fold_commands cl env sigma c = - List.fold_right (fun com -> fold_one_com com env sigma) (List.rev cl) c + EConstr.Unsafe.to_constr (List.fold_right (fun com c -> EConstr.of_constr (fold_one_com com env sigma c)) (List.rev cl) c) (* call by value reduction functions *) let cbv_norm_flags flags env sigma t = - cbv_norm (create_cbv_infos flags env sigma) t + cbv_norm (create_cbv_infos flags env sigma) (EConstr.Unsafe.to_constr t) let cbv_beta = cbv_norm_flags beta empty_env let cbv_betaiota = cbv_norm_flags betaiota empty_env @@ -1142,7 +1161,7 @@ let abstract_scheme env (locc,a) (c, sigma) = let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> let sigma = Sigma.to_evar_map sigma in - let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (c,sigma) in + let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (EConstr.Unsafe.to_constr c,sigma) in try let _ = Typing.unsafe_type_of env sigma abstr_trm in Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) @@ -1170,7 +1189,7 @@ let check_not_primitive_record env ind = let reduce_to_ind_gen allow_product env sigma t = let rec elimrec env t l = - let t = hnf_constr env sigma t in + let t = hnf_constr env sigma (EConstr.of_constr t) in match kind_of_term (fst (decompose_app t)) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> @@ -1182,7 +1201,7 @@ let reduce_to_ind_gen allow_product env sigma t = | _ -> (* Last chance: we allow to bypass the Opaque flag (as it was partially the case between V5.10 and V8.1 *) - let t' = whd_all env sigma t in + let t' = whd_all env sigma (EConstr.of_constr t) in match kind_of_term (fst (decompose_app t')) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) | _ -> user_err (str"Not an inductive product.") @@ -1202,14 +1221,15 @@ let find_hnf_rectype env sigma t = exception NotStepReducible let one_step_reduce env sigma c = + let open EConstr in let rec redrec (x, stack) = - match kind_of_term x with + match EConstr.kind sigma x with | Lambda (n,t,c) -> (match stack with | [] -> raise NotStepReducible - | a :: rest -> (subst1 a c, rest)) + | a :: rest -> (Vars.subst1 a c, rest)) | App (f,cl) -> redrec (f, (Array.to_list cl)@stack) - | LetIn (_,f,_,cl) -> (subst1 f cl,stack) + | LetIn (_,f,_,cl) -> (Vars.subst1 f cl,stack) | Cast (c,_,_) -> redrec (c,stack) | Case (ci,p,c,lf) -> (try @@ -1221,13 +1241,13 @@ let one_step_reduce env sigma c = | Reduced s' -> s' | NotReducible -> raise NotStepReducible with Redelimination -> raise NotStepReducible) - | _ when isEvalRef env x -> - let ref,u = destEvalRefU x in + | _ when isEvalRef env (EConstr.Unsafe.to_constr x) -> + let ref,u = destEvalRefU (EConstr.Unsafe.to_constr x) in (try fst (red_elim_const env sigma ref u stack) with Redelimination -> match reference_opt_value env sigma ref u with - | Some d -> (d, stack) + | Some d -> (EConstr.of_constr d, stack) | None -> raise NotStepReducible) | _ -> raise NotStepReducible @@ -1249,7 +1269,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = else (* lazily reduces to match the head of [t] with the expected [ref] *) let rec elimrec env t l = - let c, _ = decompose_appvect (Reductionops.whd_nored sigma t) in + let c, _ = decompose_app_vect sigma (EConstr.of_constr t) in match kind_of_term c with | Prod (n,ty,t') -> if allow_product then @@ -1264,7 +1284,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = else raise Not_found with Not_found -> try - let t' = nf_betaiota sigma (one_step_reduce env sigma t) in + let t' = nf_betaiota sigma (one_step_reduce env sigma (EConstr.of_constr t)) in elimrec env t' l with NotStepReducible -> error_cannot_recognize ref in diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 4207eccb9a..50dd66ea0a 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -289,7 +289,7 @@ let build_subclasses ~check env sigma glob pri = | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = - Reductionops.whd_beta sigma (appvectc c (Context.Rel.to_extended_vect 0 rels)) + Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect 0 rels))) in let projargs = Array.of_list (args @ [instapp]) in let projs = List.map_filter diff --git a/pretyping/typing.ml b/pretyping/typing.ml index e79e3d46f1..e3d1c17413 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -36,7 +36,7 @@ let inductive_type_knowing_parameters env (ind,u) jl = Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp let e_type_judgment env evdref j = - match kind_of_term (whd_all env !evdref j.uj_type) with + match kind_of_term (whd_all env !evdref (EConstr.of_constr j.uj_type)) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | Evar ev -> let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in @@ -54,7 +54,7 @@ let e_judge_of_apply env evdref funj argjv = { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ } | hj::restjl -> - match kind_of_term (whd_all env !evdref typ) with + match kind_of_term (whd_all env !evdref (EConstr.of_constr typ)) with | Prod (_,c1,c2) -> if Evarconv.e_cumul env evdref hj.uj_type c1 then apply_rec (n+1) (subst1 hj.uj_val c2) restjl @@ -87,7 +87,7 @@ let e_is_correct_arity env evdref c pj ind specif params = let allowed_sorts = elim_sorts specif in let error () = error_elim_arity env ind allowed_sorts c pj None in let rec srec env pt ar = - let pt' = whd_all env !evdref pt in + let pt' = whd_all env !evdref (EConstr.of_constr pt) in match kind_of_term pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> if not (Evarconv.e_cumul env evdref a1 a1') then error (); @@ -113,12 +113,12 @@ let e_type_case_branches env evdref (ind,largs) pj c = let () = e_is_correct_arity env evdref c pj ind specif params in let lc = build_branches_type ind specif params p in let n = (snd specif).Declarations.mind_nrealdecls in - let ty = whd_betaiota !evdref (lambda_applist_assum (n+1) p (realargs@[c])) in + let ty = whd_betaiota !evdref (EConstr.of_constr (lambda_applist_assum (n+1) p (realargs@[c]))) in (lc, ty) let e_judge_of_case env evdref ci pj cj lfj = let indspec = - try find_mrectype env !evdref cj.uj_type + try find_mrectype env !evdref (EConstr.of_constr cj.uj_type) with Not_found -> error_case_not_inductive env cj in let _ = check_case_info env (fst indspec) ci in let (bty,rslty) = e_type_case_branches env evdref indspec pj cj.uj_val in @@ -139,7 +139,7 @@ let check_type_fixpoint loc env evdref lna lar vdefj = (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in - let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in + let ksort = family_of_sort (sort_of_arity env sigma (EConstr.of_constr pj.uj_type)) in let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 3134dac6a6..ede2606daf 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -68,7 +68,7 @@ let occur_meta_or_undefined_evar evd c = let occur_meta_evd sigma mv c = let rec occrec c = (* Note: evars are not instantiated by terms with metas *) - let c = whd_evar sigma (whd_meta sigma c) in + let c = whd_evar sigma (whd_meta sigma (EConstr.of_constr c)) in match kind_of_term c with | Meta mv' when Int.equal mv mv' -> raise Occur | _ -> Constr.iter occrec c @@ -98,7 +98,7 @@ let abstract_scheme env evd c l lname_typ = (* Precondition: resulting abstraction is expected to be of type [typ] *) let abstract_list_all env evd typ c l = - let ctxt,_ = splay_prod_n env evd (List.length l) typ in + let ctxt,_ = splay_prod_n env evd (List.length l) (EConstr.of_constr typ) in let l_with_all_occs = List.map (function a -> (LikeFirst,a)) l in let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in let evd,typp = @@ -480,8 +480,8 @@ let unfold_projection env p stk = let expand_key ts env sigma = function | Some (IsKey k) -> expand_table_key env k | Some (IsProj (p, c)) -> - let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma - Cst_stack.empty (c, unfold_projection env p []))) + let red = EConstr.Unsafe.to_constr (Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma + Cst_stack.empty (EConstr.of_constr c, unfold_projection env p [])))) in if Term.eq_constr (mkProj (p, c)) red then None else Some red | None -> None @@ -576,8 +576,8 @@ let constr_cmp pb sigma flags t u = sigma, false let do_reduce ts (env, nb) sigma c = - Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state - ts env sigma Cst_stack.empty (c, Stack.empty))) + EConstr.Unsafe.to_constr (Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state + ts env sigma Cst_stack.empty (EConstr.of_constr c, Stack.empty)))) let use_full_betaiota flags = flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3 @@ -977,33 +977,33 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (whd_betaiotazeta sigma (mkApp(c,l1))) cN + (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l1)))) cN | None -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (whd_betaiotazeta sigma (mkApp(c,l2))) + (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l2)))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (whd_betaiotazeta sigma (mkApp(c,l2))) + (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l2)))) | None -> (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (whd_betaiotazeta sigma (mkApp(c,l1))) cN + (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l1)))) cN | None -> error_cannot_unify curenv sigma (cM,cN))) and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = if isApp cM then - let f1l1 = whd_nored_state sigma (cM,Stack.empty) in + let f1l1 = whd_nored_state sigma (EConstr.of_constr cM,Stack.empty) in if is_open_canonical_projection curenv sigma f1l1 then - let f2l2 = whd_nored_state sigma (cN,Stack.empty) in + let f2l2 = whd_nored_state sigma (EConstr.of_constr cN,Stack.empty) in solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1017,9 +1017,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb else try f1 () with e when precatchable_exception e -> if isApp cN then - let f2l2 = whd_nored_state sigma (cN, Stack.empty) in + let f2l2 = whd_nored_state sigma (EConstr.of_constr cN, Stack.empty) in if is_open_canonical_projection curenv sigma f2l2 then - let f1l1 = whd_nored_state sigma (cM, Stack.empty) in + let f1l1 = whd_nored_state sigma (EConstr.of_constr cM, Stack.empty) in solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1044,13 +1044,14 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb in try let opt' = {opt with with_types = false} in + let inj = EConstr.Unsafe.to_constr in let (substn,_,_) = Reductionops.Stack.fold2 - (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) + (fun s u1 u -> unirec_rec curenvnb pb opt' s (inj u1) (substl ks (inj u))) (evd,ms,es) us2 us in let (substn,_,_) = Reductionops.Stack.fold2 - (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) + (fun s u1 u -> unirec_rec curenvnb pb opt' s (inj u1) (substl ks (inj u))) substn params1 params in - let (substn,_,_) = Reductionops.Stack.fold2 (unirec_rec curenvnb pb opt') substn ts ts1 in + let (substn,_,_) = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s (inj u1) (inj u2)) substn ts ts1 in let app = mkApp (c, Array.rev_of_list ks) in (* let substn = unirec_rec curenvnb pb b false substn t cN in *) unirec_rec curenvnb pb opt' substn c1 app @@ -1206,7 +1207,7 @@ let applyHead env (type r) (evd : r Sigma.t) n c = if Int.equal n 0 then Sigma (c, evd, p) else - match kind_of_term (whd_all env (Sigma.to_evar_map evd) cty) with + match kind_of_term (whd_all env (Sigma.to_evar_map evd) (EConstr.of_constr cty)) with | Prod (_,c1,c2) -> let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' @@ -1235,7 +1236,7 @@ let w_coerce_to_type env evd c cty mvty = (* inh_conv_coerce_rigid_to should have reasoned modulo reduction but there are cases where it though it was not rigid (like in fst (nat,nat)) and stops while it could have seen that it is rigid *) - let cty = Tacred.hnf_constr env evd cty in + let cty = Tacred.hnf_constr env evd (EConstr.of_constr cty) in try_to_coerce env evd c cty tycon let w_coerce env evd mv c = @@ -1246,7 +1247,7 @@ let w_coerce env evd mv c = let unify_to_type env sigma flags c status u = let sigma, c = refresh_universes (Some false) env sigma c in let t = get_type_of env sigma (nf_meta sigma c) in - let t = nf_betaiota sigma (nf_meta sigma t) in + let t = nf_betaiota sigma (EConstr.of_constr (nf_meta sigma t)) in unify_0 env sigma CUMUL flags t u let unify_type env sigma flags mv status c = @@ -1270,7 +1271,7 @@ let order_metas metas = (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) let solve_simple_evar_eqn ts env evd ev rhs = - match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with + match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,EConstr.of_constr rhs) with | UnifFailure (evd,reason) -> error_cannot_unify env evd ~reason (mkEvar ev,rhs); | Success evd -> @@ -1349,7 +1350,7 @@ let w_merge env with_types flags (evd,metas,evars) = else let evd' = if occur_meta_evd evd mv c then - if isMetaOf mv (whd_all env evd c) then evd + if isMetaOf mv (whd_all env evd (EConstr.of_constr c)) then evd else error_cannot_unify env evd (mkMeta mv,c) else meta_assign mv (c,(status,TypeProcessed)) evd in @@ -1415,7 +1416,7 @@ let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = types of metavars are unifiable with the types of their instances *) let head_app sigma m = - fst (whd_nored_state sigma (m, Stack.empty)) + EConstr.Unsafe.to_constr (fst (whd_nored_state sigma (EConstr.of_constr m, Stack.empty))) let check_types env flags (sigma,_,_ as subst) m n = if isEvar_or_Meta (head_app sigma m) then @@ -1577,7 +1578,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = (fun test -> match test.testing_state with | None -> None | Some (sigma,_,l) -> - let c = applist (nf_evar sigma (local_strong whd_meta sigma c),l) in + let c = applist (nf_evar sigma (local_strong whd_meta sigma (EConstr.of_constr c)),l) in let univs, subst = nf_univ_variables sigma in Some (sigma,subst_univs_constr subst c)) @@ -1832,7 +1833,7 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let w_unify_to_subterm_list env evd flags hdmeta oplist t = List.fold_right (fun op (evd,l) -> - let op = whd_meta evd op in + let op = whd_meta evd (EConstr.of_constr op) in if isMeta op then if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l) else error_abstraction_over_meta env evd hdmeta (destMeta op) @@ -1905,15 +1906,16 @@ let secondOrderAbstractionAlgo dep = if dep then secondOrderDependentAbstraction else secondOrderAbstraction let w_unify2 env evd flags dep cv_pb ty1 ty2 = - let c1, oplist1 = whd_nored_stack evd ty1 in - let c2, oplist2 = whd_nored_stack evd ty2 in - match kind_of_term c1, kind_of_term c2 with + let inj = EConstr.Unsafe.to_constr in + let c1, oplist1 = whd_nored_stack evd (EConstr.of_constr ty1) in + let c2, oplist2 = whd_nored_stack evd (EConstr.of_constr ty2) in + match EConstr.kind evd c1, EConstr.kind evd c2 with | Meta p1, _ -> (* Find the predicate *) - secondOrderAbstractionAlgo dep env evd flags ty2 (p1,oplist1) + secondOrderAbstractionAlgo dep env evd flags ty2 (p1, List.map inj oplist1) | _, Meta p2 -> (* Find the predicate *) - secondOrderAbstractionAlgo dep env evd flags ty1 (p2, oplist2) + secondOrderAbstractionAlgo dep env evd flags ty1 (p2, List.map inj oplist2) | _ -> error "w_unify2" (* The unique unification algorithm works like this: If the pattern is @@ -1937,8 +1939,8 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = - let hd1,l1 = decompose_appvect (whd_nored evd ty1) in - let hd2,l2 = decompose_appvect (whd_nored evd ty2) in + let hd1,l1 = decompose_appvect (whd_nored evd (EConstr.of_constr ty1)) in + let hd2,l2 = decompose_appvect (whd_nored evd (EConstr.of_constr ty2)) in let is_empty1 = Array.is_empty l1 in let is_empty2 = Array.is_empty l2 in match kind_of_term hd1, not is_empty1, kind_of_term hd2, not is_empty2 with diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 75159bf8bc..8c3de7cfd4 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -99,13 +99,13 @@ let construct_of_constr_block = construct_of_constr false let type_of_ind env (ind, u) = type_of_inductive env (Inductive.lookup_mind_specif env ind, u) -let build_branches_type env (mind,_ as _ind) mib mip u params dep p = +let build_branches_type env sigma (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = let typi = type_constructor mind mib u cty params in - let decl,indapp = Reductionops.splay_prod env Evd.empty typi in + let decl,indapp = Reductionops.splay_prod env sigma (EConstr.of_constr typi) in let decl_with_letin,_ = decompose_prod_assum typi in let ((ind,u),cargs) = find_rectype_a env indapp in let nparams = Array.length params in @@ -131,28 +131,28 @@ let build_case_type dep p realargs c = (* La fonction de normalisation *) -let rec nf_val env v t = nf_whd env (whd_val v) t +let rec nf_val env sigma v t = nf_whd env sigma (whd_val v) t -and nf_vtype env v = nf_val env v crazy_type +and nf_vtype env sigma v = nf_val env sigma v crazy_type -and nf_whd env whd typ = +and nf_whd env sigma whd typ = match whd with | Vsort s -> mkSort s | Vprod p -> - let dom = nf_vtype env (dom p) in + let dom = nf_vtype env sigma (dom p) in let name = Name (Id.of_string "x") in let vc = body_of_vfun (nb_rel env) (codom p) in - let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) vc in + let codom = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vc in mkProd(name,dom,codom) - | Vfun f -> nf_fun env f typ - | Vfix(f,None) -> nf_fix env f - | Vfix(f,Some vargs) -> fst (nf_fix_app env f vargs) - | Vcofix(cf,_,None) -> nf_cofix env cf + | Vfun f -> nf_fun env sigma f typ + | Vfix(f,None) -> nf_fix env sigma f + | Vfix(f,Some vargs) -> fst (nf_fix_app env sigma f vargs) + | Vcofix(cf,_,None) -> nf_cofix env sigma cf | Vcofix(cf,_,Some vargs) -> - let cfd = nf_cofix env cf in + let cfd = nf_cofix env sigma cf in let i,(_,ta,_) = destCoFix cfd in let t = ta.(i) in - let _, args = nf_args env vargs t in + let _, args = nf_args env sigma vargs t in mkApp(cfd,args) | Vconstr_const n -> construct_of_constr_const env n typ @@ -165,10 +165,10 @@ and nf_whd env whd typ = | _ -> assert false else (tag, 0) in let capp,ctyp = construct_of_constr_block env tag typ in - let args = nf_bargs env b ofs ctyp in + let args = nf_bargs env sigma b ofs ctyp in mkApp(capp,args) | Vatom_stk(Aid idkey, stk) -> - constr_type_of_idkey env idkey stk + constr_type_of_idkey env sigma idkey stk | Vatom_stk(Aind ((mi,i) as ind), stk) -> let mib = Environ.lookup_mind mi env in let nb_univs = @@ -178,12 +178,12 @@ and nf_whd env whd typ = let mk u = let pind = (ind, u) in (mkIndU pind, type_of_ind env pind) in - nf_univ_args ~nb_univs mk env stk + nf_univ_args ~nb_univs mk env sigma stk | Vatom_stk(Atype u, stk) -> assert false | Vuniv_level lvl -> assert false -and nf_univ_args ~nb_univs mk env stk = +and nf_univ_args ~nb_univs mk env sigma stk = let u = if Int.equal nb_univs 0 then Univ.Instance.empty else match stk with @@ -195,9 +195,9 @@ and nf_univ_args ~nb_univs mk env stk = | _ -> assert false in let (t,ty) = mk u in - nf_stk ~from:nb_univs env t ty stk + nf_stk ~from:nb_univs env sigma t ty stk -and constr_type_of_idkey env (idkey : Vars.id_key) stk = +and constr_type_of_idkey env sigma (idkey : Vars.id_key) stk = match idkey with | ConstKey cst -> let cbody = Environ.lookup_constant cst env in @@ -208,30 +208,30 @@ and constr_type_of_idkey env (idkey : Vars.id_key) stk = let mk u = let pcst = (cst, u) in (mkConstU pcst, Typeops.type_of_constant_in env pcst) in - nf_univ_args ~nb_univs mk env stk + nf_univ_args ~nb_univs mk env sigma stk | VarKey id -> let ty = NamedDecl.get_type (lookup_named id env) in - nf_stk env (mkVar id) ty stk + nf_stk env sigma (mkVar id) ty stk | RelKey i -> let n = (nb_rel env - i) in let ty = RelDecl.get_type (lookup_rel n env) in - nf_stk env (mkRel n) (lift n ty) stk + nf_stk env sigma (mkRel n) (lift n ty) stk -and nf_stk ?from:(from=0) env c t stk = +and nf_stk ?from:(from=0) env sigma c t stk = match stk with | [] -> c | Zapp vargs :: stk -> if nargs vargs >= from then - let t, args = nf_args ~from:from env vargs t in - nf_stk env (mkApp(c,args)) t stk + let t, args = nf_args ~from:from env sigma vargs t in + nf_stk env sigma (mkApp(c,args)) t stk else let rest = from - nargs vargs in - nf_stk ~from:rest env c t stk + nf_stk ~from:rest env sigma c t stk | Zfix (f,vargs) :: stk -> assert (from = 0) ; - let fa, typ = nf_fix_app env f vargs in + let fa, typ = nf_fix_app env sigma f vargs in let _,_,codom = decompose_prod env typ in - nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk + nf_stk env sigma (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> assert (from = 0) ; let ((mind,_ as ind), u), allargs = find_rectype_a env t in @@ -241,34 +241,34 @@ and nf_stk ?from:(from=0) env c t stk = let pT = hnf_prod_applist env (type_of_ind env (ind,u)) (Array.to_list params) in let pT = whd_all env pT in - let dep, p = nf_predicate env (ind,u) mip params (type_of_switch sw) pT in + let dep, p = nf_predicate env sigma (ind,u) mip params (type_of_switch sw) pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip u params dep p in + let btypes = build_branches_type env sigma ind mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = let decl,decl_with_letin,codom = btypes.(i) in - let b = nf_val (Termops.push_rels_assum decl env) v codom in + let b = nf_val (Termops.push_rels_assum decl env) sigma v codom in Termops.it_mkLambda_or_LetIn_from_no_LetIn b decl_with_letin in let branchs = Array.mapi mkbranch bsw in let tcase = build_case_type dep p realargs c in let ci = case_info sw in - nf_stk env (mkCase(ci, p, c, branchs)) tcase stk + nf_stk env sigma (mkCase(ci, p, c, branchs)) tcase stk | Zproj p :: stk -> assert (from = 0) ; let p' = Projection.make p true in - let ty = Inductiveops.type_of_projection_knowing_arg env Evd.empty p' c t in - nf_stk env (mkProj(p',c)) ty stk + let ty = Inductiveops.type_of_projection_knowing_arg env sigma p' (EConstr.of_constr c) (EConstr.of_constr t) in + nf_stk env sigma (mkProj(p',c)) ty stk -and nf_predicate env ind mip params v pT = +and nf_predicate env sigma ind mip params v pT = match whd_val v, kind_of_term pT with | Vfun f, Prod _ -> let k = nb_rel env in let vb = body_of_vfun k f in let name,dom,codom = decompose_prod env pT in let dep,body = - nf_predicate (push_rel (LocalAssum (name,dom)) env) ind mip params vb codom in + nf_predicate (push_rel (LocalAssum (name,dom)) env) sigma ind mip params vb codom in dep, mkLambda(name,dom,body) | Vfun f, _ -> let k = nb_rel env in @@ -278,33 +278,33 @@ and nf_predicate env ind mip params v pT = let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in let dom = mkApp(mkIndU ind,Array.append params rargs) in - let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) vb in + let body = nf_vtype (push_rel (LocalAssum (name,dom)) env) sigma vb in true, mkLambda(name,dom,body) - | _, _ -> false, nf_val env v crazy_type + | _, _ -> false, nf_val env sigma v crazy_type -and nf_args env vargs ?from:(f=0) t = +and nf_args env sigma vargs ?from:(f=0) t = let t = ref t in let len = nargs vargs - f in let args = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env (arg vargs (f+i)) dom in + let c = nf_val env sigma (arg vargs (f+i)) dom in t := subst1 c codom; c) in !t,args -and nf_bargs env b ofs t = +and nf_bargs env sigma b ofs t = let t = ref t in let len = bsize b - ofs in let args = Array.init len (fun i -> let _,dom,codom = decompose_prod env !t in - let c = nf_val env (bfield b (i+ofs)) dom in + let c = nf_val env sigma (bfield b (i+ofs)) dom in t := subst1 c codom; c) in args -and nf_fun env f typ = +and nf_fun env sigma f typ = let k = nb_rel env in let vb = body_of_vfun k f in let name,dom,codom = @@ -314,46 +314,46 @@ and nf_fun env f typ = CErrors.anomaly (Pp.strbrk "Returned a functional value in a type not recognized as a product type.") in - let body = nf_val (push_rel (LocalAssum (name,dom)) env) vb codom in + let body = nf_val (push_rel (LocalAssum (name,dom)) env) sigma vb codom in mkLambda(name,dom,body) -and nf_fix env f = +and nf_fix env sigma f = let init = current_fix f in let rec_args = rec_args f in let k = nb_rel env in let vb, vt = reduce_fix k f in let ndef = Array.length vt in - let ft = Array.map (fun v -> nf_val env v crazy_type) vt in + let ft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in let name = Array.init ndef (fun _ -> (Name (Id.of_string "Ffix"))) in (* Third argument of the tuple is ignored by push_rec_types *) let env = push_rec_types (name,ft,ft) env in (* We lift here because the types of arguments (in tt) will be evaluated in an environment where the fixpoints have been pushed *) - let norm_vb v t = nf_fun env v (lift ndef t) in + let norm_vb v t = nf_fun env sigma v (lift ndef t) in let fb = Util.Array.map2 norm_vb vb ft in mkFix ((rec_args,init),(name,ft,fb)) -and nf_fix_app env f vargs = - let fd = nf_fix env f in +and nf_fix_app env sigma f vargs = + let fd = nf_fix env sigma f in let (_,i),(_,ta,_) = destFix fd in let t = ta.(i) in - let t, args = nf_args env vargs t in + let t, args = nf_args env sigma vargs t in mkApp(fd,args),t -and nf_cofix env cf = +and nf_cofix env sigma cf = let init = current_cofix cf in let k = nb_rel env in let vb,vt = reduce_cofix k cf in let ndef = Array.length vt in - let cft = Array.map (fun v -> nf_val env v crazy_type) vt in + let cft = Array.map (fun v -> nf_val env sigma v crazy_type) vt in let name = Array.init ndef (fun _ -> (Name (Id.of_string "Fcofix"))) in let env = push_rec_types (name,cft,cft) env in - let cfb = Util.Array.map2 (fun v t -> nf_val env v t) vb cft in + let cfb = Util.Array.map2 (fun v t -> nf_val env sigma v t) vb cft in mkCoFix (init,(name,cft,cfb)) -let cbv_vm env c t = +let cbv_vm env sigma c t = let v = Vconv.val_of_constr env c in - nf_val env v t + nf_val env sigma v t let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb) diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 58f5b14e1c..bc6eec851f 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -10,4 +10,4 @@ open Term open Environ (** {6 Reduction functions } *) -val cbv_vm : env -> constr -> types -> constr +val cbv_vm : env -> Evd.evar_map -> constr -> types -> constr -- cgit v1.2.3 From 2db085e62f7797cc999518eb58983ac059763e1f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Nov 2016 14:13:08 +0100 Subject: Vnorm API using EConstr. --- pretyping/vnorm.ml | 5 +++++ pretyping/vnorm.mli | 4 ++-- 2 files changed, 7 insertions(+), 2 deletions(-) (limited to 'pretyping') diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 8c3de7cfd4..60f99fd3d8 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -352,6 +352,11 @@ and nf_cofix env sigma cf = mkCoFix (init,(name,cft,cfb)) let cbv_vm env sigma c t = + if Termops.occur_meta_or_existential sigma c then + CErrors.error "vm_compute does not support existential variables."; + (** This evar-normalizes terms beforehand *) + let c = EConstr.to_constr sigma c in + let t = EConstr.to_constr sigma t in let v = Vconv.val_of_constr env c in nf_val env sigma v t diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index bc6eec851f..650f3f2911 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -6,8 +6,8 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Term +open EConstr open Environ (** {6 Reduction functions } *) -val cbv_vm : env -> Evd.evar_map -> constr -> types -> constr +val cbv_vm : env -> Evd.evar_map -> constr -> types -> Constr.t -- cgit v1.2.3 From 6bd193ff409b01948751525ce0f905916d7a64bd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Nov 2016 14:38:35 +0100 Subject: Nativenorm API using EConstr. --- pretyping/nativenorm.ml | 6 +++++- pretyping/nativenorm.mli | 5 +++-- pretyping/pretyping.ml | 2 +- 3 files changed, 9 insertions(+), 4 deletions(-) (limited to 'pretyping') diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index e45c920a32..c8bcae0c85 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -377,7 +377,9 @@ let evars_of_evar_map sigma = Nativelambda.evars_typ = Evd.existential_type sigma; Nativelambda.evars_metas = Evd.meta_type sigma } -let native_norm env sigma c ty = +let native_norm env sigma c ty = + let c = EConstr.Unsafe.to_constr c in + let ty = EConstr.Unsafe.to_constr ty in if Coq_config.no_native_compiler then error "Native_compute reduction has been disabled at configure time." else @@ -407,5 +409,7 @@ let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t let native_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = + let t1 = EConstr.Unsafe.to_constr t1 in + let t2 = EConstr.Unsafe.to_constr t2 in Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma) ~catch_incon:true ~pb env sigma t1 t2 diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index 0b1ce8e511..ba46138a4f 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -5,13 +5,14 @@ (* // * This file is distributed under the terms of the *) (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Term + +open EConstr open Environ open Evd (** This module implements normalization by evaluation to OCaml code *) -val native_norm : env -> evar_map -> constr -> types -> constr +val native_norm : env -> evar_map -> constr -> types -> Constr.t (** Conversion with inference of universe constraints *) val native_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 3a6d4f36cc..2f42ad3954 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1021,7 +1021,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let cj = pretype empty_tycon env evdref lvar c in let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in begin - let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in + let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref (EConstr.of_constr cty) (EConstr.of_constr tval) in if b then (evdref := evd; cj, tval) else error_actual_type ~loc env.ExtraEnv.env !evdref cj tval -- cgit v1.2.3 From d528fdaf12b74419c47698cca7c6f1ec762245a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Nov 2016 14:48:36 +0100 Subject: Retyping API using EConstr. --- pretyping/cases.ml | 14 ++--- pretyping/classops.ml | 2 +- pretyping/coercion.ml | 4 +- pretyping/constr_matching.ml | 8 +-- pretyping/detyping.ml | 6 +-- pretyping/evarconv.ml | 12 ++--- pretyping/evarsolve.ml | 16 +++--- pretyping/evarsolve.mli | 2 +- pretyping/inductiveops.ml | 4 +- pretyping/inductiveops.mli | 2 +- pretyping/patternops.ml | 2 +- pretyping/pretyping.ml | 8 +-- pretyping/retyping.ml | 126 +++++++++++++++++++++++-------------------- pretyping/retyping.mli | 16 +++--- pretyping/tacred.ml | 4 +- pretyping/typeclasses.ml | 4 +- pretyping/typing.ml | 2 +- pretyping/unification.ml | 32 +++++------ 18 files changed, 137 insertions(+), 127 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index be72091a91..4dd5021060 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1480,7 +1480,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = if not (Flags.is_program_mode ()) && (isRel orig || isVar orig) then (* Try to compile first using non expanded alias *) try - if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) orig) + if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) (EConstr.of_constr orig)) else just_pop () with e when precatchable_exception e -> (* Try then to compile using expanded alias *) @@ -1495,7 +1495,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = (* Could be needed in case of a recursive call which requires to be on a variable for size reasons *) pb.evdref := sigma; - if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) orig) + if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) (EConstr.of_constr orig)) else just_pop () @@ -1627,7 +1627,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = let t = whd_evar !evdref t in match kind_of_term t with | Rel n when is_local_def (lookup_rel n env) -> t | Evar ev -> - let ty = get_type_of env !evdref t in + let ty = get_type_of env !evdref (EConstr.of_constr t) in let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in let inst = List.map_i @@ -1649,7 +1649,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = - let ty = get_type_of env !evdref t in + let ty = get_type_of env !evdref (EConstr.of_constr t) in Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in let ty = lift (-k) (aux x ty) in @@ -1798,7 +1798,7 @@ let build_inversion_problem loc env sigma tms t = it = None } } ] in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) - let s' = Retyping.get_sort_of env sigma t in + let s' = Retyping.get_sort_of env sigma (EConstr.of_constr t) in let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in let sigma = Evd.set_leq_sort env sigma s' s in let evdref = ref sigma in @@ -2067,7 +2067,7 @@ let constr_of_pat env evdref arsign pat avoid = let cstr = mkConstructU ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in - let apptype = Retyping.get_type_of env ( !evdref) app in + let apptype = Retyping.get_type_of env ( !evdref) (EConstr.of_constr app) in let IndType (indf, realargs) = find_rectype env (!evdref) (EConstr.of_constr apptype) in match alias with Anonymous -> @@ -2325,7 +2325,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> let name = RelDecl.get_name decl in let t = RelDecl.get_type decl in - let argt = Retyping.get_type_of env !evdref arg in + let argt = Retyping.get_type_of env !evdref (EConstr.of_constr arg) in let eq, refl_arg = if Reductionops.is_conv env !evdref (EConstr.of_constr argt) (EConstr.of_constr t) then (mk_eq evdref (lift (nargeqs + slift) argt) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index fd21f5bd12..577f41a7d7 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -441,7 +441,7 @@ let cache_coercion (_, c) = let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in - let typ = Retyping.get_type_of (Global.env ()) Evd.empty value in + let typ = Retyping.get_type_of (Global.env ()) Evd.empty (EConstr.of_constr value) in let xf = { coe_value = value; coe_type = typ; diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index b062da1f49..6a7f904632 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -65,7 +65,7 @@ let apply_coercion_args env evd check isproj argl funj = | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) match kind_of_term (whd_all env evd (EConstr.of_constr typ)) with | Prod (_,c1,c2) -> - if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then + if check && not (e_cumul env evdref (Retyping.get_type_of env evd (EConstr.of_constr h)) c1) then raise NoCoercion; apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") @@ -488,7 +488,7 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let v2 = Option.map (fun v -> beta_applist evd' (EConstr.of_constr (lift 1 v),[EConstr.of_constr v1])) v in let t2 = match v2 with | None -> subst_term evd' (EConstr.of_constr v1) (EConstr.of_constr t2) - | Some v2 -> Retyping.get_type_of env1 evd' v2 in + | Some v2 -> Retyping.get_type_of env1 evd' (EConstr.of_constr v2) in let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 66e6907149..1261844a06 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -221,7 +221,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels else (* Might be a projection on the right *) match kind_of_term c2 with | Proj (pr, c) when not (Projection.unfolded pr) -> - (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in + (try let term = Retyping.expand_projection env sigma pr (EConstr.of_constr c) (Array.map_to_list EConstr.of_constr args2) in sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _ -> raise PatternMatchingFailure) @@ -237,7 +237,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels with Invalid_argument _ -> raise PatternMatchingFailure else raise PatternMatchingFailure | _, Proj (pr,c) when not (Projection.unfolded pr) -> - (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in + (try let term = Retyping.expand_projection env sigma pr (EConstr.of_constr c) (Array.map_to_list EConstr.of_constr arg2) in sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _, _ -> @@ -249,7 +249,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels raise PatternMatchingFailure | PApp (c, args), Proj (pr, c2) -> - (try let term = Retyping.expand_projection env sigma pr c2 [] in + (try let term = Retyping.expand_projection env sigma pr (EConstr.of_constr c2) [] in sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) @@ -440,7 +440,7 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in if partial_app then try - let term = Retyping.expand_projection env sigma p c' [] in + let term = Retyping.expand_projection env sigma p (EConstr.of_constr c') [] in aux env term mk_ctx next with Retyping.RetypeError _ -> next () else diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index a4d943cfa6..e5e778f23a 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -501,7 +501,7 @@ let rec detype flags avoid env sigma t = try let pb = Environ.lookup_projection p (snd env) in let body = pb.Declarations.proj_body in - let ty = Retyping.get_type_of (snd env) sigma c in + let ty = Retyping.get_type_of (snd env) sigma (EConstr.of_constr c) in let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma (EConstr.of_constr ty) in let body' = strip_lam_assum body in let body' = subst_instance_constr u body' in @@ -512,7 +512,7 @@ let rec detype flags avoid env sigma t = else if print_primproj_params () then try - let c = Retyping.expand_projection (snd env) sigma p c [] in + let c = Retyping.expand_projection (snd env) sigma p (EConstr.of_constr c) [] in detype flags avoid env sigma c with Retyping.RetypeError _ -> noparams () else noparams () @@ -689,7 +689,7 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = | BLetIn -> let c = detype (lax,false) avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) - let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in + let s = try Retyping.get_sort_family_of (snd env) sigma (EConstr.of_constr ty) with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in let c = if s != InProp then c else GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in GLetIn (dl, na', c, r) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index f54a57d57d..47db71cc65 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -165,7 +165,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let params1, c1, extra_args1 = match arg with | Some c -> (* A primitive projection applied to c *) - let ty = Retyping.get_type_of ~lax:true env sigma c in + let ty = Retyping.get_type_of ~lax:true env sigma (EConstr.of_constr c) in let (i,u), ind_args = try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with _ -> raise Not_found @@ -464,7 +464,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else let f = try - let termM' = Retyping.expand_projection env evd p (EConstr.Unsafe.to_constr c) [] in + let termM' = Retyping.expand_projection env evd p c [] in let apprM', cstsM' = whd_betaiota_deltazeta_for_iota_state (fst ts) env evd cstsM (EConstr.of_constr termM',skM) @@ -643,7 +643,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Catch the p.c ~= p c' cases *) | Proj (p,c), Const (p',u) when eq_constant (Projection.constant p) p' -> let res = - try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p c []))) + try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p (EConstr.of_constr c) []))) with Retyping.RetypeError _ -> None in (match res with @@ -654,7 +654,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Const (p,u), Proj (p',c') when eq_constant p (Projection.constant p') -> let res = - try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p' c' []))) + try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p' (EConstr.of_constr c') []))) with Retyping.RetypeError _ -> None in (match res with @@ -888,7 +888,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) List.fold_left (fun (i,ks,m,test) b -> if match n with Some n -> Int.equal m n | None -> false then - let ty = Retyping.get_type_of env i t2 in + let ty = Retyping.get_type_of env i (EConstr.of_constr t2) in let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in (i,t2::ks, m-1, test) else @@ -1058,7 +1058,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let id = NamedDecl.get_id decl' in let t = NamedDecl.get_type decl' in let evs = ref [] in - let ty = Retyping.get_type_of env_rhs evd c in + let ty = Retyping.get_type_of env_rhs evd (EConstr.of_constr c) in let filter' = filter_possible_projections evd c ty ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) | _, _, [] -> [] diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 17bb1406e2..86ef8f56f1 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -141,8 +141,8 @@ let recheck_applications conv_algo env evdref t = match kind_of_term t with | App (f, args) -> let () = aux env f in - let fty = Retyping.get_type_of env !evdref f in - let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in + let fty = Retyping.get_type_of env !evdref (EConstr.of_constr f) in + let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref (EConstr.of_constr x)) args in let rec aux i ty = if i < Array.length argsty then match kind_of_term (whd_all env !evdref (EConstr.of_constr ty)) with @@ -634,7 +634,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in let id = next_name_away na avoid in let evd,t_in_sign = - let s = Retyping.get_sort_of env evd t_in_env in + let s = Retyping.get_sort_of env evd (EConstr.of_constr t_in_env) in let evd,ty_t_in_sign = refresh_universes ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env @@ -653,7 +653,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1) in let evd,ev2ty_in_sign = - let s = Retyping.get_sort_of env evd ty_in_env in + let s = Retyping.get_sort_of env evd (EConstr.of_constr ty_in_env) in let evd,ty_t_in_sign = refresh_universes ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env @@ -1161,7 +1161,7 @@ let check_evar_instance evd evk1 body conv_algo = (* FIXME: The body might be ill-typed when this is called from w_merge *) (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) let ty = - try Retyping.get_type_of ~lax:true evenv evd body + try Retyping.get_type_of ~lax:true evenv evd (EConstr.of_constr body) with Retyping.RetypeError _ -> error "Ill-typed evar instance" in match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with @@ -1365,7 +1365,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | (id,p)::_::_ -> if choose then (mkVar id, p) else raise (NotUniqueInType sols) in - let ty = lazy (Retyping.get_type_of env !evdref t) in + let ty = lazy (Retyping.get_type_of env !evdref (EConstr.of_constr t)) in let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in evdref := evd; c @@ -1428,7 +1428,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = if not !progress then raise (NotEnoughInformationEvarEvar t); (* Make the virtual left evar real *) - let ty = get_type_of env' evd t in + let ty = get_type_of env' evd (EConstr.of_constr t) in let (evd,evar'',ev'') = materialize_evar (evar_define conv_algo ~choose) env' evd k ev ty in (* materialize_evar may instantiate ev' by another evar; adjust it *) @@ -1462,7 +1462,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | _ -> None with | Some l -> - let ty = get_type_of env' !evdref t in + let ty = get_type_of env' !evdref (EConstr.of_constr t) in let candidates = try let self env c = EConstr.of_constr (imitate env (EConstr.Unsafe.to_constr c)) in diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 70e94b4dc7..ac082d1bf8 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -76,4 +76,4 @@ val remove_instance_local_defs : evar_map -> existential_key -> constr array -> constr list val get_type_of_refresh : - ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> EConstr.constr -> evar_map * types diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index a3cca2ad87..a9184777d0 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -606,7 +606,7 @@ let rec instantiate_universes env evdref scl is = function let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = match mip.mind_arity with - | RegularArity s -> sigma, subst_instance_constr u s.mind_user_arity + | RegularArity s -> sigma, EConstr.of_constr (subst_instance_constr u s.mind_user_arity) | TemplateArity ar -> let _,scl = splay_arity env sigma conclty in let ctx = List.rev mip.mind_arity_ctxt in @@ -614,7 +614,7 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = let ctx = instantiate_universes env evdref scl ar.template_level (ctx,ar.template_param_levels) in - !evdref, mkArity (List.rev ctx,scl) + !evdref, EConstr.of_constr (mkArity (List.rev ctx,scl)) let type_of_projection_knowing_arg env sigma p c ty = let c = EConstr.Unsafe.to_constr c in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 1cfdef6e58..e375a2c6be 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -195,7 +195,7 @@ i*) (********************) val type_of_inductive_knowing_conclusion : - env -> evar_map -> Inductive.mind_specif puniverses -> EConstr.types -> evar_map * types + env -> evar_map -> Inductive.mind_specif puniverses -> EConstr.types -> evar_map * EConstr.types (********************) val control_only_guard : env -> types -> unit diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 9dcb5d2a57..938b6b18eb 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -153,7 +153,7 @@ let pattern_of_constr env sigma t = | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) | Proj (p, c) -> - pattern_of_constr env (Retyping.expand_projection env sigma p c []) + pattern_of_constr env (Retyping.expand_projection env sigma p (EConstr.of_constr c) []) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 2f42ad3954..3c48c42df2 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -409,7 +409,7 @@ let invert_ltac_bound_name lvar env id0 id = str " which is not bound in current context.") let protected_get_type_of env sigma c = - try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c + try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma (EConstr.of_constr c) with Retyping.RetypeError _ -> user_err (str "Cannot reinterpret " ++ quote (print_constr c) ++ @@ -563,7 +563,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let hyps = evar_filtered_context (Evd.find !evdref evk) in let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in let c = mkEvar (evk, args) in - let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in + let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref (EConstr.of_constr c)) in inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> @@ -757,7 +757,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let sigma = !evdref in let c = mkApp (f,Array.map (whd_evar sigma) args) in let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in - let t = Retyping.get_type_of env.ExtraEnv.env !evdref c in + let t = Retyping.get_type_of env.ExtraEnv.env !evdref (EConstr.of_constr c) in make_judge c (* use this for keeping evars: resj.uj_val *) t else resj | _ -> resj @@ -1067,7 +1067,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | Some v -> let s = let sigma = !evdref in - let t = Retyping.get_type_of env.ExtraEnv.env sigma v in + let t = Retyping.get_type_of env.ExtraEnv.env sigma (EConstr.of_constr v) in match kind_of_term (whd_all env.ExtraEnv.env sigma (EConstr.of_constr t)) with | Sort s -> s | Evar ev when is_Type (existential_type sigma ev) -> diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 353bdbb899..2efb024176 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -49,12 +49,21 @@ let anomaly_on_error f x = try f x with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e) +let local_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + let get_type_from_constraints env sigma t = - if isEvar (fst (decompose_app t)) then + let open EConstr in + if isEvar sigma (EConstr.of_constr (fst (decompose_app_vect sigma t))) then match List.map_filter (fun (pbty,env,t1,t2) -> - if is_fconv Reduction.CONV env sigma (EConstr.of_constr t) (EConstr.of_constr t1) then Some t2 - else if is_fconv Reduction.CONV env sigma (EConstr.of_constr t) (EConstr.of_constr t2) then Some t1 + if is_fconv Reduction.CONV env sigma t (EConstr.of_constr t1) then Some t2 + else if is_fconv Reduction.CONV env sigma t (EConstr.of_constr t2) then Some t1 else None) (snd (Evd.extract_all_conv_pbs sigma)) with @@ -65,87 +74,89 @@ let get_type_from_constraints env sigma t = let rec subst_type env sigma typ = function | [] -> typ | h::rest -> - match kind_of_term (whd_all env sigma (EConstr.of_constr typ)) with - | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest + let open EConstr in + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma typ)) with + | Prod (na,c1,c2) -> subst_type env sigma (Vars.subst1 h c2) rest | _ -> retype_error NonFunctionalConstruction (* If ft is the type of f which itself is applied to args, *) (* [sort_of_atomic_type] computes ft[args] which has to be a sort *) let sort_of_atomic_type env sigma ft args = + let open EConstr in let rec concl_of_arity env n ar args = - match kind_of_term (whd_all env sigma (EConstr.of_constr ar)), args with - | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma ar)), args with + | Prod (na, t, b), h::l -> concl_of_arity (push_rel (local_def (na, Vars.lift n h, t)) env) (n + 1) b l | Sort s, [] -> s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) let type_of_var env id = - try NamedDecl.get_type (lookup_named id env) + try EConstr.of_constr (NamedDecl.get_type (lookup_named id env)) with Not_found -> retype_error (BadVariable id) let decomp_sort env sigma t = - match kind_of_term (whd_all env sigma t) with + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with | Sort s -> s | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = + let open EConstr in let rec type_of env cstr = - match kind_of_term cstr with + match EConstr.kind sigma cstr with | Meta n -> - (try strip_outer_cast sigma (EConstr.of_constr (Evd.meta_ftype sigma n).Evd.rebus) + EConstr.of_constr (try strip_outer_cast sigma (EConstr.of_constr (Evd.meta_ftype sigma n).Evd.rebus) with Not_found -> retype_error (BadMeta n)) | Rel n -> - let ty = RelDecl.get_type (lookup_rel n env) in - lift n ty + let ty = EConstr.of_constr (RelDecl.get_type (lookup_rel n env)) in + Vars.lift n ty | Var id -> type_of_var env id - | Const cst -> rename_type_of_constant env cst - | Evar ev -> Evd.existential_type sigma ev - | Ind ind -> rename_type_of_inductive env ind - | Construct cstr -> rename_type_of_constructor env cstr + | Const cst -> EConstr.of_constr (rename_type_of_constant env cst) + | Evar (evk, args) -> EConstr.of_constr (Evd.existential_type sigma (evk, Array.map EConstr.Unsafe.to_constr args)) + | Ind ind -> EConstr.of_constr (rename_type_of_inductive env ind) + | Construct cstr -> EConstr.of_constr (rename_type_of_constructor env cstr) | Case (_,p,c,lf) -> let Inductiveops.IndType(indf,realargs) = let t = type_of env c in - try Inductiveops.find_rectype env sigma (EConstr.of_constr t) + try Inductiveops.find_rectype env sigma t with Not_found -> try - let t = get_type_from_constraints env sigma t in - Inductiveops.find_rectype env sigma (EConstr.of_constr t) + let t = EConstr.of_constr (get_type_from_constraints env sigma t) in + Inductiveops.find_rectype env sigma t with Not_found -> retype_error BadRecursiveType in let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in - let t = betazetaevar_applist sigma n (EConstr.of_constr p) (List.map EConstr.of_constr realargs) in - (match kind_of_term (whd_all env sigma (EConstr.of_constr (type_of env t))) with - | Prod _ -> whd_beta sigma (EConstr.of_constr (applist (t, [c]))) + let t = EConstr.of_constr (betazetaevar_applist sigma n p (List.map EConstr.of_constr realargs)) in + (match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma (type_of env t))) with + | Prod _ -> EConstr.of_constr (whd_beta sigma (applist (t, [c]))) | _ -> t) | Lambda (name,c1,c2) -> - mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2) + mkProd (name, c1, type_of (push_rel (local_assum (name,c1)) env) c2) | LetIn (name,b,c1,c2) -> - subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2) + Vars.subst1 b (type_of (push_rel (local_def (name,b,c1)) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) - | App(f,args) when is_template_polymorphic env sigma (EConstr.of_constr f) -> - let f = whd_evar sigma f in + | App(f,args) when is_template_polymorphic env sigma f -> let t = type_of_global_reference_knowing_parameters env f args in - strip_outer_cast sigma (EConstr.of_constr (subst_type env sigma t (Array.to_list args))) + EConstr.of_constr (strip_outer_cast sigma (subst_type env sigma t (Array.to_list args))) | App(f,args) -> - strip_outer_cast sigma - (EConstr.of_constr (subst_type env sigma (type_of env f) (Array.to_list args))) + EConstr.of_constr (strip_outer_cast sigma + (subst_type env sigma (type_of env f) (Array.to_list args))) | Proj (p,c) -> let ty = type_of env c in - (try - Inductiveops.type_of_projection_knowing_arg env sigma p (EConstr.of_constr c) (EConstr.of_constr ty) + EConstr.of_constr (try + Inductiveops.type_of_projection_knowing_arg env sigma p c ty with Invalid_argument _ -> retype_error BadRecursiveType) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) and sort_of env t = - match kind_of_term t with - | Cast (c,_, s) when isSort s -> destSort s + match EConstr.kind sigma t with + | Cast (c,_, s) when isSort sigma s -> destSort sigma s | Sort (Prop c) -> type1_sort | Sort (Type u) -> Type (Univ.super u) | Prod (name,t,c2) -> - (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with + (match (sort_of env t, sort_of (push_rel (local_assum (name,t)) env) c2) with | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s @@ -153,47 +164,45 @@ let retype ?(polyprop=true) sigma = | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2) | Prop Null, (Type _ as s) -> s | Type u1, Type u2 -> Type (Univ.sup u1 u2)) - | App(f,args) when is_template_polymorphic env sigma (EConstr.of_constr f) -> - let f = whd_evar sigma f in + | App(f,args) when is_template_polymorphic env sigma f -> let t = type_of_global_reference_knowing_parameters env f args in sort_of_atomic_type env sigma t args | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | Lambda _ | Fix _ | Construct _ -> retype_error NotAType - | _ -> decomp_sort env sigma (EConstr.of_constr (type_of env t)) + | _ -> decomp_sort env sigma (type_of env t) and sort_family_of env t = - match kind_of_term t with - | Cast (c,_, s) when isSort s -> family_of_sort (destSort s) + match EConstr.kind sigma t with + | Cast (c,_, s) when isSort sigma s -> family_of_sort (destSort sigma s) | Sort (Prop c) -> InType | Sort (Type u) -> InType | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in + let s2 = sort_family_of (push_rel (local_assum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 - | App(f,args) when is_template_polymorphic env sigma (EConstr.of_constr f) -> - let f = whd_evar sigma f in + | App(f,args) when is_template_polymorphic env sigma f -> let t = type_of_global_reference_knowing_parameters env f args in family_of_sort (sort_of_atomic_type env sigma t args) | App(f,args) -> family_of_sort (sort_of_atomic_type env sigma (type_of env f) args) | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> - family_of_sort (decomp_sort env sigma (EConstr.of_constr (type_of env t))) + family_of_sort (decomp_sort env sigma (type_of env t)) and type_of_global_reference_knowing_parameters env c args = let argtyps = - Array.map (fun c -> lazy (nf_evar sigma (type_of env c))) args in - match kind_of_term c with + Array.map (fun c -> lazy (EConstr.to_constr sigma (type_of env c))) args in + match EConstr.kind sigma c with | Ind ind -> let mip = lookup_mind_specif env (fst ind) in - (try Inductive.type_of_inductive_knowing_parameters + EConstr.of_constr (try Inductive.type_of_inductive_knowing_parameters ~polyprop env (mip,snd ind) argtyps with Reduction.NotArity -> retype_error NotAnArity) | Const cst -> - (try Typeops.type_of_constant_knowing_parameters_in env cst argtyps + EConstr.of_constr (try Typeops.type_of_constant_knowing_parameters_in env cst argtyps with Reduction.NotArity -> retype_error NotAnArity) | Var id -> type_of_var env id - | Construct cstr -> type_of_constructor env cstr + | Construct cstr -> EConstr.of_constr (type_of_constructor env cstr) | _ -> assert false in type_of, sort_of, sort_family_of, @@ -204,19 +213,19 @@ let get_sort_of ?(polyprop=true) env sigma t = let get_sort_family_of ?(polyprop=true) env sigma c = let _,_,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) c let type_of_global_reference_knowing_parameters env sigma c args = - let _,_,_,f = retype sigma in anomaly_on_error (f env c) args + let _,_,_,f = retype sigma in EConstr.Unsafe.to_constr (anomaly_on_error (f env c) args) let type_of_global_reference_knowing_conclusion env sigma c conclty = - match kind_of_term c with + match EConstr.kind sigma c with | Ind (ind,u) -> let spec = Inductive.lookup_mind_specif env ind in - type_of_inductive_knowing_conclusion env sigma (spec,u) (EConstr.of_constr conclty) + type_of_inductive_knowing_conclusion env sigma (spec,u) conclty | Const cst -> let t = constant_type_in env cst in (* TODO *) - sigma, Typeops.type_of_constant_type_knowing_parameters env t [||] + sigma, EConstr.of_constr (Typeops.type_of_constant_type_knowing_parameters env t [||]) | Var id -> sigma, type_of_var env id - | Construct cstr -> sigma, type_of_constructor env cstr + | Construct cstr -> sigma, EConstr.of_constr (type_of_constructor env cstr) | _ -> assert false (* Profiling *) @@ -232,10 +241,10 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_,_ = retype ~polyprop sigma in - if lax then f env c else anomaly_on_error (f env) c + if lax then EConstr.Unsafe.to_constr (f env c) else EConstr.Unsafe.to_constr (anomaly_on_error (f env) c) (* Makes an unsafe judgment from a constr *) -let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } +let get_judgment_of env evc c = { uj_val = EConstr.Unsafe.to_constr c; uj_type = get_type_of env evc c } (* Returns sorts of a context *) let sorts_of_context env evc ctxt = @@ -243,15 +252,16 @@ let sorts_of_context env evc ctxt = | [] -> env,[] | d :: ctxt -> let env,sorts = aux ctxt in - let s = get_sort_of env evc (RelDecl.get_type d) in + let s = get_sort_of env evc (EConstr.of_constr (RelDecl.get_type d)) in (push_rel d env,s::sorts) in snd (aux ctxt) let expand_projection env sigma pr c args = + let inj = EConstr.Unsafe.to_constr in let ty = get_type_of ~lax:true env sigma c in let (i,u), ind_args = try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with Not_found -> retype_error BadRecursiveType in mkApp (mkConstU (Projection.constant pr,u), - Array.of_list (ind_args @ (c :: args))) + Array.of_list (ind_args @ (inj c :: List.map inj args))) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 8ca40f829f..08f7502878 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -26,25 +26,25 @@ type retype_error exception RetypeError of retype_error val get_type_of : - ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> EConstr.constr -> types val get_sort_of : - ?polyprop:bool -> env -> evar_map -> types -> sorts + ?polyprop:bool -> env -> evar_map -> EConstr.types -> sorts val get_sort_family_of : - ?polyprop:bool -> env -> evar_map -> types -> sorts_family + ?polyprop:bool -> env -> evar_map -> EConstr.types -> sorts_family (** Makes an unsafe judgment from a constr *) -val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment +val get_judgment_of : env -> evar_map -> EConstr.constr -> unsafe_judgment -val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> - constr array -> types +val type_of_global_reference_knowing_parameters : env -> evar_map -> EConstr.constr -> + EConstr.constr array -> types val type_of_global_reference_knowing_conclusion : - env -> evar_map -> constr -> types -> evar_map * types + env -> evar_map -> EConstr.constr -> EConstr.types -> evar_map * EConstr.types val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list -val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr +val expand_projection : env -> evar_map -> Names.projection -> EConstr.constr -> EConstr.constr list -> constr val print_retype_error : retype_error -> Pp.std_ppcmds diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 357a80f441..ac2a3bc490 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -974,7 +974,7 @@ let matches_head env sigma c t = let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = match kind_of_term c with | Proj (p, r) -> (* Treat specially for partial applications *) - let t = Retyping.expand_projection env sigma p r [] in + let t = Retyping.expand_projection env sigma p (EConstr.of_constr r) [] in let hdf, al = destApp t in let a = al.(Array.length al - 1) in let app = (mkApp (hdf, Array.sub al 0 (Array.length al - 1))) in @@ -1150,7 +1150,7 @@ let compute = cbv_betadeltaiota * the specified occurrences. *) let abstract_scheme env (locc,a) (c, sigma) = - let ta = Retyping.get_type_of env sigma a in + let ta = Retyping.get_type_of env sigma (EConstr.of_constr a) in let na = named_hd env ta Anonymous in if occur_meta sigma (EConstr.of_constr ta) then error "Cannot find a type for the generalisation."; if occur_meta sigma (EConstr.of_constr a) then diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 50dd66ea0a..8c03329e24 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -300,7 +300,7 @@ let build_subclasses ~check env sigma glob pri = | Some (Forward, pri') -> let proj = Option.get proj in let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in - if check && check_instance env sigma body then None + if check && check_instance env sigma (EConstr.of_constr body) then None else let pri = match pri, pri' with @@ -312,7 +312,7 @@ let build_subclasses ~check env sigma glob pri = in let declare_proj hints (cref, pri, body) = let path' = cref :: path in - let ty = Retyping.get_type_of env sigma body in + let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in let rest = aux pri body ty path' in hints @ (path', pri, body) :: rest in List.fold_left declare_proj [] projs diff --git a/pretyping/typing.ml b/pretyping/typing.ml index e3d1c17413..acfe05f24d 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -138,7 +138,7 @@ let check_type_fixpoint loc env evdref lna lar vdefj = (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = - let pj = Retyping.get_judgment_of env sigma p in + let pj = Retyping.get_judgment_of env sigma (EConstr.of_constr p) in let ksort = family_of_sort (sort_of_arity env sigma (EConstr.of_constr pj.uj_type)) in let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ede2606daf..848a2f4a8a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -684,7 +684,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb if opt.with_types && flags.check_applied_meta_types then (try let tyM = Typing.meta_type sigma k in - let tyN = get_type_of curenv ~lax:true sigma cN in + let tyN = get_type_of curenv ~lax:true sigma (EConstr.of_constr cN) in check_compatibility curenv CUMUL flags substn tyN tyM with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma) @@ -703,7 +703,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb let sigma = if opt.with_types && flags.check_applied_meta_types then (try - let tyM = get_type_of curenv ~lax:true sigma cM in + let tyM = get_type_of curenv ~lax:true sigma (EConstr.of_constr cM) in let tyN = Typing.meta_type sigma k in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> @@ -863,7 +863,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb let expand_proj c c' l = match kind_of_term c with | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> - (try destApp (Retyping.expand_projection curenv sigma p t (Array.to_list l)) + (try destApp (Retyping.expand_projection curenv sigma p (EConstr.of_constr t) (Array.map_to_list EConstr.of_constr l)) with RetypeError _ -> (** Unification can be called on ill-typed terms, due to FO and eta in particular, fail gracefully in that case *) (c, l)) @@ -888,8 +888,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb and unify_same_proj (curenv, nb as curenvnb) cv_pb opt substn c1 c2 = let substn = unirec_rec curenvnb CONV opt substn c1 c2 in try (* Force unification of the types to fill in parameters *) - let ty1 = get_type_of curenv ~lax:true sigma c1 in - let ty2 = get_type_of curenv ~lax:true sigma c2 in + let ty1 = get_type_of curenv ~lax:true sigma (EConstr.of_constr c1) in + let ty2 = get_type_of curenv ~lax:true sigma (EConstr.of_constr c2) in unify_0_with_initial_metas substn true curenv cv_pb { flags with modulo_conv_on_closed_terms = Some full_transparent_state; modulo_delta = full_transparent_state; @@ -953,8 +953,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb let sigma = if opt.with_types then try (* Ensure we call conversion on terms of the same type *) - let tyM = get_type_of curenv ~lax:true sigma m1 in - let tyN = get_type_of curenv ~lax:true sigma n1 in + let tyM = get_type_of curenv ~lax:true sigma (EConstr.of_constr m1) in + let tyN = get_type_of curenv ~lax:true sigma (EConstr.of_constr n1) in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma @@ -1240,13 +1240,13 @@ let w_coerce_to_type env evd c cty mvty = try_to_coerce env evd c cty tycon let w_coerce env evd mv c = - let cty = get_type_of env evd c in + let cty = get_type_of env evd (EConstr.of_constr c) in let mvty = Typing.meta_type evd mv in w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = let sigma, c = refresh_universes (Some false) env sigma c in - let t = get_type_of env sigma (nf_meta sigma c) in + let t = get_type_of env sigma (EConstr.of_constr (nf_meta sigma c)) in let t = nf_betaiota sigma (EConstr.of_constr (nf_meta sigma t)) in unify_0 env sigma CUMUL flags t u @@ -1379,7 +1379,7 @@ let w_merge env with_types flags (evd,metas,evars) = let evd' = Sigma.to_evar_map evd' in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags - (get_type_of sp_env evd' c) ev.evar_concl in + (get_type_of sp_env evd' (EConstr.of_constr c)) ev.evar_concl in let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' then Evd.define sp c evd''' @@ -1422,13 +1422,13 @@ let check_types env flags (sigma,_,_ as subst) m n = if isEvar_or_Meta (head_app sigma m) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma n) - (get_type_of env sigma m) + (get_type_of env sigma (EConstr.of_constr n)) + (get_type_of env sigma (EConstr.of_constr m)) else if isEvar_or_Meta (head_app sigma n) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma m) - (get_type_of env sigma n) + (get_type_of env sigma (EConstr.of_constr m)) + (get_type_of env sigma (EConstr.of_constr n)) else subst let try_resolve_typeclasses env evd flag m n = @@ -1557,7 +1557,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = applist (t,l1), l2 else t, [] in let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in - let ty = Retyping.get_type_of env sigma t in + let ty = Retyping.get_type_of env sigma (EConstr.of_constr t) in if not (is_correct_type ty) then raise (NotUnifiable None); Some(sigma, t, l2) with @@ -1590,7 +1590,7 @@ let make_eq_test env evd c = let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let id = - let t = match ty with Some t -> t | None -> get_type_of env sigma c in + let t = match ty with Some t -> t | None -> get_type_of env sigma (EConstr.of_constr c) in let x = id_of_name_using_hdchar (Global.env()) t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else -- cgit v1.2.3 From 214a2ffd2cce3fa24908710af7db528a40345db6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Nov 2016 18:24:20 +0100 Subject: Cbv API using EConstr. --- pretyping/cbv.ml | 1 + pretyping/cbv.mli | 2 +- pretyping/tacred.ml | 2 +- 3 files changed, 3 insertions(+), 2 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 84bf849e76..a42061f283 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -376,6 +376,7 @@ and cbv_norm_value info = function (* reduction under binders *) (* with profiling *) let cbv_norm infos constr = + let constr = EConstr.Unsafe.to_constr constr in with_stats (lazy (cbv_norm_term infos (subs_id 0) constr)) type cbv_infos = cbv_value infos diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 87a03abbd9..3d17457679 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -19,7 +19,7 @@ open Esubst type cbv_infos val create_cbv_infos : RedFlags.reds -> env -> Evd.evar_map -> cbv_infos -val cbv_norm : cbv_infos -> constr -> constr +val cbv_norm : cbv_infos -> EConstr.constr -> constr (*********************************************************************** i This is for cbv debug *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index ac2a3bc490..c1e9573d27 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1136,7 +1136,7 @@ let fold_commands cl env sigma c = (* call by value reduction functions *) let cbv_norm_flags flags env sigma t = - cbv_norm (create_cbv_infos flags env sigma) (EConstr.Unsafe.to_constr t) + cbv_norm (create_cbv_infos flags env sigma) t let cbv_beta = cbv_norm_flags beta empty_env let cbv_betaiota = cbv_norm_flags betaiota empty_env -- cgit v1.2.3 From 83607f75a13ea915affa8cfc5bfc14cc944c61ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Nov 2016 18:45:55 +0100 Subject: Find_subterm API using EConstr. --- pretyping/find_subterm.ml | 25 +++++++++++++++---------- pretyping/find_subterm.mli | 12 ++++++------ pretyping/pretype_errors.ml | 2 +- pretyping/pretype_errors.mli | 2 +- pretyping/tacred.ml | 7 ++++--- pretyping/unification.ml | 23 ++++++++++++----------- 6 files changed, 39 insertions(+), 32 deletions(-) (limited to 'pretyping') diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 4b9cf415f0..d7f2d54aa2 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -11,7 +11,7 @@ open Util open CErrors open Names open Locus -open Term +open EConstr open Nameops open Termops open Pretype_errors @@ -63,7 +63,10 @@ let proceed_with_occurrences f occs x = let map_named_declaration_with_hyploc f hyploc acc decl = let open Context.Named.Declaration in - let f = f (Some (NamedDecl.get_id decl, hyploc)) in + let f acc typ = + let acc, typ = f (Some (NamedDecl.get_id decl, hyploc)) acc (EConstr.of_constr typ) in + acc, EConstr.Unsafe.to_constr typ + in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> error_occurrences_error (IncorrectInValueOccurrence id) @@ -82,10 +85,10 @@ let map_named_declaration_with_hyploc f hyploc acc decl = exception SubtermUnificationError of subterm_unification_error -exception NotUnifiable of (constr * constr * unification_error) option +exception NotUnifiable of (Constr.t * Constr.t * unification_error) option type 'a testing_function = { - match_fun : 'a -> constr -> 'a; + match_fun : 'a -> EConstr.constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : position_reporting option @@ -130,7 +133,8 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = with NotUnifiable _ -> subst_below k t and subst_below k t = - map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k t + let substrec i c = EConstr.Unsafe.to_constr (substrec i (EConstr.of_constr c)) in + EConstr.of_constr (map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k (EConstr.Unsafe.to_constr t)) in let t' = substrec 0 t in (!pos, t') @@ -138,8 +142,8 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = let replace_term_occ_modulo occs test bywhat t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in - proceed_with_occurrences - (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t + EConstr.Unsafe.to_constr (proceed_with_occurrences + (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t) let replace_term_occ_decl_modulo occs test bywhat d = let (plocs,hyploc),like_first = @@ -154,11 +158,12 @@ let replace_term_occ_decl_modulo occs test bywhat d = let make_eq_univs_test env evd c = { match_fun = (fun evd c' -> - let b, cst = Universes.eq_constr_universes_proj env c c' in - if b then + match EConstr.eq_constr_universes_proj env evd c c' with + | None -> raise (NotUnifiable None) + | Some cst -> try Evd.add_universe_constraints evd cst with Evd.UniversesDiffer -> raise (NotUnifiable None) - else raise (NotUnifiable None)); + ); merge_fun = (fun evd _ -> evd); testing_state = evd; last_found = None diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index c741ab048d..49a5dd7f26 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -26,7 +26,7 @@ exception SubtermUnificationError of subterm_unification_error with None. *) type 'a testing_function = { - match_fun : 'a -> constr -> 'a; + match_fun : 'a -> EConstr.constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : position_reporting option @@ -34,7 +34,7 @@ type 'a testing_function = { (** This is the basic testing function, looking for exact matches of a closed term *) -val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function +val make_eq_univs_test : env -> evar_map -> EConstr.constr -> evar_map testing_function (** [replace_term_occ_modulo occl test mk c] looks in [c] for subterm modulo a testing function [test] and replaces successfully @@ -42,26 +42,26 @@ val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) val replace_term_occ_modulo : occurrences or_like_first -> - 'a testing_function -> (unit -> constr) -> constr -> constr + 'a testing_function -> (unit -> EConstr.constr) -> EConstr.constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : (occurrences * hyp_location_flag) or_like_first -> - 'a testing_function -> (unit -> constr) -> + 'a testing_function -> (unit -> EConstr.constr) -> Context.Named.Declaration.t -> Context.Named.Declaration.t (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), unifying universes which results in a set of constraints. *) val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> - constr -> constr -> constr * evar_map + EConstr.constr -> EConstr.constr -> constr * evar_map (** [subst_closed_term_occ_decl evd occl c decl] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [decl]. *) val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> - constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map + EConstr.constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map (** Miscellaneous *) val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 5b09586950..f8f6d44bfe 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -27,7 +27,7 @@ type unification_error = type position = (Id.t * Locus.hyp_location_flag) option -type position_reporting = (position * int) * constr +type position_reporting = (position * int) * EConstr.t type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 73f81923ff..b015add799 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -28,7 +28,7 @@ type unification_error = type position = (Id.t * Locus.hyp_location_flag) option -type position_reporting = (position * int) * constr +type position_reporting = (position * int) * EConstr.t type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index c1e9573d27..290d77b1b3 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1150,13 +1150,14 @@ let compute = cbv_betadeltaiota * the specified occurrences. *) let abstract_scheme env (locc,a) (c, sigma) = - let ta = Retyping.get_type_of env sigma (EConstr.of_constr a) in + let a = EConstr.of_constr a in + let ta = Retyping.get_type_of env sigma a in let na = named_hd env ta Anonymous in if occur_meta sigma (EConstr.of_constr ta) then error "Cannot find a type for the generalisation."; - if occur_meta sigma (EConstr.of_constr a) then + if occur_meta sigma a then mkLambda (na,ta,c), sigma else - let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in + let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a (EConstr.of_constr c) in mkLambda (na,ta,c'), sigma' let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 848a2f4a8a..8865e69ef5 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -89,7 +89,7 @@ let abstract_scheme env evd c l lname_typ = else *) if occur_meta evd (EConstr.of_constr a) then mkLambda_name env (na,ta,t), evd else - let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in + let t', evd' = Find_subterm.subst_closed_term_occ env evd locc (EConstr.of_constr a) (EConstr.of_constr t) in mkLambda_name env (na,ta,t'), evd') (c,evd) (List.rev l) @@ -1544,20 +1544,21 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = else default_matching_flags pending in let n = List.length (snd (decompose_app c)) in let matching_fun _ t = + let open EConstr in try let t',l2 = if from_prefix_of_ind then (* We check for fully applied subterms of the form "u u1 .. un" *) (* of inductive type knowing only a prefix "u u1 .. ui" *) - let t,l = decompose_app t in + let t,l = decompose_app sigma t in let l1,l2 = try List.chop n l with Failure _ -> raise (NotUnifiable None) in - if not (List.for_all closed0 l2) then raise (NotUnifiable None) + if not (List.for_all (fun c -> Vars.closed0 sigma c) l2) then raise (NotUnifiable None) else applist (t,l1), l2 else t, [] in - let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in - let ty = Retyping.get_type_of env sigma (EConstr.of_constr t) in + let sigma = w_typed_unify env sigma Reduction.CONV flags c (EConstr.Unsafe.to_constr t') in + let ty = Retyping.get_type_of env sigma t in if not (is_correct_type ty) then raise (NotUnifiable None); Some(sigma, t, l2) with @@ -1568,7 +1569,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = let merge_fun c1 c2 = match c1, c2 with | Some (evd,c1,x), Some (_,c2,_) -> - let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in + let (evd,b) = infer_conv ~pb:CONV env evd (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) in if b then Some (evd, c1, x) else raise (NotUnifiable None) | Some _, None -> c1 | None, Some _ -> c2 @@ -1578,13 +1579,13 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = (fun test -> match test.testing_state with | None -> None | Some (sigma,_,l) -> - let c = applist (nf_evar sigma (local_strong whd_meta sigma (EConstr.of_constr c)),l) in + let c = applist (nf_evar sigma (local_strong whd_meta sigma (EConstr.of_constr c)), List.map (EConstr.to_constr sigma) l) in let univs, subst = nf_univ_variables sigma in Some (sigma,subst_univs_constr subst c)) let make_eq_test env evd c = let out cstr = - match cstr.last_found with None -> None | _ -> Some (cstr.testing_state, c) + match cstr.last_found with None -> None | _ -> Some (cstr.testing_state, EConstr.Unsafe.to_constr c) in (make_eq_univs_test env evd c, out) @@ -1601,7 +1602,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = x in let likefirst = clause_with_generic_occurrences occs in - let mkvarid () = mkVar id in + let mkvarid () = EConstr.mkVar id in let compute_dependency _ d (sign,depdecls) = let hyp = NamedDecl.get_id d in match occurrences_of_hyp hyp occs with @@ -1630,7 +1631,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo occ test mkvarid concl + replace_term_occ_modulo occ test mkvarid (EConstr.of_constr concl) in let lastlhyp = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in @@ -1674,7 +1675,7 @@ let make_abstraction env evd ccl abs = env evd (snd c) None occs check_occs ccl | AbstractExact (name,c,ty,occs,check_occs) -> make_abstraction_core name - (make_eq_test env evd c) + (make_eq_test env evd (EConstr.of_constr c)) env evd c ty occs check_occs ccl let keyed_unify env evd kop = -- cgit v1.2.3 From 147afe827dc83602cc160a8b1357e84ecea910ff Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Nov 2016 20:13:32 +0100 Subject: Evardefine API using EConstr. --- pretyping/cases.ml | 8 +++--- pretyping/coercion.ml | 11 ++++---- pretyping/evarconv.ml | 2 +- pretyping/evardefine.ml | 65 ++++++++++++++++++++++++-------------------- pretyping/evardefine.mli | 12 ++++---- pretyping/pretype_errors.ml | 4 +-- pretyping/pretype_errors.mli | 8 +++--- pretyping/pretyping.ml | 20 +++++++------- pretyping/typing.ml | 21 +++++++------- pretyping/unification.ml | 11 ++++---- 10 files changed, 86 insertions(+), 76 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 4dd5021060..915cd261d7 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -336,7 +336,7 @@ let unify_tomatch_with_patterns evdref env loc typ pats realnames = let find_tomatch_tycon evdref env loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) | Some (_,ind,realnal) -> - mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal) + mk_tycon (EConstr.of_constr (inductive_template evdref env loc ind)),Some (List.rev realnal) | None -> empty_tycon,None @@ -1211,7 +1211,7 @@ let rec generalize_problem names pb = function (* No more patterns: typing the right-hand side of equations *) let build_leaf pb = let rhs = extract_rhs pb in - let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in + let j = pb.typing_function (mk_tycon (EConstr.of_constr pb.pred)) rhs.rhs_env pb.evdref rhs.it in j_nf_evar !(pb.evdref) j (* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *) @@ -1972,7 +1972,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let envar = List.fold_right push_rel_context arsign env in let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in - let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in + let predcclj = typing_fun (mk_tycon (EConstr.mkSort newt)) envar evdref rtntyp in let sigma = !evdref in let predccl = (j_nf_evar sigma predcclj).uj_val in [sigma, predccl] @@ -2238,7 +2238,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = eqs_rels @ neqs_rels @ rhs_rels', arity in let rhs_env = push_rel_context rhs_rels' env in - let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in + let j = typing_fun (mk_tycon (EConstr.of_constr tycon)) rhs_env eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let _btype = evd_comb1 (Typing.type_of env) evdref bbody in diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 6a7f904632..c5418d22e7 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -244,8 +244,9 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) match kind_of_term c with | Lambda (n, t, t') -> c, t' | Evar (k, args) -> - let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in + let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k, Array.map EConstr.of_constr args) in evdref := evs; + let t = EConstr.Unsafe.to_constr t in let (n, dom, rng) = destLambda t in let dom = whd_evar !evdref dom in if isEvar dom then @@ -374,11 +375,11 @@ let apply_coercion env sigma p hj typ_cl = (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core env evd j = let t = whd_all env evd (EConstr.of_constr j.uj_type) in - match kind_of_term t with + match EConstr.kind evd (EConstr.of_constr t) with | Prod (_,_,_) -> (evd,j) | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product evd ev in - (evd',{ uj_val = j.uj_val; uj_type = t }) + (evd',{ uj_val = j.uj_val; uj_type = EConstr.Unsafe.to_constr t }) | _ -> try let t,p = lookup_path_to_fun_from env evd j.uj_type in @@ -415,9 +416,9 @@ let inh_tosort_force loc env evd j = let inh_coerce_to_sort loc env evd j = let typ = whd_all env evd (EConstr.of_constr j.uj_type) in - match kind_of_term typ with + match EConstr.kind evd (EConstr.of_constr typ) with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) - | Evar ev when not (is_defined evd (fst ev)) -> + | Evar ev -> let (evd',s) = Evardefine.define_evar_as_sort env evd ev in (evd',{ utj_val = j.uj_val; utj_type = s }) | _ -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 47db71cc65..4540af28b9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -503,7 +503,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let i,tF = if isRel tR || isVar tR then (* Optimization so as to generate candidates *) - let i,ev = evar_absorb_arguments env i ev (List.map EConstr.Unsafe.to_constr lF) in + let i,ev = evar_absorb_arguments env i (fst ev, Array.map EConstr.of_constr (snd ev)) lF in i,mkEvar ev else i,zip evd apprF in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 3982edd1c4..8026ff3e4f 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -61,13 +61,13 @@ type val_constraint = constr option let empty_tycon = None (* Builds a type constraint *) -let mk_tycon ty = Some ty +let mk_tycon ty = Some (EConstr.Unsafe.to_constr ty) (* Constrains the value of a type *) let empty_valcon = None (* Builds a value constraint *) -let mk_valcon c = Some c +let mk_valcon c = Some (EConstr.Unsafe.to_constr c) let idx = Namegen.default_dependent_ident @@ -75,11 +75,12 @@ let idx = Namegen.default_dependent_ident let define_pure_evar_as_product evd evk = let open Context.Named.Declaration in + let open EConstr in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in - let s = destSort concl in + let s = destSort evd (EConstr.of_constr concl) in let evd1,(dom,u1) = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in @@ -103,20 +104,21 @@ let define_pure_evar_as_product evd evk = let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in evd3, rng in - let prod = mkProd (Name id, dom, subst_var id rng) in - let evd3 = Evd.define evk prod evd2 in + let prod = mkProd (Name id, EConstr.of_constr dom, EConstr.of_constr (subst_var id rng)) in + let evd3 = Evd.define evk (EConstr.Unsafe.to_constr prod) evd2 in evd3,prod (* Refine an applied evar to a product and returns its instantiation *) let define_evar_as_product evd (evk,args) = + let open EConstr in let evd,prod = define_pure_evar_as_product evd evk in (* Quick way to compute the instantiation of evk with args *) - let na,dom,rng = destProd prod in - let evdom = mkEvar (fst (destEvar dom), args) in - let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in - let evrng = mkEvar (fst (destEvar rng), evrngargs) in - evd,mkProd (na, evdom, evrng) + let na,dom,rng = destProd evd prod in + let evdom = mkEvar (fst (destEvar evd dom), args) in + let evrngargs = Array.cons (mkRel 1) (Array.map (Vars.lift 1) args) in + let evrng = mkEvar (fst (destEvar evd rng), evrngargs) in + evd, mkProd (na, evdom, evrng) (* Refine an evar with an abstraction @@ -129,38 +131,42 @@ let define_evar_as_product evd (evk,args) = let define_pure_evar_as_lambda env evd evk = let open Context.Named.Declaration in + let open EConstr in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in - let typ = Reductionops.whd_all evenv evd (EConstr.of_constr (evar_concl evi)) in - let evd1,(na,dom,rng) = match kind_of_term typ with + let typ = EConstr.of_constr (Reductionops.whd_all evenv evd (EConstr.of_constr (evar_concl evi))) in + let evd1,(na,dom,rng) = match EConstr.kind evd typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) - | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd typ + | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd evd typ | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in + let dom = EConstr.Unsafe.to_constr dom in let id = next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in - let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in - let lam = mkLambda (Name id, dom, subst_var id body) in - Evd.define evk lam evd2, lam + let evd2,body = new_evar_unsafe newenv evd1 ~src (EConstr.Unsafe.to_constr (Vars.subst1 (mkVar id) rng)) ~filter in + let lam = mkLambda (Name id, EConstr.of_constr dom, Vars.subst_var id (EConstr.of_constr body)) in + Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam let define_evar_as_lambda env evd (evk,args) = + let open EConstr in let evd,lam = define_pure_evar_as_lambda env evd evk in (* Quick way to compute the instantiation of evk with args *) - let na,dom,body = destLambda lam in - let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in - let evbody = mkEvar (fst (destEvar body), evbodyargs) in - evd,mkLambda (na, dom, evbody) + let na,dom,body = destLambda evd lam in + let evbodyargs = Array.cons (mkRel 1) (Array.map (Vars.lift 1) args) in + let evbody = mkEvar (fst (destEvar evd body), evbodyargs) in + evd, mkLambda (na, dom, evbody) let rec evar_absorb_arguments env evd (evk,args as ev) = function - | [] -> evd,ev + | [] -> evd, (evk, Array.map EConstr.Unsafe.to_constr args) | a::l -> + let open EConstr in (* TODO: optimize and avoid introducing intermediate evars *) let evd,lam = define_pure_evar_as_lambda env evd evk in - let _,_,body = destLambda lam in - let evk = fst (destEvar body) in + let _,_,body = destLambda evd lam in + let evk = fst (destEvar evd body) in evar_absorb_arguments env evd (evk, Array.cons a args) l (* Refining an evar to a sort *) @@ -180,23 +186,24 @@ let define_evar_as_sort env evd (ev,args) = an evar instantiate it with the product of 2 new evars. *) let split_tycon loc env evd tycon = + let open EConstr in let rec real_split evd c = - let t = Reductionops.whd_all env evd (EConstr.of_constr c) in - match kind_of_term t with + let t = Reductionops.whd_all env evd c in + match EConstr.kind evd (EConstr.of_constr t) with | Prod (na,dom,rng) -> evd, (na, dom, rng) | Evar ev (* ev is undefined because of whd_all *) -> let (evd',prod) = define_evar_as_product evd ev in - let (_,dom,rng) = destProd prod in + let (_,dom,rng) = destProd evd prod in evd',(Anonymous, dom, rng) - | App (c,args) when isEvar c -> - let (evd',lam) = define_evar_as_lambda env evd (destEvar c) in + | App (c,args) when isEvar evd c -> + let (evd',lam) = define_evar_as_lambda env evd (destEvar evd c) in real_split evd' (mkApp (lam,args)) | _ -> error_not_product ~loc env evd c in match tycon with | None -> evd,(Anonymous,None,None) | Some c -> - let evd', (n, dom, rng) = real_split evd c in + let evd', (n, dom, rng) = real_split evd (EConstr.of_constr c) in evd', (n, mk_tycon dom, mk_tycon rng) let valcon_of_tycon x = x diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index 07b0e69d9f..f6d0efba62 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -18,15 +18,15 @@ type type_constraint = types option type val_constraint = constr option val empty_tycon : type_constraint -val mk_tycon : constr -> type_constraint +val mk_tycon : EConstr.constr -> type_constraint val empty_valcon : val_constraint -val mk_valcon : constr -> val_constraint +val mk_valcon : EConstr.constr -> val_constraint (** Instantiate an evar by as many lambda's as needed so that its arguments are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into [?y[vars1:=args1,vars:=args]] with [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) -val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> +val evar_absorb_arguments : env -> evar_map -> EConstr.existential -> EConstr.constr list -> evar_map * existential val split_tycon : @@ -36,9 +36,9 @@ val split_tycon : val valcon_of_tycon : type_constraint -> val_constraint val lift_tycon : int -> type_constraint -> type_constraint -val define_evar_as_product : evar_map -> existential -> evar_map * types -val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types -val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts +val define_evar_as_product : evar_map -> EConstr.existential -> evar_map * EConstr.types +val define_evar_as_lambda : env -> evar_map -> EConstr.existential -> evar_map * EConstr.types +val define_evar_as_sort : env -> evar_map -> EConstr.existential -> evar_map * sorts (** {6 debug pretty-printer:} *) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index f8f6d44bfe..f28fb84ba1 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -44,14 +44,14 @@ type pretype_error = | CannotUnifyBindingType of constr * constr | CannotGeneralize of constr | NoOccurrenceFound of constr * Id.t option - | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option + | CannotFindWellTypedAbstraction of constr * EConstr.constr list * (env * type_error) option | WrongAbstractionType of Name.t * constr * types * types | AbstractionOverMeta of Name.t * Name.t | NonLinearUnification of Name.t * constr (* Pretyping *) | VarNotFound of Id.t | UnexpectedType of constr * constr - | NotProduct of constr + | NotProduct of EConstr.constr | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index b015add799..8a6d8b6b37 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -45,14 +45,14 @@ type pretype_error = | CannotUnifyBindingType of constr * constr | CannotGeneralize of constr | NoOccurrenceFound of constr * Id.t option - | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option + | CannotFindWellTypedAbstraction of constr * EConstr.constr list * (env * type_error) option | WrongAbstractionType of Name.t * constr * types * types | AbstractionOverMeta of Name.t * Name.t | NonLinearUnification of Name.t * constr (** Pretyping *) | VarNotFound of Id.t | UnexpectedType of constr * constr - | NotProduct of constr + | NotProduct of EConstr.constr | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of @@ -110,7 +110,7 @@ val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> - constr -> constr list -> (env * type_error) option -> 'b + constr -> EConstr.constr list -> (env * type_error) option -> 'b val error_wrong_abstraction_type : env -> Evd.evar_map -> Name.t -> constr -> types -> types -> 'b @@ -132,7 +132,7 @@ val error_unexpected_type : ?loc:Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b val error_not_product : - ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.constr -> 'b (** {6 Error in conversion from AST to glob_constr } *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 3c48c42df2..b689bb7c7f 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -606,7 +606,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in - let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in + let bd' = pretype (mk_tycon (EConstr.of_constr ty'.utj_val)) env evdref lvar bd in let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in @@ -640,7 +640,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre decompose_prod_n_assum (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon ty) nenv evdref lvar def in + let j = pretype (mk_tycon (EConstr.of_constr ty)) nenv evdref lvar def in { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in @@ -815,7 +815,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match c1 with | GCast (loc, c, CastConv t) -> let tj = pretype_type empty_valcon env evdref lvar t in - pretype (mk_tycon tj.utj_val) env evdref lvar c + pretype (mk_tycon (EConstr.of_constr tj.utj_val)) env evdref lvar c | _ -> pretype empty_tycon env evdref lvar c1 in let t = evd_comb1 (Evarsolve.refresh_universes @@ -895,7 +895,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre @[build_dependent_constructor cs] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist env.ExtraEnv.env !evdref (EConstr.of_constr lp) (List.map EConstr.of_constr inst) in - let fj = pretype (mk_tycon fty) env_f evdref lvar d in + let fj = pretype (mk_tycon (EConstr.of_constr fty)) env_f evdref lvar d in let v = let ind,_ = dest_ind_family indf in Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; @@ -973,7 +973,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre cs.cs_args in let env_c = push_rel_context csgn env in - let bj = pretype (mk_tycon pi) env_c evdref lvar b in + let bj = pretype (mk_tycon (EConstr.of_constr pi)) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs.cs_args in let b1 = f cstrs.(0) b1 in let b2 = f cstrs.(1) b2 in @@ -1028,7 +1028,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (ConversionFailed (env.ExtraEnv.env,cty,tval)) end | _ -> - pretype (mk_tycon tval) env evdref lvar c, tval + pretype (mk_tycon (EConstr.of_constr tval)) env evdref lvar c, tval in let v = mkCast (cj.uj_val, k, tval) in { uj_val = v; uj_type = tval } @@ -1041,7 +1041,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let c, update = try let c = List.assoc id update in - let c = pretype k0 resolve_tc (mk_tycon t) env evdref lvar c in + let c = pretype k0 resolve_tc (mk_tycon (EConstr.of_constr t)) env evdref lvar c in c.uj_val, List.remove_assoc id update with Not_found -> try @@ -1068,9 +1068,9 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let s = let sigma = !evdref in let t = Retyping.get_type_of env.ExtraEnv.env sigma (EConstr.of_constr v) in - match kind_of_term (whd_all env.ExtraEnv.env sigma (EConstr.of_constr t)) with + match EConstr.kind sigma (EConstr.of_constr (whd_all env.ExtraEnv.env sigma (EConstr.of_constr t))) with | Sort s -> s - | Evar ev when is_Type (existential_type sigma ev) -> + | Evar ev when is_Type (existential_type sigma (fst ev, Array.map EConstr.Unsafe.to_constr (snd ev))) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type") in @@ -1101,7 +1101,7 @@ let ise_pretype_gen flags env sigma lvar kind c = | WithoutTypeConstraint -> (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val | OfType exptyp -> - (pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c).uj_val + (pretype k0 flags.use_typeclasses (mk_tycon (EConstr.of_constr exptyp)) env evdref lvar c).uj_val | IsType -> (pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val in diff --git a/pretyping/typing.ml b/pretyping/typing.ml index acfe05f24d..db31541cd0 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -36,7 +36,7 @@ let inductive_type_knowing_parameters env (ind,u) jl = Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp let e_type_judgment env evdref j = - match kind_of_term (whd_all env !evdref (EConstr.of_constr j.uj_type)) with + match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref (EConstr.of_constr j.uj_type))) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | Evar ev -> let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in @@ -49,26 +49,27 @@ let e_assumption_of_judgment env evdref j = error_assumption env j let e_judge_of_apply env evdref funj argjv = + let open EConstr in let rec apply_rec n typ = function | [] -> - { uj_val = mkApp (j_val funj, Array.map j_val argjv); - uj_type = typ } + { uj_val = Constr.mkApp (j_val funj, Array.map j_val argjv); + uj_type = EConstr.Unsafe.to_constr typ } | hj::restjl -> - match kind_of_term (whd_all env !evdref (EConstr.of_constr typ)) with + match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref typ)) with | Prod (_,c1,c2) -> - if Evarconv.e_cumul env evdref hj.uj_type c1 then - apply_rec (n+1) (subst1 hj.uj_val c2) restjl + if Evarconv.e_cumul env evdref hj.uj_type (EConstr.Unsafe.to_constr c1) then + apply_rec (n+1) (Vars.subst1 (EConstr.of_constr hj.uj_val) c2) restjl else - error_cant_apply_bad_type env (n,c1, hj.uj_type) funj argjv + error_cant_apply_bad_type env (n, EConstr.Unsafe.to_constr c1, hj.uj_type) funj argjv | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product !evdref ev in evdref := evd'; - let (_,_,c2) = destProd t in - apply_rec (n+1) (subst1 hj.uj_val c2) restjl + let (_,_,c2) = destProd evd' t in + apply_rec (n+1) (Vars.subst1 (EConstr.of_constr hj.uj_val) c2) restjl | _ -> error_cant_apply_not_functional env funj argjv in - apply_rec 1 funj.uj_type (Array.to_list argjv) + apply_rec 1 (EConstr.of_constr funj.uj_type) (Array.to_list argjv) let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 8865e69ef5..f282ec4f18 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -105,26 +105,27 @@ let abstract_list_all env evd typ c l = try Typing.type_of env evd p with | UserError _ -> - error_cannot_find_well_typed_abstraction env evd p l None + error_cannot_find_well_typed_abstraction env evd p (List.map EConstr.of_constr l) None | Type_errors.TypeError (env',x) -> - error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in + error_cannot_find_well_typed_abstraction env evd p (List.map EConstr.of_constr l) (Some (env',x)) in evd,(p,typp) let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) let abstract_list_all_with_dependencies env evd typ c l = + let open EConstr in let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (ev, evd, _) = new_evar env evd typ in let evd = Sigma.to_evar_map evd in - let evd,ev' = evar_absorb_arguments env evd (destEvar ev) l in + let evd,ev' = evar_absorb_arguments env evd (destEvar evd (EConstr.of_constr ev)) l in let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in if b then - let p = nf_evar evd (existential_value evd (destEvar ev)) in + let p = nf_evar evd ev in evd, p else error_cannot_find_well_typed_abstraction env evd (nf_evar evd c) l None @@ -1899,7 +1900,7 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in + let evd, pred = abstract_list_all_with_dependencies env evd typp typ (List.map EConstr.of_constr oplist) in w_merge env false flags.merge_unify_flags (evd,[p,pred,(Conv,TypeProcessed)],[]) -- cgit v1.2.3 From b7fd585b89ac5e0b7770f52739c33fe179f2eed8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Nov 2016 21:36:40 +0100 Subject: Evarsolve API using EConstr. --- pretyping/cases.ml | 12 +- pretyping/evarconv.ml | 85 ++++---- pretyping/evarsolve.ml | 475 +++++++++++++++++++++++-------------------- pretyping/evarsolve.mli | 11 +- pretyping/pretype_errors.ml | 8 +- pretyping/pretype_errors.mli | 8 +- pretyping/pretyping.ml | 10 +- pretyping/typing.ml | 4 +- pretyping/unification.ml | 21 +- 9 files changed, 341 insertions(+), 293 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 915cd261d7..a68daf4e5d 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -78,6 +78,9 @@ let list_try_compile f l = let force_name = let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na +let to_conv_fun f = (); fun env sigma pb c1 c2 -> + f env sigma pb (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) + (************************************************************************) (* Pattern-matching compilation (Cases) *) (************************************************************************) @@ -1583,7 +1586,7 @@ let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = | LocalAssum _ -> p in let p = traverse_local_defs p in let u = lift (n' - n) u in - try Some (p, u, expand_vars_in_term extenv sigma u) + try Some (p, u, EConstr.Unsafe.to_constr (expand_vars_in_term extenv sigma (EConstr.of_constr u))) (* pedrot: does this really happen to raise [Failure _]? *) with Failure _ -> None in let subst0 = List.map_filter map subst in @@ -1628,14 +1631,15 @@ let abstract_tycon loc env evdref subst tycon extenv t = | Rel n when is_local_def (lookup_rel n env) -> t | Evar ev -> let ty = get_type_of env !evdref (EConstr.of_constr t) in - let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in + let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref (EConstr.of_constr ty) in let inst = List.map_i (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context env) in let ev' = e_new_evar env evdref ~src ty in - begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,EConstr.of_constr (substl inst ev')) with + let ev = (fst ev, Array.map EConstr.of_constr (snd ev)) in + begin match solve_simple_eqn (to_conv_fun (evar_conv_x full_transparent_state)) env !evdref (None,ev,EConstr.of_constr (substl inst ev')) with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; @@ -1650,7 +1654,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = let vl = List.map pi1 good in let ty = let ty = get_type_of env !evdref (EConstr.of_constr t) in - Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty + Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref (EConstr.of_constr ty) in let ty = lift (-k) (aux x ty) in let depvl = free_rels !evdref (EConstr.of_constr ty) in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 4540af28b9..8f3f671abf 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -42,6 +42,9 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> debug_unification:=a); } +let to_conv_fun f = (); fun env sigma pb c1 c2 -> + f env sigma pb (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) + let unfold_projection env evd ts p c = let cst = Projection.constant p in if is_transparent_constant ts cst then @@ -341,7 +344,7 @@ let rec evar_conv_x ts env evd pbty term1 term2 = env evd term1 term2 in if b then Success evd - else UnifFailure (evd, ConversionFailed (env,term1,term2)) + else UnifFailure (evd, ConversionFailed (env,EConstr.of_constr term1,EConstr.of_constr term2)) with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) in match e with @@ -361,15 +364,15 @@ let rec evar_conv_x ts env evd pbty term1 term2 = (whd_nored_state evd (EConstr.of_constr term1,Stack.empty), Cst_stack.empty) (whd_nored_state evd (EConstr.of_constr term2,Stack.empty), Cst_stack.empty) in - begin match kind_of_term term1, kind_of_term term2 with + begin match EConstr.kind evd (EConstr.of_constr term1), EConstr.kind evd (EConstr.of_constr term2) with | Evar ev, _ when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (evar_conv_x ts) env evd + (match solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env evd (position_problem true pbty,ev, EConstr.of_constr term2) with | UnifFailure (_,OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) | _, Evar ev when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (evar_conv_x ts) env evd + (match solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env evd (position_problem false pbty,ev, EConstr.of_constr term1) with | UnifFailure (_, OccurCheck _) -> (* Eta-expansion might apply *) default () @@ -383,13 +386,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty UnifFailure (i, NotSameHead) in let miller_pfenning on_left fallback ev lF tM evd = - let lF = List.map EConstr.Unsafe.to_constr lF in match is_unification_pattern_evar env evd ev lF tM with | None -> fallback () | Some l1' -> (* Miller-Pfenning's patterns unification *) - let t2 = nf_evar evd tM in + let t2 = EConstr.of_constr (nf_evar evd (EConstr.Unsafe.to_constr tM)) (** FIXME *) in let t2 = solve_pattern_eqn env evd l1' t2 in - solve_simple_eqn (evar_conv_x ts) env evd + solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env evd (position_problem on_left pbty,ev, EConstr.of_constr t2) in let consume_stack on_left (termF,skF) (termO,skO) evd = @@ -441,7 +443,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun () -> if not_only_app then (* Postpone the use of an heuristic *) switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) (zip evd apprF) tM else quick_fail i) - ev lF tM i + ev lF (EConstr.of_constr tM) i and consume (termF,skF as apprF) (termM,skM as apprM) i = if not (Stack.is_empty skF && Stack.is_empty skM) then consume_stack on_left apprF apprM i @@ -510,8 +512,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) tF tR else - UnifFailure (evd,OccurCheck (fst ev,tR)))]) - ev lF tR evd + UnifFailure (evd,OccurCheck (fst ev,EConstr.of_constr tR)))]) + (fst ev, Array.map EConstr.of_constr (snd ev)) lF (EConstr.of_constr tR) evd in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) @@ -529,33 +531,33 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | None, Success i' -> (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) - let ev1' = whd_evar i' (mkEvar ev1) in - if isEvar ev1' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar ev1', term2) + let ev1' = EConstr.of_constr (whd_evar i' (mkEvar ev1)) in + if EConstr.isEvar i' ev1' then + solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env i' + (position_problem true pbty,EConstr.destEvar i' ev1', term2) else evar_eqappr_x ts env evd pbty - ((EConstr.of_constr ev1', sk1), csts1) ((term2, sk2), csts2) + ((ev1', sk1), csts1) ((term2, sk2), csts2) | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) - let ev2' = whd_evar i' (mkEvar ev2) in - if isEvar ev2' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem false pbty,destEvar ev2',Stack.zip evd (term1,r)) + let ev2' = EConstr.of_constr (whd_evar i' (mkEvar ev2)) in + if EConstr.isEvar i' ev2' then + solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env i' + (position_problem false pbty,EConstr.destEvar i' ev2',Stack.zip evd (term1,r)) else evar_eqappr_x ts env evd pbty - ((EConstr.of_constr ev2', sk1), csts1) ((term2, sk2), csts2) + ((ev2', sk1), csts1) ((term2, sk2), csts2) | Some ([],r), Success i' -> (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) (* we now unify ?ev1 and r[?ev2] *) - let ev1' = whd_evar i' (mkEvar ev1) in - if isEvar ev1' then - solve_simple_eqn (evar_conv_x ts) env i' - (position_problem true pbty,destEvar ev1',Stack.zip evd (term2,r)) + let ev1' = EConstr.of_constr (whd_evar i' (mkEvar ev1)) in + if EConstr.isEvar i' ev1' then + solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env i' + (position_problem true pbty,EConstr.destEvar i' ev1',Stack.zip evd (term2,r)) else evar_eqappr_x ts env evd pbty - ((EConstr.of_constr ev1', sk1), csts1) ((term2, sk2), csts2) + ((ev1', sk1), csts1) ((term2, sk2), csts2) | None, (UnifFailure _ as x) -> (* sk1 and sk2 have no common outer part *) if Stack.not_purely_applicative sk2 then @@ -590,9 +592,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty if Evar.equal sp1 sp2 then match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with |None, Success i' -> - Success (solve_refl (fun env i pbty a1 a2 -> - is_success (evar_conv_x ts env i pbty a1 a2)) - env i' (position_problem true pbty) sp1 al1 al2) + Success (solve_refl (to_conv_fun (fun env i pbty a1 a2 -> + is_success (evar_conv_x ts env i pbty a1 a2))) + env i' (position_problem true pbty) sp1 (Array.map EConstr.of_constr al1) (Array.map EConstr.of_constr al2)) |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (i,NotSameArgSize) else UnifFailure (i,NotSameHead) @@ -600,10 +602,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_try evd [f1; f2] | Flexible ev1, MaybeFlexible v2 -> - flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) (EConstr.of_constr v2) + flex_maybeflex true (fst ev1, Array.map EConstr.of_constr (snd ev1)) (appr1,csts1) (appr2,csts2) (EConstr.of_constr v2) | MaybeFlexible v1, Flexible ev2 -> - flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) (EConstr.of_constr v1) + flex_maybeflex false (fst ev2, Array.map EConstr.of_constr (snd ev2)) (appr2,csts2) (appr1,csts1) (EConstr.of_constr v1) | MaybeFlexible v1, MaybeFlexible v2 -> begin match kind_of_term (EConstr.Unsafe.to_constr term1), kind_of_term (EConstr.Unsafe.to_constr term2) with @@ -964,7 +966,8 @@ let first_order_unification ts env evd (ev1,l1) (term2,l2) = if is_defined i (fst ev1) then evar_conv_x ts env i CONV t2 (mkEvar ev1) else - solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1, EConstr.of_constr t2))] + let ev1 = (fst ev1, Array.map EConstr.of_constr (snd ev1)) in + solve_simple_eqn ~choose:true (to_conv_fun (evar_conv_x ts)) env i (None,ev1, EConstr.of_constr t2))] let choose_less_dependent_instance evk evd term args = let evi = Evd.find_undefined evd evk in @@ -1109,7 +1112,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = match evar_conv_x ts env_evar evd CUMUL idty evty with | UnifFailure _ -> error "Cannot find an instance" | Success evd -> - match reconsider_conv_pbs (evar_conv_x ts) evd with + match reconsider_conv_pbs (to_conv_fun (evar_conv_x ts)) evd with | UnifFailure _ -> error "Cannot find an instance" | Success evd -> evd @@ -1123,8 +1126,8 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = force_instantiation evd !evsref | [] -> let evd = - try Evarsolve.check_evar_instance evd evk rhs - (evar_conv_x full_transparent_state) + try Evarsolve.check_evar_instance evd evk (EConstr.of_constr rhs) + (to_conv_fun (evar_conv_x full_transparent_state)) with IllTypedInstance _ -> raise (TypingFailed evd) in Evd.define evk rhs evd @@ -1173,11 +1176,13 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> let f env evd pbty x y = is_fconv ~reds:ts pbty env evd (EConstr.of_constr x) (EConstr.of_constr y) in - Success (solve_refl ~can_drop:true f env evd - (position_problem true pbty) evk1 args1 args2) + Success (solve_refl ~can_drop:true (to_conv_fun f) env evd + (position_problem true pbty) evk1 (Array.map EConstr.of_constr args1) (Array.map EConstr.of_constr args2)) | Evar ev1, Evar ev2 when app_empty -> + let ev1 = (fst ev1, Array.map EConstr.of_constr (snd ev1)) in + let ev2 = (fst ev2, Array.map EConstr.of_constr (snd ev2)) in Success (solve_evar_evar ~force:true - (evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd + (evar_define (to_conv_fun (evar_conv_x ts)) ~choose:true) (to_conv_fun (evar_conv_x ts)) env evd (position_problem true pbty) ev1 ev2) | Evar ev1,_ when Array.length l1 <= Array.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) @@ -1239,9 +1244,9 @@ let rec solve_unconstrained_evars_with_candidates ts evd = | a::l -> try let conv_algo = evar_conv_x ts in - let evd = check_evar_instance evd evk a conv_algo in + let evd = check_evar_instance evd evk (EConstr.of_constr a) (to_conv_fun conv_algo) in let evd = Evd.define evk a evd in - match reconsider_conv_pbs conv_algo evd with + match reconsider_conv_pbs (to_conv_fun conv_algo) evd with | Success evd -> solve_unconstrained_evars_with_candidates ts evd | UnifFailure _ -> aux l with @@ -1260,7 +1265,7 @@ let solve_unconstrained_impossible_cases env evd = let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc evd' ctx in let ty = j_type j in let conv_algo = evar_conv_x full_transparent_state in - let evd' = check_evar_instance evd' evk ty conv_algo in + let evd' = check_evar_instance evd' evk (EConstr.of_constr ty) (to_conv_fun conv_algo) in Evd.define evk ty evd' | _ -> evd') evd evd diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 86ef8f56f1..8a22aed2f2 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -22,13 +22,14 @@ open Pretype_errors open Sigma.Notations let normalize_evar evd ev = - match kind_of_term (whd_evar evd (mkEvar ev)) with + let open EConstr in + match EConstr.kind evd (mkEvar ev) with | Evar (evk,args) -> (evk,args) | _ -> assert false -let get_polymorphic_positions f = +let get_polymorphic_positions sigma f = let open Declarations in - match kind_of_term f with + match EConstr.kind sigma f with | Ind (ind, u) | Construct ((ind, _), u) -> let mib,oib = Global.lookup_inductive ind in (match oib.mind_arity with @@ -49,10 +50,11 @@ let refresh_level evd s = let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) pbty env evd t = + let open EConstr in let evdref = ref evd in let modified = ref false in let rec refresh status dir t = - match kind_of_term t with + match EConstr.kind !evdref t with | Sort (Type u as s) when (match Univ.universe_level u with | None -> true @@ -72,20 +74,20 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) | _ -> t (** Refresh the types of evars under template polymorphic references *) and refresh_term_evars onevars top t = - match kind_of_term (whd_evar !evdref t) with - | App (f, args) when is_template_polymorphic env !evdref (EConstr.of_constr f) -> - let pos = get_polymorphic_positions f in + match EConstr.kind !evdref t with + | App (f, args) when is_template_polymorphic env !evdref f -> + let pos = get_polymorphic_positions !evdref f in refresh_polymorphic_positions args pos - | App (f, args) when top && isEvar f -> + | App (f, args) when top && isEvar !evdref f -> refresh_term_evars true false f; Array.iter (refresh_term_evars onevars false) args | Evar (ev, a) when onevars -> let evi = Evd.find !evdref ev in - let ty' = refresh univ_flexible true evi.evar_concl in + let ty' = refresh univ_flexible true (EConstr.of_constr evi.evar_concl) in if !modified then - evdref := Evd.add !evdref ev {evi with evar_concl = ty'} + evdref := Evd.add !evdref ev {evi with evar_concl = EConstr.Unsafe.to_constr ty'} else () - | _ -> Constr.iter (refresh_term_evars onevars false) t + | _ -> EConstr.iter !evdref (refresh_term_evars onevars false) t and refresh_polymorphic_positions args pos = let rec aux i = function | Some l :: ls -> @@ -100,17 +102,17 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) in aux 0 pos in let t' = - if isArity t then + if isArity !evdref t then (match pbty with | None -> t | Some dir -> refresh status dir t) else (refresh_term_evars false true t; t) in - if !modified then !evdref, t' else !evdref, t + if !modified then !evdref, EConstr.Unsafe.to_constr t' else !evdref, EConstr.Unsafe.to_constr t let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in - refresh_universes (Some false) env sigma ty + refresh_universes (Some false) env sigma (EConstr.of_constr ty) (************************) @@ -127,6 +129,8 @@ let test_success conv_algo env evd c c' rhs = is_success (conv_algo env evd c c' rhs) let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = + let t1 = EConstr.Unsafe.to_constr t1 in + let t2 = EConstr.Unsafe.to_constr t2 in match pbty with | Some true -> add_conv_pb ~tail (Reduction.CUMUL,env,t1,t2) evd | Some false -> add_conv_pb ~tail (Reduction.CUMUL,env,t2,t1) evd @@ -134,29 +138,30 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = (* We retype applications to ensure the universe constraints are collected *) -exception IllTypedInstance of env * types * types +exception IllTypedInstance of env * EConstr.types * EConstr.types let recheck_applications conv_algo env evdref t = + let open EConstr in let rec aux env t = - match kind_of_term t with + match EConstr.kind !evdref t with | App (f, args) -> let () = aux env f in - let fty = Retyping.get_type_of env !evdref (EConstr.of_constr f) in - let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref (EConstr.of_constr x)) args in + let fty = Retyping.get_type_of env !evdref f in + let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in let rec aux i ty = if i < Array.length argsty then - match kind_of_term (whd_all env !evdref (EConstr.of_constr ty)) with + match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref ty)) with | Prod (na, dom, codom) -> - (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with + (match conv_algo env !evdref Reduction.CUMUL (EConstr.of_constr argsty.(i)) dom with | Success evd -> evdref := evd; - aux (succ i) (subst1 args.(i) codom) + aux (succ i) (Vars.subst1 args.(i) codom) | UnifFailure (evd, reason) -> - Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) - | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) + Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), EConstr.Unsafe.to_constr dom)) + | _ -> raise (IllTypedInstance (env, ty, EConstr.of_constr argsty.(i))) else () - in aux 0 fty + in aux 0 (EConstr.of_constr fty) | _ -> - iter_constr_with_full_binders (fun d env -> push_rel d env) aux env t + iter_with_full_binders !evdref (fun d env -> push_rel d env) aux env t in aux env t @@ -169,7 +174,7 @@ type 'a update = | NoUpdate open Context.Named.Declaration -let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign +let inst_of_vars sign = Array.map_of_list (get_id %> EConstr.mkVar) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -186,7 +191,7 @@ let restrict_evar_key evd evk filter candidates = | Some filter -> filter in let candidates = match candidates with | NoUpdate -> evi.evar_candidates - | UpdateWith c -> Some c in + | UpdateWith c -> Some (List.map EConstr.Unsafe.to_constr c) in let sigma = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in (Sigma.to_evar_map sigma, evk) @@ -216,27 +221,25 @@ let restrict_instance evd evk filter argsv = open Context.Rel.Declaration let noccur_evar env evd evk c = + let open EConstr in let cache = ref Int.Set.empty (* cache for let-ins *) in let rec occur_rec check_types (k, env as acc) c = - match kind_of_term c with + match EConstr.kind evd c with | Evar (evk',args' as ev') -> - (match safe_evar_value evd ev' with - | Some c -> occur_rec check_types acc c - | None -> - if Evar.equal evk evk' then raise Occur - else (if check_types then - occur_rec false acc (existential_type evd ev'); - Array.iter (occur_rec check_types acc) args')) + if Evar.equal evk evk' then raise Occur + else (if check_types then + occur_rec false acc (existential_type evd ev'); + Array.iter (occur_rec check_types acc) args') | Rel i when i > k -> if not (Int.Set.mem (i-k) !cache) then let decl = Environ.lookup_rel i env in if check_types then - (cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (get_type decl))); + (cache := Int.Set.add (i-k) !cache; occur_rec false acc (Vars.lift i (EConstr.of_constr (get_type decl)))); (match decl with | LocalAssum _ -> () - | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i b)) + | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (Vars.lift i (EConstr.of_constr b))) | Proj (p,c) -> occur_rec true acc c - | _ -> iter_constr_with_full_binders (fun rd (k,env) -> (succ k, push_rel rd env)) + | _ -> iter_with_full_binders evd (fun rd (k,env) -> (succ k, push_rel rd env)) (occur_rec check_types) acc c in try occur_rec false (0,env) c; true with Occur -> false @@ -249,13 +252,14 @@ let noccur_evar env evd evk c = dependencies in variables are canonically associated to the most ancient variable in its family of aliased variables *) -let compute_var_aliases sign = +let compute_var_aliases sign sigma = let open Context.Named.Declaration in List.fold_right (fun decl aliases -> let id = get_id decl in match decl with | LocalDef (_,t,_) -> - (match kind_of_term t with + let t = EConstr.of_constr t in + (match EConstr.kind sigma t with | Var id' -> let aliases_of_id = try Id.Map.find id' aliases with Not_found -> [] in @@ -265,13 +269,16 @@ let compute_var_aliases sign = | LocalAssum _ -> aliases) sign Id.Map.empty -let compute_rel_aliases var_aliases rels = +let compute_rel_aliases var_aliases rels sigma = + let open EConstr in snd (List.fold_right (fun decl (n,aliases) -> (n-1, match decl with | LocalDef (_,t,u) -> - (match kind_of_term t with + let t = EConstr.of_constr t in + let u = EConstr.of_constr u in + (match EConstr.kind sigma t with | Var id' -> let aliases_of_n = try Id.Map.find id' var_aliases with Not_found -> [] in @@ -281,52 +288,57 @@ let compute_rel_aliases var_aliases rels = try Int.Map.find (p+n) aliases with Not_found -> [] in Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases | _ -> - Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) + Int.Map.add n [Vars.lift n (mkCast(t,DEFAULTcast,u))] aliases) | LocalAssum _ -> aliases) ) rels (List.length rels,Int.Map.empty)) -let make_alias_map env = +let make_alias_map env sigma = (* We compute the chain of aliases for each var and rel *) - let var_aliases = compute_var_aliases (named_context env) in - let rel_aliases = compute_rel_aliases var_aliases (rel_context env) in + let var_aliases = compute_var_aliases (named_context env) sigma in + let rel_aliases = compute_rel_aliases var_aliases (rel_context env) sigma in (var_aliases,rel_aliases) let lift_aliases n (var_aliases,rel_aliases as aliases) = + let open EConstr in if Int.equal n 0 then aliases else (var_aliases, - Int.Map.fold (fun p l -> Int.Map.add (p+n) (List.map (lift n) l)) + Int.Map.fold (fun p l -> Int.Map.add (p+n) (List.map (Vars.lift n) l)) rel_aliases Int.Map.empty) -let get_alias_chain_of aliases x = match kind_of_term x with +let get_alias_chain_of sigma aliases x = match EConstr.kind sigma x with | Rel n -> (try Int.Map.find n (snd aliases) with Not_found -> []) | Var id -> (try Id.Map.find id (fst aliases) with Not_found -> []) | _ -> [] -let normalize_alias_opt aliases x = - match get_alias_chain_of aliases x with +let normalize_alias_opt sigma aliases x = + let open EConstr in + match get_alias_chain_of sigma aliases x with | [] -> None - | a::_ when isRel a || isVar a -> Some a + | a::_ when isRel sigma a || isVar sigma a -> Some a | [_] -> None | _::a::_ -> Some a -let normalize_alias aliases x = - match normalize_alias_opt aliases x with +let normalize_alias sigma aliases x = + match normalize_alias_opt sigma aliases x with | Some a -> a | None -> x -let normalize_alias_var var_aliases id = - destVar (normalize_alias (var_aliases,Int.Map.empty) (mkVar id)) +let normalize_alias_var sigma var_aliases id = + let open EConstr in + destVar sigma (normalize_alias sigma (var_aliases,Int.Map.empty) (mkVar id)) -let extend_alias decl (var_aliases,rel_aliases) = +let extend_alias sigma decl (var_aliases,rel_aliases) = + let open EConstr in let rel_aliases = - Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l)) + Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (Vars.lift 1) l)) rel_aliases Int.Map.empty in let rel_aliases = match decl with | LocalDef(_,t,_) -> - (match kind_of_term t with + let t = EConstr.of_constr t in + (match EConstr.kind sigma t with | Var id' -> let aliases_of_binder = try Id.Map.find id' var_aliases with Not_found -> [] in @@ -336,37 +348,38 @@ let extend_alias decl (var_aliases,rel_aliases) = try Int.Map.find (p+1) rel_aliases with Not_found -> [] in Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases | _ -> - Int.Map.add 1 [lift 1 t] rel_aliases) + Int.Map.add 1 [Vars.lift 1 t] rel_aliases) | LocalAssum _ -> rel_aliases in (var_aliases, rel_aliases) -let expand_alias_once aliases x = - match get_alias_chain_of aliases x with +let expand_alias_once sigma aliases x = + match get_alias_chain_of sigma aliases x with | [] -> None | l -> Some (List.last l) -let expansions_of_var aliases x = - match get_alias_chain_of aliases x with +let expansions_of_var sigma aliases x = + let open EConstr in + match get_alias_chain_of sigma aliases x with | [] -> [x] - | a::_ as l when isRel a || isVar a -> x :: List.rev l + | a::_ as l when isRel sigma a || isVar sigma a -> x :: List.rev l | _::l -> x :: List.rev l -let expansion_of_var aliases x = - match get_alias_chain_of aliases x with +let expansion_of_var sigma aliases x = + match get_alias_chain_of sigma aliases x with | [] -> x | a::_ -> a -let rec expand_vars_in_term_using sigma aliases t = match kind_of_term t with +let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t with | Rel _ | Var _ -> - normalize_alias aliases t + normalize_alias sigma aliases t | _ -> - let self aliases c = EConstr.of_constr (expand_vars_in_term_using sigma aliases (EConstr.Unsafe.to_constr c)) in - EConstr.Unsafe.to_constr (map_constr_with_full_binders sigma - extend_alias self aliases (EConstr.of_constr t)) + let self aliases c = expand_vars_in_term_using sigma aliases c in + map_constr_with_full_binders sigma (extend_alias sigma) self aliases t -let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env) +let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env sigma) -let free_vars_and_rels_up_alias_expansion aliases c = +let free_vars_and_rels_up_alias_expansion sigma aliases c = + let open EConstr in let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in let acc3 = ref Int.Set.empty and acc4 = ref Id.Set.empty in let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in @@ -379,25 +392,25 @@ let free_vars_and_rels_up_alias_expansion aliases c = | Var s -> cache_var := Id.Set.add s !cache_var | _ -> () in let rec frec (aliases,depth) c = - match kind_of_term c with + match EConstr.kind sigma c with | Rel _ | Var _ as ck -> if is_in_cache depth ck then () else begin put_in_cache depth ck; - let c' = expansion_of_var aliases c in - (if c != c' then (* expansion, hence a let-in *) - match kind_of_term c with + let c' = expansion_of_var sigma aliases c in + (if c != c' then (* expansion, hence a let-in *) (** FIXME *) + match EConstr.kind sigma c with | Var id -> acc4 := Id.Set.add id !acc4 | Rel n -> if n >= depth+1 then acc3 := Int.Set.add (n-depth) !acc3 | _ -> ()); - match kind_of_term c' with + match EConstr.kind sigma c' with | Var id -> acc2 := Id.Set.add id !acc2 | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 | _ -> frec (aliases,depth) c end | Const _ | Ind _ | Construct _ -> - acc2 := Id.Set.union (vars_of_global (Global.env()) c) !acc2 + acc2 := Id.Set.union (vars_of_global (Global.env()) (EConstr.to_constr sigma c)) !acc2 | _ -> - iter_constr_with_full_binders - (fun d (aliases,depth) -> (extend_alias d aliases,depth+1)) + iter_with_full_binders sigma + (fun d (aliases,depth) -> (extend_alias sigma d aliases,depth+1)) frec (aliases,depth) c in frec (aliases,0) c; @@ -407,11 +420,11 @@ let free_vars_and_rels_up_alias_expansion aliases c = (* Managing pattern-unification *) (********************************) -let rec expand_and_check_vars aliases = function +let rec expand_and_check_vars sigma aliases = function | [] -> [] - | a::l when isRel a || isVar a -> - let a = expansion_of_var aliases a in - if isRel a || isVar a then a :: expand_and_check_vars aliases l + | a::l when EConstr.isRel sigma a || EConstr.isVar sigma a -> + let a = expansion_of_var sigma aliases a in + if EConstr.isRel sigma a || EConstr.isVar sigma a then a :: expand_and_check_vars sigma aliases l else raise Exit | _ -> raise Exit @@ -422,24 +435,25 @@ module Constrhash = Hashtbl.Make let hash = hash_constr end) -let constr_list_distinct l = +let constr_list_distinct sigma l = let visited = Constrhash.create 23 in let rec loop = function | h::t -> + let h = EConstr.to_constr sigma h in if Constrhash.mem visited h then false else (Constrhash.add visited h h; loop t) | [] -> true in loop l let get_actual_deps evd aliases l t = - if occur_meta_or_existential evd (EConstr.of_constr t) then + if occur_meta_or_existential evd t then (* Probably no restrictions on allowed vars in presence of evars *) l else (* Probably strong restrictions coming from t being evar-closed *) - let (fv_rels,fv_ids,_,_) = free_vars_and_rels_up_alias_expansion aliases t in + let (fv_rels,fv_ids,_,_) = free_vars_and_rels_up_alias_expansion evd aliases t in List.filter (fun c -> - match kind_of_term c with + match EConstr.kind evd c with | Var id -> Id.Set.mem id fv_ids | Rel n -> Int.Set.mem n fv_rels | _ -> assert false) l @@ -462,10 +476,11 @@ let remove_instance_local_defs evd evk args = (* Check if an applied evar "?X[args] l" is a Miller's pattern *) let find_unification_pattern_args env evd l t = - if List.for_all (fun x -> isRel x || isVar x) l (* common failure case *) then - let aliases = make_alias_map env in - match (try Some (expand_and_check_vars aliases l) with Exit -> None) with - | Some l as x when constr_list_distinct (get_actual_deps evd aliases l t) -> x + let open EConstr in + if List.for_all (fun x -> isRel evd x || isVar evd x) l (* common failure case *) then + let aliases = make_alias_map env evd in + match (try Some (expand_and_check_vars evd aliases l) with Exit -> None) with + | Some l as x when constr_list_distinct evd (get_actual_deps evd aliases l t) -> x | _ -> None else None @@ -473,15 +488,17 @@ let find_unification_pattern_args env evd l t = let is_unification_pattern_meta env evd nb m l t = (* Variables from context and rels > nb are implicitly all there *) (* so we need to be a rel <= nb *) - if List.for_all (fun x -> isRel x && destRel x <= nb) l then + let open EConstr in + if List.for_all (fun x -> isRel evd x && destRel evd x <= nb) l then match find_unification_pattern_args env evd l t with - | Some _ as x when not (dependent evd (EConstr.mkMeta m) (EConstr.of_constr t)) -> x + | Some _ as x when not (dependent evd (EConstr.mkMeta m) t) -> x | _ -> None else None let is_unification_pattern_evar env evd (evk,args) l t = - if List.for_all (fun x -> isRel x || isVar x) l + let open EConstr in + if List.for_all (fun x -> isRel evd x || isVar evd x) l && noccur_evar env evd evk t then let args = remove_instance_local_defs evd evk args in @@ -498,7 +515,7 @@ let is_unification_pattern_pure_evar env evd (evk,args) t = | Some _ -> true let is_unification_pattern (env,nb) evd f l t = - match kind_of_term f with + match EConstr.kind evd f with | Meta m -> is_unification_pattern_meta env evd nb m l t | Evar ev -> is_unification_pattern_evar env evd ev l t | _ -> None @@ -511,21 +528,23 @@ let is_unification_pattern (env,nb) evd f l t = dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) let solve_pattern_eqn env sigma l c = + let open EConstr in let c' = List.fold_right (fun a c -> - let c' = subst_term sigma (EConstr.of_constr (lift 1 a)) (EConstr.of_constr (lift 1 c)) in - match kind_of_term a with + let c' = subst_term sigma (Vars.lift 1 a) (Vars.lift 1 c) in + match EConstr.kind sigma a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> let open Context.Rel.Declaration in let d = map_constr (lift n) (lookup_rel n env) in + let c' = EConstr.of_constr c' in mkLambda_or_LetIn d c' | Var id -> - let d = lookup_named id env in mkNamedLambda_or_LetIn d c' + let d = lookup_named id env in EConstr.of_constr (mkNamedLambda_or_LetIn d c') | _ -> assert false) l c in (* Warning: we may miss some opportunity to eta-reduce more since c' is not in normal form *) - shrink_eta (EConstr.of_constr c') + shrink_eta c' (*****************************************) (* Refining/solving unification problems *) @@ -543,35 +562,33 @@ let solve_pattern_eqn env sigma l c = let make_projectable_subst aliases sigma evi args = let sign = evar_filtered_context evi in - let evar_aliases = compute_var_aliases sign in + let evar_aliases = compute_var_aliases sign sigma in let (_,full_subst,cstr_subst) = List.fold_right (fun decl (args,all,cstrs) -> match decl,args with | LocalAssum (id,c), a::rest -> - let a = whd_evar sigma a in let cstrs = - let a',args = decompose_app_vect sigma (EConstr.of_constr a) in - match kind_of_term a' with + let a',args = decompose_app_vect sigma a in + match EConstr.kind sigma (EConstr.of_constr a') with | Construct cstr -> let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in - (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) + (rest,Id.Map.add id [a,normalize_alias_opt sigma aliases a,id] all,cstrs) | LocalDef (id,c,_), a::rest -> - let a = whd_evar sigma a in - (match kind_of_term c with + (match EConstr.kind sigma (EConstr.of_constr c) with | Var id' -> - let idc = normalize_alias_var evar_aliases id' in + let idc = normalize_alias_var sigma evar_aliases id' in let sub = try Id.Map.find idc all with Not_found -> [] in - if List.exists (fun (c,_,_) -> Term.eq_constr a c) sub then + if List.exists (fun (c,_,_) -> EConstr.eq_constr sigma a c) sub then (rest,all,cstrs) else (rest, - Id.Map.add idc ((a,normalize_alias_opt aliases a,id)::sub) all, + Id.Map.add idc ((a,normalize_alias_opt sigma aliases a,id)::sub) all, cstrs) | _ -> - (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs)) + (rest,Id.Map.add id [a,normalize_alias_opt sigma aliases a,id] all,cstrs)) | _ -> anomaly (Pp.str "Instance does not match its signature")) sign (Array.rev_to_list args,Id.Map.empty,Constrmap.empty) in (full_subst,cstr_subst) @@ -587,15 +604,18 @@ let make_projectable_subst aliases sigma evi args = *) let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = + let open EConstr in let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in + let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src (List.map EConstr.Unsafe.to_constr inst_in_env) in let evd = Sigma.to_evar_map evd in - let t_in_env = whd_evar evd t_in_env in - let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in + let t_in_env = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr t_in_env)) in + let evar_in_env = EConstr.of_constr evar_in_env in + let (evk, _) = destEvar evd evar_in_env in + let evd = define_fun env evd None (EConstr.destEvar evd evar_in_env) t_in_env in let ctxt = named_context_of_val sign in let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in - let evar_in_sign = mkEvar (fst (destEvar evar_in_env), inst_in_sign) in - (evd,whd_evar evd evar_in_sign) + let evar_in_sign = mkEvar (evk, inst_in_sign) in + (evd,whd_evar evd (EConstr.Unsafe.to_constr evar_in_sign)) (* We have x1..xq |- ?e1 : τ and had to solve something like * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some @@ -617,10 +637,11 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si exception MorePreciseOccurCheckNeeeded let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = + let open EConstr in if Evd.is_defined evd evk1 then (* Some circularity somewhere (see e.g. #3209) *) raise MorePreciseOccurCheckNeeeded; - let (evk1,args1) = destEvar (whd_evar evd (mkEvar (evk1,args1))) in + let (evk1,args1) = EConstr.destEvar evd (EConstr.mkEvar (evk1,args1)) in let evi1 = Evd.find_undefined evd evk1 in let env1,rel_sign = env_rel_context_chop k env in let sign1 = evar_hyps evi1 in @@ -634,36 +655,38 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in let id = next_name_away na avoid in let evd,t_in_sign = - let s = Retyping.get_sort_of env evd (EConstr.of_constr t_in_env) in + let t_in_env = EConstr.of_constr t_in_env in + let s = Retyping.get_sort_of env evd t_in_env in let evd,ty_t_in_sign = refresh_universes - ~status:univ_flexible (Some false) env evd (mkSort s) in + ~status:univ_flexible (Some false) env evd (EConstr.mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in let evd,d' = match d with | LocalAssum _ -> evd, Context.Named.Declaration.LocalAssum (id,t_in_sign) | LocalDef (_,b,_) -> + let b = EConstr.of_constr b in let evd,b = define_evar_from_virtual_equation define_fun env evd src b t_in_sign sign filter inst_in_env in evd, Context.Named.Declaration.LocalDef (id,b,t_in_sign) in (push_named_context_val d' sign, Filter.extend 1 filter, - (mkRel 1)::(List.map (lift 1) inst_in_env), - (mkRel 1)::(List.map (lift 1) inst_in_sign), + (mkRel 1)::(List.map (Vars.lift 1) inst_in_env), + (mkRel 1)::(List.map (Vars.lift 1) inst_in_sign), push_rel d env,evd,id::avoid)) rel_sign (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1) in let evd,ev2ty_in_sign = - let s = Retyping.get_sort_of env evd (EConstr.of_constr ty_in_env) in + let s = Retyping.get_sort_of env evd ty_in_env in let evd,ty_t_in_sign = refresh_universes - ~status:univ_flexible (Some false) env evd (mkSort s) in + ~status:univ_flexible (Some false) env evd (EConstr.mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (ev2_in_sign, evd, _) = - new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in + new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src (List.map EConstr.Unsafe.to_constr inst2_in_sign) in let evd = Sigma.to_evar_map evd in - let ev2_in_env = (fst (destEvar ev2_in_sign), Array.of_list inst2_in_env) in - (evd, ev2_in_sign, ev2_in_env) + let ev2_in_env = (fst (destEvar evd (EConstr.of_constr ev2_in_sign)), Array.of_list inst2_in_env) in + (evd, EConstr.of_constr ev2_in_sign, ev2_in_env) let restrict_upon_filter evd evk p args = let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in @@ -722,7 +745,7 @@ let find_projectable_constructor env evd cstr k args cstr_subst = type evar_projection = | ProjectVar -| ProjectEvar of existential * evar_info * Id.t * evar_projection +| ProjectEvar of EConstr.existential * evar_info * Id.t * evar_projection exception NotUnique exception NotUniqueInType of (Id.t * evar_projection) list @@ -730,19 +753,19 @@ exception NotUniqueInType of (Id.t * evar_projection) list let rec assoc_up_to_alias sigma aliases y yc = function | [] -> raise Not_found | (c,cc,id)::l -> - let c' = whd_evar sigma c in - if Term.eq_constr y c' then id + if EConstr.eq_constr sigma y c then id else match l with | _ :: _ -> assoc_up_to_alias sigma aliases y yc l | [] -> (* Last chance, we reason up to alias conversion *) - match (if c == c' then cc else normalize_alias_opt aliases c') with - | Some cc when Term.eq_constr yc cc -> id - | _ -> if Term.eq_constr yc c then id else raise Not_found + match (normalize_alias_opt sigma aliases c) with + | Some cc when EConstr.eq_constr sigma yc cc -> id + | _ -> if EConstr.eq_constr sigma yc c then id else raise Not_found let rec find_projectable_vars with_evars aliases sigma y subst = - let yc = normalize_alias aliases y in + let open EConstr in + let yc = normalize_alias sigma aliases y in let is_projectable idc idcl subst' = (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *) try @@ -752,12 +775,12 @@ let rec find_projectable_vars with_evars aliases sigma y subst = (* Then test if [idc] is (indirectly) bound in [subst] to some evar *) (* projectable on [y] *) if with_evars then - let f (c,_,id) = isEvar c && is_undefined sigma (fst (destEvar c)) in + let f (c,_,id) = isEvar sigma c in let idcl' = List.filter f idcl in match idcl' with | [c,_,id] -> begin - let (evk,argsv as t) = destEvar c in + let (evk,argsv as t) = destEvar sigma c in let evi = Evd.find sigma evk in let subst,_ = make_projectable_subst aliases sigma evi argsv in let l = find_projectable_vars with_evars aliases sigma y subst in @@ -805,19 +828,19 @@ let rec find_solution_type evarenv = function let rec do_projection_effects define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> - let evd = Evd.define evk (mkVar id) evd in + let open EConstr in + let evd = Evd.define evk (Constr.mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects define_fun env ty evd p in - let ty = whd_all env evd (EConstr.of_constr (Lazy.force ty)) in - if not (isSort ty) then + let ty = EConstr.of_constr (whd_all env evd (Lazy.force ty)) in + if not (isSort evd ty) then (* Don't try to instantiate if a sort because if evar_concl is an evar it may commit to a univ level which is not the right one (however, regarding coercions, because t is obtained by unif, we know that no coercion can be inserted) *) let subst = make_pure_subst evi argsv in - let ty' = replace_vars subst evi.evar_concl in - let ty' = whd_evar evd ty' in - if isEvar ty' then define_fun env evd (Some false) (destEvar ty') ty else evd + let ty' = Vars.replace_vars subst (EConstr.of_constr evi.evar_concl) in + if isEvar evd ty' then define_fun env evd (Some false) (destEvar evd ty') ty else evd else evd @@ -843,7 +866,7 @@ let rec do_projection_effects define_fun env ty evd = function type projectibility_kind = | NoUniqueProjection - | UniqueProjection of constr * evar_projection list + | UniqueProjection of EConstr.constr * evar_projection list type projectibility_status = | CannotInvert @@ -851,16 +874,16 @@ type projectibility_status = let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let effects = ref [] in + let open EConstr in let rec aux k t = - let t = whd_evar evd t in - match kind_of_term t with + match EConstr.kind evd t with | Rel i when i>k0+k -> aux' k (mkRel (i-k)) | Var id -> aux' k t - | _ -> map_constr_with_binders succ aux k t + | _ -> map_with_binders evd succ aux k t and aux' k t = - try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders + try EConstr.of_constr (project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders) with Not_found -> - match expand_alias_once aliases t with + match expand_alias_once evd aliases t with | None -> raise Not_found | Some c -> aux k c in try @@ -895,7 +918,7 @@ let extract_unique_projection = function let extract_candidates sols = try UpdateWith - (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols) + (List.map (function (id,ProjectVar) -> EConstr.mkVar id | _ -> raise Exit) sols) with Exit -> NoUpdate @@ -929,12 +952,12 @@ let filter_effective_candidates evd evi filter candidates = | None -> candidates | Some filter -> let ids = set_of_evctx (Filter.filter_list filter (evar_context evi)) in - List.filter (fun a -> Id.Set.subset (collect_vars evd (EConstr.of_constr a)) ids) candidates + List.filter (fun a -> Id.Set.subset (collect_vars evd a) ids) candidates let filter_candidates evd evk filter candidates_update = let evi = Evd.find_undefined evd evk in let candidates = match candidates_update with - | NoUpdate -> evi.evar_candidates + | NoUpdate -> Option.map (fun l -> List.map EConstr.of_constr l) evi.evar_candidates | UpdateWith c -> Some c in match candidates with @@ -982,17 +1005,18 @@ let restrict_hyps evd evk filter candidates = let typablefilter = closure_of_filter evd evk (Some filter) in (typablefilter,candidates) -exception EvarSolvedWhileRestricting of evar_map * constr +exception EvarSolvedWhileRestricting of evar_map * EConstr.constr let do_restrict_hyps evd (evk,args as ev) filter candidates = + let open EConstr in let filter,candidates = match filter with | None -> None,candidates | Some filter -> restrict_hyps evd evk filter candidates in match candidates,filter with | UpdateWith [], _ -> error "Not solvable." | UpdateWith [nc],_ -> - let evd = Evd.define evk nc evd in - raise (EvarSolvedWhileRestricting (evd,whd_evar evd (mkEvar ev))) + let evd = Evd.define evk (EConstr.Unsafe.to_constr nc) evd in + raise (EvarSolvedWhileRestricting (evd,mkEvar ev)) | NoUpdate, None -> evd,ev | _ -> restrict_applied_evar evd ev filter candidates @@ -1000,6 +1024,7 @@ let do_restrict_hyps evd (evk,args as ev) filter candidates = (* ?e is assumed to have no candidates *) let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = + let open EConstr in let rhs = expand_vars_in_term env evd rhs in let filter = restrict_upon_filter evd evk @@ -1010,8 +1035,8 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = (* that says that the body is hidden. Note that expand_vars_in_term *) (* expands only rels and vars aliases, not rels or vars bound to an *) (* arbitrary complex term *) - (fun a -> not (isRel a || isVar a) - || dependent evd (EConstr.of_constr a) (EConstr.of_constr rhs) || List.exists (fun (id,_) -> isVarId id a) sols) + (fun a -> not (isRel evd a || isVar evd a) + || dependent evd a rhs || List.exists (fun (id,_) -> isVarId evd id a) sols) argsv in let filter = closure_of_filter evd evk filter in let candidates = extract_candidates sols in @@ -1042,6 +1067,9 @@ let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = * Note: argument f is the function used to instantiate evars. *) +let instantiate_evar_array evi c args = + EConstr.of_constr (instantiate_evar_array evi (EConstr.Unsafe.to_constr c) (Array.map EConstr.Unsafe.to_constr args)) + let filter_compatible_candidates conv_algo env evd evi args rhs c = let c' = instantiate_evar_array evi c args in match conv_algo env evd Reduction.CONV rhs c' with @@ -1061,6 +1089,8 @@ let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = | _, None -> filter_candidates evd evk1 filter1 NoUpdate | None, Some _ -> raise DoesNotPreserveCandidateRestriction | Some l1, Some l2 -> + let l1 = List.map EConstr.of_constr l1 in + let l2 = List.map EConstr.of_constr l2 in let l1 = filter_effective_candidates evd evi1 filter1 l1 in let l1' = List.filter (fun c1 -> let c1' = instantiate_evar_array evi1 c1 argsv1 in @@ -1075,7 +1105,7 @@ let restrict_candidates conv_algo env evd filter1 (evk1,argsv1) (evk2,argsv2) = if Int.equal (List.length l1) (List.length l1') then NoUpdate else UpdateWith l1' -exception CannotProject of evar_map * existential +exception CannotProject of evar_map * EConstr.existential (* Assume that FV(?n[x1:=t1..xn:=tn]) belongs to some set U. Can ?n be instantiated by a term u depending essentially on xi such that the @@ -1092,15 +1122,15 @@ exception CannotProject of evar_map * existential *) let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = - let f,args = decompose_app_vect evd (EConstr.of_constr t) in - match kind_of_term f with + let f,args = decompose_app_vect evd t in + match EConstr.kind evd (EConstr.of_constr f) with | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in if n > Array.length args then true (* We don't try to be more clever *) else let params = fst (Array.chop n args) in - Array.for_all (is_constrainable_in false evd k g) params - | Ind _ -> Array.for_all (is_constrainable_in false evd k g) args + Array.for_all (EConstr.of_constr %> is_constrainable_in false evd k g) params + | Ind _ -> Array.for_all (EConstr.of_constr %> is_constrainable_in false evd k g) args | Prod (na,t1,t2) -> is_constrainable_in false evd k g t1 && is_constrainable_in false evd k g t2 | Evar (ev',_) -> top || not (Evar.equal ev' ev) (*If ev' needed, one may also try to restrict it*) | Var id -> Id.Set.mem id fv_ids @@ -1109,30 +1139,31 @@ let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = | _ -> (* We don't try to be more clever *) true let has_constrainable_free_vars env evd aliases force k ev (fv_rels,fv_ids,let_rels,let_ids) t = - let t' = expansion_of_var aliases t in + let t' = expansion_of_var evd aliases t in if t' != t then (* t is a local definition, we keep it only if appears in the list *) (* of let-in variables effectively occurring on the right-hand side, *) (* which is the only reason to keep it when inverting arguments *) - match kind_of_term t with + match EConstr.kind evd t with | Var id -> Id.Set.mem id let_ids | Rel n -> Int.Set.mem n let_rels | _ -> assert false else (* t is an instance for a proper variable; we filter it along *) (* the free variables allowed to occur *) - match kind_of_term t with + match EConstr.kind evd t with | Var id -> Id.Set.mem id fv_ids | Rel n -> n <= k || Int.Set.mem n fv_rels | _ -> (not force || noccur_evar env evd ev t) && is_constrainable_in true evd k (ev,(fv_rels,fv_ids)) t -exception EvarSolvedOnTheFly of evar_map * constr +exception EvarSolvedOnTheFly of evar_map * EConstr.constr (* Try to project evk1[argsv1] on evk2[argsv2], if [ev1] is a pattern on the common domain of definition *) let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = + let open EConstr in (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) - let fvs2 = free_vars_and_rels_up_alias_expansion aliases (mkEvar ev2) in + let fvs2 = free_vars_and_rels_up_alias_expansion evd aliases (mkEvar ev2) in let filter1 = restrict_upon_filter evd evk1 (has_constrainable_free_vars env evd aliases force k2 evk2 fvs2) argsv1 in @@ -1161,12 +1192,12 @@ let check_evar_instance evd evk1 body conv_algo = (* FIXME: The body might be ill-typed when this is called from w_merge *) (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) let ty = - try Retyping.get_type_of ~lax:true evenv evd (EConstr.of_constr body) + try EConstr.of_constr (Retyping.get_type_of ~lax:true evenv evd body) with Retyping.RetypeError _ -> error "Ill-typed evar instance" in - match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with + match conv_algo evenv evd Reduction.CUMUL ty (EConstr.of_constr evi.evar_concl) with | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,EConstr.of_constr evi.evar_concl)) let update_evar_source ev1 ev2 evd = let loc, evs2 = evar_source ev2 evd in @@ -1178,9 +1209,10 @@ let update_evar_source ev1 ev2 evd = let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = try + let open EConstr in let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in - let evd' = Evd.define evk2 body evd in - let evd' = update_evar_source (fst (destEvar body)) evk2 evd' in + let evd' = Evd.define evk2 (EConstr.Unsafe.to_constr body) evd in + let evd' = update_evar_source (fst (destEvar evd body)) evk2 evd' in check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1197,7 +1229,8 @@ let preferred_orientation evd evk1 evk2 = | _ -> true let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = - let aliases = make_alias_map env in + let open EConstr in + let aliases = make_alias_map env evd in if preferred_orientation evd evk1 evk2 then try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 with CannotProject (evd,ev2) -> @@ -1244,10 +1277,10 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar solve_evar_evar_aux force f g env evd pbty ev1 ev2 type conv_fun = - env -> evar_map -> conv_pb -> constr -> constr -> unification_result + env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> unification_result type conv_fun_bool = - env -> evar_map -> conv_pb -> constr -> constr -> bool + env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> bool (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs @@ -1255,8 +1288,9 @@ type conv_fun_bool = * depend on these args). *) let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = + let open EConstr in let evdref = ref evd in - if Array.equal (e_eq_constr_univs evdref) argsv1 argsv2 then !evdref else + if Array.equal (fun c1 c2 -> e_eq_constr_univs evdref (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) ) argsv1 argsv2 then !evdref else (* Filter and restrict if needed *) let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in let untypedfilter = @@ -1288,14 +1322,14 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = | Some l -> let l' = List.map_filter - (filter_compatible_candidates conv_algo env evd evi argsv rhs) l in + (fun c -> filter_compatible_candidates conv_algo env evd evi argsv rhs (EConstr.of_constr c)) l in match l' with | [] -> raise IncompatibleCandidates | [c,evd] -> (* solve_candidates might have been called recursively in the mean *) (* time and the evar been solved by the filtering process *) if Evd.is_undefined evd evk then - let evd' = Evd.define evk c evd in + let evd' = Evd.define evk (EConstr.Unsafe.to_constr c) evd in check_evar_instance evd' evk c conv_algo else evd | l when List.length l < List.length l' -> @@ -1304,7 +1338,9 @@ let solve_candidates conv_algo env evd (evk,argsv) rhs = | l -> evd let occur_evar_upto_types sigma n c = + let c = EConstr.Unsafe.to_constr c in let seen = ref Evar.Set.empty in + (** FIXME: Is that supposed to be evar-insensitive? *) let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur | Evar (sp,args as e) -> @@ -1341,14 +1377,15 @@ let occur_evar_upto_types sigma n c = * Σ; Γ, y1..yk |- φ(u1..un) = c /\ x1..xn |- φ(x1..xn) *) -exception NotInvertibleUsingOurAlgorithm of constr +exception NotInvertibleUsingOurAlgorithm of EConstr.constr exception NotEnoughInformationToProgress of (Id.t * evar_projection) list -exception NotEnoughInformationEvarEvar of constr -exception OccurCheckIn of evar_map * constr +exception NotEnoughInformationEvarEvar of EConstr.constr +exception OccurCheckIn of evar_map * EConstr.constr exception MetaOccurInBodyInternal let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = - let aliases = make_alias_map env in + let open EConstr in + let aliases = make_alias_map env evd in let evdref = ref evd in let progress = ref false in let evi = Evd.find evd evk in @@ -1365,7 +1402,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | (id,p)::_::_ -> if choose then (mkVar id, p) else raise (NotUniqueInType sols) in - let ty = lazy (Retyping.get_type_of env !evdref (EConstr.of_constr t)) in + let ty = lazy (EConstr.of_constr (Retyping.get_type_of env !evdref t)) in let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in evdref := evd; c @@ -1377,18 +1414,18 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) let ty = find_solution_type (evar_filtered_env evi) sols in - let ty' = instantiate_evar_array evi ty argsv in + let ty' = instantiate_evar_array evi (EConstr.of_constr ty) argsv in let (evd,evar,(evk',argsv' as ev')) = materialize_evar (evar_define conv_algo ~choose) env !evdref 0 ev ty' in - let ts = expansions_of_var aliases t in - let test c = isEvar c || List.mem_f Constr.equal c ts in + let ts = expansions_of_var evd aliases t in + let test c = isEvar evd c || List.mem_f (EConstr.eq_constr evd) c ts in let filter = restrict_upon_filter evd evk test argsv' in let filter = closure_of_filter evd evk' filter in let candidates = extract_candidates sols in let evd = match candidates with | NoUpdate -> let evd, ev'' = restrict_applied_evar evd ev' filter NoUpdate in - Evd.add_conv_pb (Reduction.CONV,env,mkEvar ev'',t) evd + add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',t) evd | UpdateWith _ -> restrict_evar evd evk' filter candidates in @@ -1396,29 +1433,28 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = evar in let rec imitate (env',k as envk) t = - let t = whd_evar !evdref t in - match kind_of_term t with + match EConstr.kind !evdref t with | Rel i when i>k -> let open Context.Rel.Declaration in (match Environ.lookup_rel (i-k) env' with | LocalAssum _ -> project_variable (mkRel (i-k)) | LocalDef (_,b,_) -> try project_variable (mkRel (i-k)) - with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i b)) + with NotInvertibleUsingOurAlgorithm _ -> imitate envk (Vars.lift i (EConstr.of_constr b))) | Var id -> (match Environ.lookup_named id env' with | LocalAssum _ -> project_variable t | LocalDef (_,b,_) -> try project_variable t - with NotInvertibleUsingOurAlgorithm _ -> imitate envk b) + with NotInvertibleUsingOurAlgorithm _ -> imitate envk (EConstr.of_constr b)) | LetIn (na,b,u,c) -> - imitate envk (subst1 b c) + imitate envk (Vars.subst1 b c) | Evar (evk',args' as ev') -> if Evar.equal evk evk' then raise (OccurCheckIn (evd,rhs)); (* Evar/Evar problem (but left evar is virtual) *) let aliases = lift_aliases k aliases in (try - let ev = (evk,Array.map (lift k) argsv) in + let ev = (evk,Array.map (Vars.lift k) argsv) in let evd,body = project_evar_on_evar false conv_algo env' !evdref aliases k None ev' ev in evdref := evd; body @@ -1428,7 +1464,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = if not !progress then raise (NotEnoughInformationEvarEvar t); (* Make the virtual left evar real *) - let ty = get_type_of env' evd (EConstr.of_constr t) in + let ty = EConstr.of_constr (get_type_of env' evd t) in let (evd,evar'',ev'') = materialize_evar (evar_define conv_algo ~choose) env' evd k ev ty in (* materialize_evar may instantiate ev' by another evar; adjust it *) @@ -1437,7 +1473,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Try to project (a restriction of) the left evar ... *) try let evd,body = project_evar_on_evar false conv_algo env' evd aliases 0 None ev'' ev' in - let evd = Evd.define evk' body evd in + let evd = Evd.define evk' (EConstr.Unsafe.to_constr body) evd in check_evar_instance evd evk' body conv_algo with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) @@ -1449,9 +1485,9 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | _ -> progress := true; match - let c,args = decompose_app_vect !evdref (EConstr.of_constr t) in - match kind_of_term c with - | Construct (cstr,u) when noccur_between 1 k t -> + let c,args = decompose_app_vect !evdref t in + match EConstr.kind !evdref (EConstr.of_constr c) with + | Construct (cstr,u) when Vars.noccur_between !evdref 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) (* possible inversions; we do not treat overlap with a possible *) @@ -1462,14 +1498,13 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | _ -> None with | Some l -> - let ty = get_type_of env' !evdref (EConstr.of_constr t) in + let ty = EConstr.of_constr (get_type_of env' !evdref t) in let candidates = try - let self env c = EConstr.of_constr (imitate env (EConstr.Unsafe.to_constr c)) in let t = map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) - self envk (EConstr.of_constr t) in - EConstr.Unsafe.to_constr t::l + imitate envk t in + t::l with e when CErrors.noncritical e -> l in (match candidates with | [x] -> x @@ -1480,11 +1515,10 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = evar'') | None -> (* Evar/Rigid problem (or assimilated if not normal): we "imitate" *) - let self env c = EConstr.of_constr (imitate env (EConstr.Unsafe.to_constr c)) in - EConstr.Unsafe.to_constr (map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) - self envk (EConstr.of_constr t)) + map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) + imitate envk t in - let rhs = whd_beta evd (EConstr.of_constr rhs) (* heuristic *) in + let rhs = EConstr.of_constr (whd_beta evd rhs) (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in let names = ref Idset.empty in @@ -1493,16 +1527,16 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | (decl :: ctxt'), (c :: s') -> let id = get_id decl in names := Idset.add id !names; - isVarId id c && is_id_subst ctxt' s' + isVarId evd id c && is_id_subst ctxt' s' | [], [] -> true | _ -> false in is_id_subst filter_ctxt (Array.to_list argsv) && - closed0 rhs && - Idset.subset (collect_vars evd (EConstr.of_constr rhs)) !names + Vars.closed0 evd rhs && + Idset.subset (collect_vars evd rhs) !names in let body = - if fast rhs then nf_evar evd rhs + if fast rhs then EConstr.of_constr (EConstr.to_constr evd rhs) (** FIXME? *) else let t' = imitate (env,0) rhs in if !progress then @@ -1518,7 +1552,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = *) and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = - match kind_of_term rhs with + match EConstr.kind evd rhs with | Evar (evk2,argsv2 as ev2) -> if Evar.equal evk evk2 then solve_refl ~can_drop:choose @@ -1531,7 +1565,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = with NoCandidates -> try let (evd',body) = invert_definition conv_algo choose env evd pbty ev rhs in - if occur_meta evd' (EConstr.of_constr body) then raise MetaOccurInBodyInternal; + if occur_meta evd' body then raise MetaOccurInBodyInternal; (* invert_definition may have instantiate some evars of rhs with evk *) (* so we recheck acyclicity *) if occur_evar_upto_types evd' evk body then raise (OccurCheckIn (evd',body)); @@ -1553,23 +1587,23 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = str "----> " ++ int ev ++ str " := " ++ print_constr body); raise e in*) - let evd' = check_evar_instance evd' evk body conv_algo in + let evd' = check_evar_instance evd' evk (EConstr.of_constr body) conv_algo in Evd.define evk body evd' with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd pbty ev sols rhs | NotEnoughInformationEvarEvar t -> - add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd + add_conv_oriented_pb (pbty,env,EConstr.mkEvar ev,t) evd | MorePreciseOccurCheckNeeeded -> - add_conv_oriented_pb (pbty,env,mkEvar ev,rhs) evd + add_conv_oriented_pb (pbty,env,EConstr.mkEvar ev,rhs) evd | NotInvertibleUsingOurAlgorithm _ | MetaOccurInBodyInternal as e -> raise e | OccurCheckIn (evd,rhs) -> (* last chance: rhs actually reduces to ev *) - let c = whd_all env evd (EConstr.of_constr rhs) in - match kind_of_term c with + let c = EConstr.of_constr (whd_all env evd rhs) in + match EConstr.kind evd c with | Evar (evk',argsv2) when Evar.equal evk evk' -> - solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma (EConstr.of_constr c) (EConstr.of_constr c')) + solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c') env evd pbty evk argsv argsv2 | _ -> raise (OccurCheckIn (evd,rhs)) @@ -1610,7 +1644,7 @@ let reconsider_conv_pbs conv_algo evd = (fun p (pbty,env,t1,t2 as x) -> match p with | Success evd -> - (match conv_algo env evd pbty t1 t2 with + (match conv_algo env evd pbty (EConstr.of_constr t1) (EConstr.of_constr t2) with | Success _ as x -> x | UnifFailure (i,e) -> UnifFailure (i,CannotSolveConstraint (x,e))) | UnifFailure _ as x -> x) @@ -1624,8 +1658,9 @@ let reconsider_conv_pbs conv_algo evd = (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = + let open EConstr in try - let t2 = whd_betaiota evd t2 in (* includes whd_evar *) + let t2 = EConstr.of_constr (whd_betaiota evd t2) in (* includes whd_evar *) let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in reconsider_conv_pbs conv_algo evd with @@ -1638,5 +1673,5 @@ let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1) | IllTypedInstance (env,t,u) -> UnifFailure (evd,InstanceNotSameType (evk1,env,t,u)) | IncompatibleCandidates -> - UnifFailure (evd,ConversionFailed (env,mkEvar ev1, EConstr.Unsafe.to_constr t2)) + UnifFailure (evd,ConversionFailed (env,mkEvar ev1,t2)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index ac082d1bf8..23cb245e00 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -7,6 +7,7 @@ (************************************************************************) open Term +open EConstr open Evd open Environ @@ -41,7 +42,7 @@ val refresh_universes : (* Also refresh Prop and Set universes, so that the returned type can be any supertype of the original type *) bool option (* direction: true for levels lower than the existing levels *) -> - env -> evar_map -> types -> evar_map * types + env -> evar_map -> types -> evar_map * Constr.types val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> bool option -> existential_key -> constr array -> constr array -> evar_map @@ -52,7 +53,7 @@ val solve_evar_evar : ?force:bool -> env -> evar_map -> bool option -> existential -> existential -> evar_map val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> - bool option * existential * EConstr.t -> unification_result + bool option * existential * constr -> unification_result val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result @@ -62,7 +63,7 @@ val is_unification_pattern_evar : env -> evar_map -> existential -> constr list val is_unification_pattern : env * int -> evar_map -> constr -> constr list -> constr -> constr list option -val solve_pattern_eqn : env -> evar_map -> constr list -> constr -> constr +val solve_pattern_eqn : env -> evar_map -> constr list -> constr -> Constr.t val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool @@ -73,7 +74,7 @@ val check_evar_instance : evar_map -> existential_key -> constr -> conv_fun -> evar_map val remove_instance_local_defs : - evar_map -> existential_key -> constr array -> constr list + evar_map -> existential_key -> 'a array -> 'a list val get_type_of_refresh : - ?polyprop:bool -> ?lax:bool -> env -> evar_map -> EConstr.constr -> evar_map * types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * Constr.types diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index f28fb84ba1..c14d815054 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -13,14 +13,14 @@ open Environ open Type_errors type unification_error = - | OccurCheck of existential_key * constr - | NotClean of existential * env * constr (* Constr is a variable not in scope *) + | OccurCheck of existential_key * EConstr.constr + | NotClean of EConstr.existential * env * EConstr.constr (* Constr is a variable not in scope *) | NotSameArgSize | NotSameHead | NoCanonicalStructure - | ConversionFailed of env * constr * constr (* Non convertible closed terms *) + | ConversionFailed of env * EConstr.constr * EConstr.constr (* Non convertible closed terms *) | MetaOccurInBody of existential_key - | InstanceNotSameType of existential_key * env * types * types + | InstanceNotSameType of existential_key * env * EConstr.types * EConstr.types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error | ProblemBeyondCapabilities diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 8a6d8b6b37..217deda4d8 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -14,14 +14,14 @@ open Type_errors (** {6 The type of errors raised by the pretyper } *) type unification_error = - | OccurCheck of existential_key * constr - | NotClean of existential * env * constr + | OccurCheck of existential_key * EConstr.constr + | NotClean of EConstr.existential * env * EConstr.constr | NotSameArgSize | NotSameHead | NoCanonicalStructure - | ConversionFailed of env * constr * constr + | ConversionFailed of env * EConstr.constr * EConstr.constr | MetaOccurInBody of existential_key - | InstanceNotSameType of existential_key * env * types * types + | InstanceNotSameType of existential_key * env * EConstr.types * EConstr.types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error | ProblemBeyondCapabilities diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index b689bb7c7f..fbba682fc1 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -756,7 +756,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre refreshed right away. *) let sigma = !evdref in let c = mkApp (f,Array.map (whd_evar sigma) args) in - let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in + let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref (EConstr.of_constr c) in let t = Retyping.get_type_of env.ExtraEnv.env !evdref (EConstr.of_constr c) in make_judge c (* use this for keeping evars: resj.uj_val *) t else resj @@ -820,7 +820,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre in let t = evd_comb1 (Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) - evdref j.uj_type in + evdref (EConstr.of_constr j.uj_type) in (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) @@ -1003,7 +1003,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let tj = pretype_type empty_valcon env evdref lvar t in let tval = evd_comb1 (Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) - evdref tj.utj_val in + evdref (EConstr.of_constr tj.utj_val) in let tval = nf_evar !evdref tval in let cj, tval = match k with | VMcast -> @@ -1014,7 +1014,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if b then (evdref := evd; cj, tval) else error_actual_type ~loc env.ExtraEnv.env !evdref cj tval - (ConversionFailed (env.ExtraEnv.env,cty,tval)) + (ConversionFailed (env.ExtraEnv.env,EConstr.of_constr cty,EConstr.of_constr tval)) else user_err ~loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> @@ -1025,7 +1025,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre if b then (evdref := evd; cj, tval) else error_actual_type ~loc env.ExtraEnv.env !evdref cj tval - (ConversionFailed (env.ExtraEnv.env,cty,tval)) + (ConversionFailed (env.ExtraEnv.env,EConstr.of_constr cty,EConstr.of_constr tval)) end | _ -> pretype (mk_tycon (EConstr.of_constr tval)) env evdref lvar c, tval diff --git a/pretyping/typing.ml b/pretyping/typing.ml index db31541cd0..1dcb5f9451 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -309,7 +309,7 @@ let type_of ?(refresh=false) env evd c = let j = execute env evdref c in (* side-effect on evdref *) if refresh then - Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type + Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref (EConstr.of_constr j.uj_type) else !evdref, j.uj_type let e_type_of ?(refresh=false) env evdref c = @@ -317,7 +317,7 @@ let e_type_of ?(refresh=false) env evdref c = let j = execute env evdref c in (* side-effect on evdref *) if refresh then - let evd, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type in + let evd, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref (EConstr.of_constr j.uj_type) in let () = evdref := evd in c else j.uj_type diff --git a/pretyping/unification.ml b/pretyping/unification.ml index f282ec4f18..b8c9a93db3 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -183,7 +183,7 @@ let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) = extra assumptions added by unification to the context *) let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in - let c = solve_pattern_eqn env sigma l c in + let c = solve_pattern_eqn env sigma (List.map EConstr.of_constr l) (EConstr.of_constr c) in let pb = (Conv,TypeNotProcessed) in if noccur_between 1 nb c then sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst @@ -191,7 +191,7 @@ let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) = | Evar ev -> let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in - sigma,metasubst,(env,ev,solve_pattern_eqn env sigma l c)::evarsubst + sigma,metasubst,(env,ev,solve_pattern_eqn env sigma (List.map EConstr.of_constr l) (EConstr.of_constr c))::evarsubst | _ -> assert false let push d (env,n) = (push_rel_assum d env,n+1) @@ -841,7 +841,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb and unify_app_pattern dir curenvnb pb opt substn cM f1 l1 cN f2 l2 = let f, l, t = if dir then f1, l1, cN else f2, l2, cM in - match is_unification_pattern curenvnb sigma f (Array.to_list l) t with + match is_unification_pattern curenvnb sigma (EConstr.of_constr f) (Array.map_to_list EConstr.of_constr l) (EConstr.of_constr t) with | None -> (match kind_of_term t with | App (f',l') -> @@ -850,7 +850,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb | Proj _ -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> unify_not_same_head curenvnb pb opt substn cM cN) | Some l -> - solve_pattern_eqn_array curenvnb f l t substn + solve_pattern_eqn_array curenvnb f (List.map EConstr.Unsafe.to_constr l) t substn and unify_app (curenv, nb as curenvnb) pb opt (sigma, metas, evars as substn) cM f1 l1 cN f2 l2 = try @@ -1246,7 +1246,7 @@ let w_coerce env evd mv c = w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = - let sigma, c = refresh_universes (Some false) env sigma c in + let sigma, c = refresh_universes (Some false) env sigma (EConstr.of_constr c) in let t = get_type_of env sigma (EConstr.of_constr (nf_meta sigma c)) in let t = nf_betaiota sigma (EConstr.of_constr (nf_meta sigma t)) in unify_0 env sigma CUMUL flags t u @@ -1271,10 +1271,13 @@ let order_metas metas = (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) +let to_conv_fun f = (); fun env sigma pb c1 c2 -> + f env sigma pb (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) + let solve_simple_evar_eqn ts env evd ev rhs = - match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,EConstr.of_constr rhs) with + match solve_simple_eqn (to_conv_fun (Evarconv.evar_conv_x ts)) env evd (None,ev,EConstr.of_constr rhs) with | UnifFailure (evd,reason) -> - error_cannot_unify env evd ~reason (mkEvar ev,rhs); + error_cannot_unify env evd ~reason (EConstr.Unsafe.to_constr (EConstr.mkEvar ev),rhs); | Success evd -> Evarconv.consider_remaining_unif_problems env evd @@ -1308,14 +1311,14 @@ let w_merge env with_types flags (evd,metas,evars) = else let evd' = let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' + try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' (fst ev, Array.map EConstr.of_constr (snd ev)) rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev,rhs'') in w_merge_rec evd' metas evars' eqns | _ -> let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in let evd' = - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' + try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' (fst ev, Array.map EConstr.of_constr (snd ev)) rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'') in w_merge_rec evd' metas evars' eqns -- cgit v1.2.3 From b113f9e1ca88514cd9d94dfe90669a27689b7434 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 03:11:44 +0100 Subject: Recordops API using EConstr. --- pretyping/recordops.ml | 6 +++--- pretyping/recordops.mli | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) (limited to 'pretyping') diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 062e4a0683..f09f3221d9 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -171,7 +171,7 @@ let keep_true_projections projs kinds = let filter (p, (_, b)) = if b then Some p else None in List.map_filter filter (List.combine projs kinds) -let cs_pattern_of_constr sigma t = +let cs_pattern_of_constr t = match kind_of_term t with App (f,vargs) -> begin @@ -179,7 +179,7 @@ let cs_pattern_of_constr sigma t = with e when CErrors.noncritical e -> raise Not_found end | Rel n -> Default_cs, Some n, [] - | Prod (_,a,b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b) -> Prod_cs, None, [a; Termops.pop (EConstr.of_constr b)] + | Prod (_,a,b) when Vars.noccurn 1 b -> Prod_cs, None, [a; Vars.lift (-1) b] | Sort s -> Sort_cs (family_of_sort s), None, [] | _ -> begin @@ -217,7 +217,7 @@ let compute_canonical_projections warn (con,ind) = | Some proji_sp -> begin try - let patt, n , args = cs_pattern_of_constr Evd.empty t (** FIXME *) in + let patt, n , args = cs_pattern_of_constr t in ((ConstRef proji_sp, patt, t, n, args) :: l) with Not_found -> let con_pp = Nametab.pr_global_env Id.Set.empty (ConstRef con) diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 405963a9ca..7c0d0ec6d4 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -65,7 +65,7 @@ type obj_typ = { o_TCOMPS : constr list } (** ordered *) (** Return the form of the component of a canonical structure *) -val cs_pattern_of_constr : Evd.evar_map -> constr -> cs_pattern * int option * constr list +val cs_pattern_of_constr : constr -> cs_pattern * int option * constr list val pr_cs_pattern : cs_pattern -> Pp.std_ppcmds -- cgit v1.2.3 From b365304d32db443194b7eaadda63c784814f53f1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 03:23:13 +0100 Subject: Evarconv API using EConstr. --- pretyping/cases.ml | 13 +- pretyping/coercion.ml | 12 +- pretyping/evarconv.ml | 342 ++++++++++++++++++++++++----------------------- pretyping/evarconv.mli | 9 +- pretyping/evardefine.ml | 2 +- pretyping/evardefine.mli | 2 +- pretyping/pretyping.ml | 6 +- pretyping/typeclasses.ml | 2 +- pretyping/typing.ml | 16 +-- pretyping/unification.ml | 23 ++-- 10 files changed, 212 insertions(+), 215 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a68daf4e5d..04f50d50ed 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -78,9 +78,6 @@ let list_try_compile f l = let force_name = let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na -let to_conv_fun f = (); fun env sigma pb c1 c2 -> - f env sigma pb (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) - (************************************************************************) (* Pattern-matching compilation (Cases) *) (************************************************************************) @@ -311,7 +308,7 @@ let inh_coerce_to_ind evdref env loc ty tyi = constructor and renounce if not able to give more information *) (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) - if not (e_cumul env evdref expected_typ ty) then evdref := sigma + if not (e_cumul env evdref (EConstr.of_constr expected_typ) (EConstr.of_constr ty)) then evdref := sigma let binding_vars_of_inductive = function | NotInd _ -> [] @@ -395,7 +392,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = let current = if List.is_empty deps && isEvar typ then (* Don't insert coercions if dependent; only solve evars *) - let _ = e_cumul pb.env pb.evdref indt typ in + let _ = e_cumul pb.env pb.evdref (EConstr.of_constr indt) (EConstr.of_constr typ) in current else (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env) @@ -1639,7 +1636,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = 1 (rel_context env) in let ev' = e_new_evar env evdref ~src ty in let ev = (fst ev, Array.map EConstr.of_constr (snd ev)) in - begin match solve_simple_eqn (to_conv_fun (evar_conv_x full_transparent_state)) env !evdref (None,ev,EConstr.of_constr (substl inst ev')) with + begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,EConstr.of_constr (substl inst ev')) with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; @@ -1690,7 +1687,7 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let evd,tt = Typing.type_of extenv !evdref t in evdref := evd; (t,tt) in - let b = e_cumul env evdref tt (mkSort s) (* side effect *) in + let b = e_cumul env evdref (EConstr.of_constr tt) (EConstr.mkSort s) (* side effect *) in if not b then anomaly (Pp.str "Build_tycon: should be a type"); { uj_val = t; uj_type = tt } @@ -2083,7 +2080,7 @@ let constr_of_pat env evdref arsign pat avoid = try let env = push_rel_context sign env in evdref := the_conv_x_leq (push_rel_context sign env) - (lift (succ m) ty) (lift 1 apptype) !evdref; + (EConstr.of_constr (lift (succ m) ty)) (EConstr.of_constr (lift 1 apptype)) !evdref; let eq_t = mk_eq evdref (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index c5418d22e7..0ea6758a70 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -65,7 +65,7 @@ let apply_coercion_args env evd check isproj argl funj = | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) match kind_of_term (whd_all env evd (EConstr.of_constr typ)) with | Prod (_,c1,c2) -> - if check && not (e_cumul env evdref (Retyping.get_type_of env evd (EConstr.of_constr h)) c1) then + if check && not (e_cumul env evdref (EConstr.of_constr (Retyping.get_type_of env evd (EConstr.of_constr h))) (EConstr.of_constr c1)) then raise NoCoercion; apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") @@ -147,7 +147,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let rec coerce_unify env x y = let x = hnf env !evdref (EConstr.of_constr x) and y = hnf env !evdref (EConstr.of_constr y) in try - evdref := the_conv_x_leq env x y !evdref; + evdref := the_conv_x_leq env (EConstr.of_constr x) (EConstr.of_constr y) !evdref; None with UnableToUnify _ -> coerce' env x y and coerce' env x y : (Term.constr -> Term.constr) option = @@ -162,7 +162,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let rec aux tele typ typ' i co = if i < len then let hdx = l.(i) and hdy = l'.(i) in - try evdref := the_conv_x_leq env hdx hdy !evdref; + try evdref := the_conv_x_leq env (EConstr.of_constr hdx) (EConstr.of_constr hdy) !evdref; let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co @@ -170,7 +170,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in let _ = - try evdref := the_conv_x_leq env eqT eqT' !evdref + try evdref := the_conv_x_leq env (EConstr.of_constr eqT) (EConstr.of_constr eqT') !evdref with UnableToUnify _ -> raise NoSubtacCoercion in (* Disallow equalities on arities *) @@ -458,11 +458,11 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = | None -> evd, None, t with Not_found -> raise NoCoercion in - try (the_conv_x_leq env t' c1 evd, v') + try (the_conv_x_leq env (EConstr.of_constr t') (EConstr.of_constr c1) evd, v') with UnableToUnify _ -> raise NoCoercion let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = - try (the_conv_x_leq env t c1 evd, v) + try (the_conv_x_leq env (EConstr.of_constr t) (EConstr.of_constr c1) evd, v) with UnableToUnify (best_failed_evd,e) -> try inh_coerce_to_fail env evd rigidonly v t c1 with NoCoercion -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 8f3f671abf..c8dcb19b40 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -30,7 +30,7 @@ module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration type unify_fun = transparent_state -> - env -> evar_map -> conv_pb -> constr -> constr -> Evarsolve.unification_result + env -> evar_map -> conv_pb -> EConstr.constr -> EConstr.constr -> Evarsolve.unification_result let debug_unification = ref (false) let _ = Goptions.declare_bool_option { @@ -42,33 +42,32 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> debug_unification:=a); } -let to_conv_fun f = (); fun env sigma pb c1 c2 -> - f env sigma pb (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) - let unfold_projection env evd ts p c = + let open EConstr in let cst = Projection.constant p in if is_transparent_constant ts cst then Some (mkProj (Projection.make cst true, c)) else None let eval_flexible_term ts env evd c = - match kind_of_term c with + let open EConstr in + match EConstr.kind evd c with | Const (c,u as cu) -> if is_transparent_constant ts c - then constant_opt_value_in env cu + then Option.map EConstr.of_constr (constant_opt_value_in env cu) else None | Rel n -> (try match lookup_rel n env with | RelDecl.LocalAssum _ -> None - | RelDecl.LocalDef (_,v,_) -> Some (lift n v) + | RelDecl.LocalDef (_,v,_) -> Some (Vars.lift n (EConstr.of_constr v)) with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - env |> lookup_named id |> NamedDecl.get_value + Option.map EConstr.of_constr (env |> lookup_named id |> NamedDecl.get_value) else None with Not_found -> None) - | LetIn (_,b,_,c) -> Some (subst1 b c) + | LetIn (_,b,_,c) -> Some (Vars.subst1 b c) | Lambda _ -> Some c | Proj (p, c) -> if Projection.unfolded p then assert false @@ -77,12 +76,11 @@ let eval_flexible_term ts env evd c = type flex_kind_of_term = | Rigid - | MaybeFlexible of Constr.t (* reducible but not necessarily reduced *) - | Flexible of existential + | MaybeFlexible of EConstr.t (* reducible but not necessarily reduced *) + | Flexible of EConstr.existential let flex_kind_of_term ts env evd c sk = - let c = EConstr.Unsafe.to_constr c in - match kind_of_term c with + match EConstr.kind evd c with | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env evd c) | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c @@ -92,12 +90,13 @@ let flex_kind_of_term ts env evd c sk = | Fix _ -> Rigid (* happens when the fixpoint is partially applied *) | Cast _ | App _ | Case _ -> assert false -let zip evd (c, stk) = EConstr.Unsafe.to_constr (Stack.zip evd (c, stk)) +let add_conv_pb (pb, env, x, y) sigma = + Evd.add_conv_pb (pb, env, EConstr.Unsafe.to_constr x, EConstr.Unsafe.to_constr y) sigma let apprec_nohdbeta ts env evd c = - let (t,sk as appr) = Reductionops.whd_nored_state evd (EConstr.of_constr c, []) in + let (t,sk as appr) = Reductionops.whd_nored_state evd (c, []) in if Stack.not_purely_applicative sk - then zip evd (fst (whd_betaiota_deltazeta_for_iota_state + then Stack.zip evd (fst (whd_betaiota_deltazeta_for_iota_state ts env evd Cst_stack.empty appr)) else c @@ -106,8 +105,9 @@ let position_problem l2r = function | CUMUL -> Some l2r let occur_rigidly (evk,_ as ev) evd t = + let open EConstr in let rec aux t = - match kind_of_term (whd_evar evd t) with + match EConstr.kind evd t with | App (f, c) -> if aux f then Array.exists aux c else false | Construct _ | Ind _ | Sort _ | Meta _ | Fix _ | CoFix _ -> true | Proj (p, c) -> not (aux c) @@ -117,7 +117,7 @@ let occur_rigidly (evk,_ as ev) evd t = | Const _ -> false | Prod (_, b, t) -> ignore(aux b || aux t); true | Rel _ | Var _ -> false - | Case (_,_,c,_) -> if eq_constr (mkEvar ev) c then raise Occur else false + | Case (_,_,c,_) -> if eq_constr evd (mkEvar ev) c then raise Occur else false in try ignore(aux t); false with Occur -> true (* [check_conv_record env sigma (t1,stack1) (t2,stack2)] tries to decompose @@ -141,23 +141,22 @@ let occur_rigidly (evk,_ as ev) evd t = projection would have been reduced) *) let check_conv_record env sigma (t1,sk1) (t2,sk2) = - let t1 = EConstr.Unsafe.to_constr t1 in - let t2 = EConstr.Unsafe.to_constr t2 in - let (proji, u), arg = Universes.global_app_of_constr t1 in + let open EConstr in + let (proji, u), arg = Termops.global_app_of_constr sigma t1 in let canon_s,sk2_effective = try - match kind_of_term t2 with + match EConstr.kind sigma t2 with Prod (_,a,b) -> (* assert (l2=[]); *) - let _, a, b = destProd (Evarutil.nf_evar sigma t2) in - if EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b) then + let _, a, b = destProd sigma t2 in + if Vars.noccurn sigma 1 b then lookup_canonical_conversion (proji, Prod_cs), - (Stack.append_app [|EConstr.of_constr a;EConstr.of_constr (pop (EConstr.of_constr b))|] Stack.empty) + (Stack.append_app [|a;EConstr.of_constr (pop b)|] Stack.empty) else raise Not_found | Sort s -> lookup_canonical_conversion (proji, Sort_cs (family_of_sort s)),[] | _ -> - let c2 = global_of_constr t2 in + let c2 = global_of_constr (EConstr.to_constr sigma t2) in lookup_canonical_conversion (proji, Const_cs c2),sk2 with Not_found -> let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in @@ -165,17 +164,19 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = in let t', { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in + let us = List.map EConstr.of_constr us in + let params = List.map EConstr.of_constr params in let params1, c1, extra_args1 = match arg with | Some c -> (* A primitive projection applied to c *) - let ty = Retyping.get_type_of ~lax:true env sigma (EConstr.of_constr c) in + let ty = Retyping.get_type_of ~lax:true env sigma c in let (i,u), ind_args = try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with _ -> raise Not_found in Stack.append_app_list (List.map EConstr.of_constr ind_args) Stack.empty, c, sk1 | None -> match Stack.strip_n_app nparams sk1 with - | Some (params1, c1, extra_args1) -> params1, EConstr.Unsafe.to_constr c1, extra_args1 + | Some (params1, c1, extra_args1) -> params1, c1, extra_args1 | _ -> raise Not_found in let us2,extra_args2 = let l_us = List.length us in @@ -184,13 +185,13 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = | None -> raise Not_found | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in - let c' = subst_univs_level_constr subst c in + let c' = EConstr.of_constr (subst_univs_level_constr subst c) in let t' = subst_univs_level_constr subst t' in - let bs' = List.map (subst_univs_level_constr subst) bs in + let bs' = List.map (subst_univs_level_constr subst %> EConstr.of_constr) bs in let h, _ = decompose_app_vect sigma (EConstr.of_constr t') in - ctx',(h, t2),c',bs',(Stack.append_app_list (List.map EConstr.of_constr params) Stack.empty,params1), - (Stack.append_app_list (List.map EConstr.of_constr us) Stack.empty,us2),(extra_args1,extra_args2),c1, - (n, zip sigma (EConstr.of_constr t2,sk2)) + ctx',(EConstr.of_constr h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), + (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, + (n, Stack.zip sigma (t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -220,11 +221,10 @@ let ise_exact ise x1 x2 = | Some _, Success i -> UnifFailure (i,NotSameArgSize) let ise_array2 evd f v1 v2 = - let inj c = EConstr.Unsafe.to_constr c in let rec allrec i = function | -1 -> Success i | n -> - match f i (inj v1.(n)) (inj v2.(n)) with + match f i v1.(n) v2.(n) with | Success i' -> allrec i' (n-1) | UnifFailure _ as x -> x in let lv1 = Array.length v1 in @@ -234,14 +234,13 @@ let ise_array2 evd f v1 v2 = (* Applicative node of stack are read from the outermost to the innermost but are unified the other way. *) let rec ise_app_stack2 env f evd sk1 sk2 = - let inj = EConstr.Unsafe.to_constr in match sk1,sk2 with | Stack.App node1 :: q1, Stack.App node2 :: q2 -> let (t1,l1) = Stack.decomp_node_last node1 q1 in let (t2,l2) = Stack.decomp_node_last node2 q2 in begin match ise_app_stack2 env f evd l1 l2 with |(_,UnifFailure _) as x -> x - |x,Success i' -> x,f env i' CONV (inj t1) (inj t2) + |x,Success i' -> x,f env i' CONV t1 t2 end | _, _ -> (sk1,sk2), Success evd @@ -255,14 +254,13 @@ let push_rec_types pfix env = stacks but not the entire stacks, the first part of the answer is Some(the remaining prefixes to tackle)) *) let ise_stack2 no_app env evd f sk1 sk2 = - let inj = EConstr.Unsafe.to_constr in let rec ise_stack2 deep i sk1 sk2 = let fail x = if deep then Some (List.rev sk1, List.rev sk2), Success i else None, x in match sk1, sk2 with | [], [] -> None, Success i | Stack.Case (_,t1,c1,_)::q1, Stack.Case (_,t2,c2,_)::q2 -> - (match f env i CONV (inj t1) (inj t2) with + (match f env i CONV t1 t2 with | Success i' -> (match ise_array2 i' (fun ii -> f env ii CONV) c1 c2 with | Success i'' -> ise_stack2 true i'' q1 q2 @@ -295,7 +293,6 @@ let ise_stack2 no_app env evd f sk1 sk2 = (* Make sure that the matching suffix is the all stack *) let exact_ise_stack2 env evd f sk1 sk2 = - let inj = EConstr.Unsafe.to_constr in let rec ise_stack2 i sk1 sk2 = match sk1, sk2 with | [], [] -> Success i @@ -303,7 +300,7 @@ let exact_ise_stack2 env evd f sk1 sk2 = ise_and i [ (fun i -> ise_stack2 i q1 q2); (fun i -> ise_array2 i (fun ii -> f env ii CONV) c1 c2); - (fun i -> f env i CONV (inj t1) (inj t2))] + (fun i -> f env i CONV t1 t2)] | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -341,10 +338,10 @@ let rec evar_conv_x ts env evd pbty term1 term2 = let e = try let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) - env evd term1 term2 + env evd (EConstr.Unsafe.to_constr term1) (EConstr.Unsafe.to_constr term2) in if b then Success evd - else UnifFailure (evd, ConversionFailed (env,EConstr.of_constr term1,EConstr.of_constr term2)) + else UnifFailure (evd, ConversionFailed (env,term1,term2)) with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) in match e with @@ -361,19 +358,19 @@ let rec evar_conv_x ts env evd pbty term1 term2 = let term2 = apprec_nohdbeta (fst ts) env evd term2 in let default () = evar_eqappr_x ts env evd pbty - (whd_nored_state evd (EConstr.of_constr term1,Stack.empty), Cst_stack.empty) - (whd_nored_state evd (EConstr.of_constr term2,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (term1,Stack.empty), Cst_stack.empty) + (whd_nored_state evd (term2,Stack.empty), Cst_stack.empty) in - begin match EConstr.kind evd (EConstr.of_constr term1), EConstr.kind evd (EConstr.of_constr term2) with + begin match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar ev, _ when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env evd - (position_problem true pbty,ev, EConstr.of_constr term2) with + (match solve_simple_eqn (evar_conv_x ts) env evd + (position_problem true pbty,ev, term2) with | UnifFailure (_,OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) | _, Evar ev when Evd.is_undefined evd (fst ev) -> - (match solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env evd - (position_problem false pbty,ev, EConstr.of_constr term1) with + (match solve_simple_eqn (evar_conv_x ts) env evd + (position_problem false pbty,ev, term1) with | UnifFailure (_, OccurCheck _) -> (* Eta-expansion might apply *) default () | x -> x) @@ -382,6 +379,7 @@ let rec evar_conv_x ts env evd pbty term1 term2 = and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = + let open EConstr in let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in @@ -391,28 +389,27 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Some l1' -> (* Miller-Pfenning's patterns unification *) let t2 = EConstr.of_constr (nf_evar evd (EConstr.Unsafe.to_constr tM)) (** FIXME *) in let t2 = solve_pattern_eqn env evd l1' t2 in - solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env evd - (position_problem on_left pbty,ev, EConstr.of_constr t2) + solve_simple_eqn (evar_conv_x ts) env evd + (position_problem on_left pbty,ev,EConstr.of_constr t2) in let consume_stack on_left (termF,skF) (termO,skO) evd = - let inj = EConstr.Unsafe.to_constr in let switch f a b = if on_left then f a b else f b a in let not_only_app = Stack.not_purely_applicative skO in match switch (ise_stack2 not_only_app env evd (evar_conv_x ts)) skF skO with |Some (l,r), Success i' when on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (zip evd (termF,l)) (zip evd (termO,r)) + switch (evar_conv_x ts env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) |Some (r,l), Success i' when not on_left && (not_only_app || List.is_empty l) -> - switch (evar_conv_x ts env i' pbty) (zip evd (termF,l)) (zip evd (termO,r)) - |None, Success i' -> switch (evar_conv_x ts env i' pbty) (inj termF) (inj termO) + switch (evar_conv_x ts env i' pbty) (Stack.zip evd (termF,l)) (Stack.zip evd (termO,r)) + |None, Success i' -> switch (evar_conv_x ts env i' pbty) termF termO |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (evd,NotSameArgSize) in let eta env evd onleft sk term sk' term' = assert (match sk with [] -> true | _ -> false); - let (na,c1,c'1) = destLambda term in - let c = nf_evar evd c1 in + let (na,c1,c'1) = destLambda evd term in + let c = EConstr.to_constr evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state - (fst ts) env' evd Cst_stack.empty (EConstr.of_constr c'1, Stack.empty) in + (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in let out2 = whd_nored_state evd (Stack.zip evd (term', sk' @ [Stack.Shift 1]), Stack.append_app [|EConstr.mkRel 1|] Stack.empty), Cst_stack.empty in @@ -438,12 +435,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty match Stack.list_of_app_stack skF with | None -> quick_fail evd | Some lF -> - let tM = zip evd apprM in + let tM = Stack.zip evd apprM in miller_pfenning on_left (fun () -> if not_only_app then (* Postpone the use of an heuristic *) - switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) (zip evd apprF) tM + switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) (Stack.zip evd apprF) tM else quick_fail i) - ev lF (EConstr.of_constr tM) i + ev lF tM i and consume (termF,skF as apprF) (termM,skM as apprM) i = if not (Stack.is_empty skF && Stack.is_empty skM) then consume_stack on_left apprF apprM i @@ -487,7 +484,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let eta evd = match EConstr.kind evd termR with | Lambda _ when (* if ever problem is ill-typed: *) List.is_empty skR -> - eta env evd false skR (EConstr.Unsafe.to_constr termR) skF termF + eta env evd false skR termR skF termF | Construct u -> eta_constructor ts env evd skR u skF termF | _ -> UnifFailure (evd,NotSameHead) in @@ -495,7 +492,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | None -> ise_try evd [consume_stack on_left apprF apprR; eta] | Some lF -> - let tR = zip evd apprR in + let tR = Stack.zip evd apprR in miller_pfenning on_left (fun () -> ise_try evd @@ -503,17 +500,17 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> if not (occur_rigidly ev i tR) then let i,tF = - if isRel tR || isVar tR then + if isRel i tR || isVar i tR then (* Optimization so as to generate candidates *) - let i,ev = evar_absorb_arguments env i (fst ev, Array.map EConstr.of_constr (snd ev)) lF in + let i,ev = evar_absorb_arguments env i ev lF in i,mkEvar ev else - i,zip evd apprF in + i,Stack.zip evd apprF in switch (fun x y -> Success (add_conv_pb (pbty,env,x,y) i)) tF tR else - UnifFailure (evd,OccurCheck (fst ev,EConstr.of_constr tR)))]) - (fst ev, Array.map EConstr.of_constr (snd ev)) lF (EConstr.of_constr tR) evd + UnifFailure (evd,OccurCheck (fst ev,tR)))]) + ev lF tR evd in let app_empty = match sk1, sk2 with [], [] -> true | _ -> false in (* Evar must be undefined since we have flushed evars *) @@ -531,20 +528,20 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | None, Success i' -> (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) - let ev1' = EConstr.of_constr (whd_evar i' (mkEvar ev1)) in - if EConstr.isEvar i' ev1' then - solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env i' - (position_problem true pbty,EConstr.destEvar i' ev1', term2) + let ev1' = EConstr.of_constr (whd_evar i' (EConstr.Unsafe.to_constr (mkEvar ev1))) in + if isEvar i' ev1' then + solve_simple_eqn (evar_conv_x ts) env i' + (position_problem true pbty,destEvar i' ev1', term2) else evar_eqappr_x ts env evd pbty ((ev1', sk1), csts1) ((term2, sk2), csts2) | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) - let ev2' = EConstr.of_constr (whd_evar i' (mkEvar ev2)) in - if EConstr.isEvar i' ev2' then - solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env i' - (position_problem false pbty,EConstr.destEvar i' ev2',Stack.zip evd (term1,r)) + let ev2' = EConstr.of_constr (whd_evar i' (EConstr.Unsafe.to_constr (mkEvar ev2))) in + if isEvar i' ev2' then + solve_simple_eqn (evar_conv_x ts) env i' + (position_problem false pbty,destEvar i' ev2',Stack.zip evd (term1,r)) else evar_eqappr_x ts env evd pbty ((ev2', sk1), csts1) ((term2, sk2), csts2) @@ -552,10 +549,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) (* we now unify ?ev1 and r[?ev2] *) - let ev1' = EConstr.of_constr (whd_evar i' (mkEvar ev1)) in - if EConstr.isEvar i' ev1' then - solve_simple_eqn (to_conv_fun (evar_conv_x ts)) env i' - (position_problem true pbty,EConstr.destEvar i' ev1',Stack.zip evd (term2,r)) + let ev1' = EConstr.of_constr (whd_evar i' (EConstr.Unsafe.to_constr (mkEvar ev1))) in + if isEvar i' ev1' then + solve_simple_eqn (evar_conv_x ts) env i' + (position_problem true pbty,destEvar i' ev1',Stack.zip evd (term2,r)) else evar_eqappr_x ts env evd pbty ((ev1', sk1), csts1) ((term2, sk2), csts2) | None, (UnifFailure _ as x) -> @@ -592,9 +589,9 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty if Evar.equal sp1 sp2 then match ise_stack2 false env i (evar_conv_x ts) sk1 sk2 with |None, Success i' -> - Success (solve_refl (to_conv_fun (fun env i pbty a1 a2 -> - is_success (evar_conv_x ts env i pbty a1 a2))) - env i' (position_problem true pbty) sp1 (Array.map EConstr.of_constr al1) (Array.map EConstr.of_constr al2)) + Success (solve_refl (fun env i pbty a1 a2 -> + is_success (evar_conv_x ts env i pbty a1 a2)) + env i' (position_problem true pbty) sp1 al1 al2) |_, (UnifFailure _ as x) -> x |Some _, _ -> UnifFailure (i,NotSameArgSize) else UnifFailure (i,NotSameHead) @@ -602,13 +599,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_try evd [f1; f2] | Flexible ev1, MaybeFlexible v2 -> - flex_maybeflex true (fst ev1, Array.map EConstr.of_constr (snd ev1)) (appr1,csts1) (appr2,csts2) (EConstr.of_constr v2) + flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 | MaybeFlexible v1, Flexible ev2 -> - flex_maybeflex false (fst ev2, Array.map EConstr.of_constr (snd ev2)) (appr2,csts2) (appr1,csts1) (EConstr.of_constr v1) + flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 | MaybeFlexible v1, MaybeFlexible v2 -> begin - match kind_of_term (EConstr.Unsafe.to_constr term1), kind_of_term (EConstr.Unsafe.to_constr term2) with + match EConstr.kind evd term1, EConstr.kind evd term2 with | LetIn (na1,b1,t1,c'1), LetIn (na2,b2,t2,c'2) -> let f1 i = (* FO *) ise_and i @@ -617,14 +614,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> evar_conv_x ts env i CUMUL t2 t1)]); (fun i -> evar_conv_x ts env i CONV b1 b2); (fun i -> - let b = nf_evar i b1 in - let t = nf_evar i t1 in + let b = EConstr.to_constr i b1 in + let t = EConstr.to_constr i t1 in let na = Nameops.name_max na1 na2 in evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (EConstr.of_constr v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (EConstr.of_constr v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) in evar_eqappr_x ts env i pbty out1 out2 in ise_try evd [f1; f2] @@ -636,8 +633,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty [(fun i -> evar_conv_x ts env i CONV c c'); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] and f2 i = - let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (EConstr.of_constr v1,sk1) - and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (EConstr.of_constr v2,sk2) + let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts1 (v1,sk1) + and out2 = whd_betaiota_deltazeta_for_iota_state (fst ts) env i csts2 (v2,sk2) in evar_eqappr_x ts env i pbty out1 out2 in ise_try evd [f1; f2] @@ -645,7 +642,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Catch the p.c ~= p c' cases *) | Proj (p,c), Const (p',u) when eq_constant (Projection.constant p) p' -> let res = - try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p (EConstr.of_constr c) []))) + try Some (destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p c []))) with Retyping.RetypeError _ -> None in (match res with @@ -656,7 +653,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Const (p,u), Proj (p',c') when eq_constant p (Projection.constant p') -> let res = - try Some (EConstr.destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p' (EConstr.of_constr c') []))) + try Some (destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p' c' []))) with Retyping.RetypeError _ -> None in (match res with @@ -710,7 +707,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (EConstr.of_constr v2, applicative_stack))) in + (fst ts) env i Cst_stack.empty (v2, applicative_stack))) in let rhs_is_already_stuck = rhs_is_already_stuck || rhs_is_stuck_and_unnamed () in @@ -718,12 +715,12 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty && (not (Stack.not_purely_applicative sk1)) then evar_eqappr_x ~rhs_is_already_stuck ts env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (EConstr.of_constr v1,sk1)) + (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) (appr2,csts2) else evar_eqappr_x ts env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (EConstr.of_constr v2,sk2)) + (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f1; f2; f3] end @@ -731,14 +728,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Rigid, Rigid when EConstr.isLambda evd term1 && EConstr.isLambda evd term2 -> let (na1,c1,c'1) = EConstr.destLambda evd term1 in let (na2,c2,c'2) = EConstr.destLambda evd term2 in - let inj = EConstr.Unsafe.to_constr in assert app_empty; ise_and evd - [(fun i -> evar_conv_x ts env i CONV (inj c1) (inj c2)); + [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> - let c = nf_evar i (inj c1) in + let c = EConstr.to_constr i c1 in let na = Nameops.name_max na1 na2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV (inj c'1) (inj c'2))] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 @@ -752,7 +748,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty and f4 i = evar_eqappr_x ts env i pbty (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term1 csts1) (EConstr.of_constr v1,sk1)) + (fst ts) env i (Cst_stack.add_cst term1 csts1) (v1,sk1)) (appr2,csts2) in ise_try evd [f3; f4] @@ -766,19 +762,18 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty and f4 i = evar_eqappr_x ts env i pbty (appr1,csts1) (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i (Cst_stack.add_cst term2 csts2) (EConstr.of_constr v2,sk2)) + (fst ts) env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f3; f4] (* Eta-expansion *) - | Rigid, _ when EConstr.isLambda evd term1 && (* if ever ill-typed: *) List.is_empty sk1 -> - eta env evd true sk1 (EConstr.Unsafe.to_constr term1) sk2 term2 + | Rigid, _ when isLambda evd term1 && (* if ever ill-typed: *) List.is_empty sk1 -> + eta env evd true sk1 term1 sk2 term2 - | _, Rigid when EConstr.isLambda evd term2 && (* if ever ill-typed: *) List.is_empty sk2 -> - eta env evd false sk2 (EConstr.Unsafe.to_constr term2) sk1 term1 + | _, Rigid when isLambda evd term2 && (* if ever ill-typed: *) List.is_empty sk2 -> + eta env evd false sk2 term2 sk1 term1 | Rigid, Rigid -> begin - let inj = EConstr.Unsafe.to_constr in match EConstr.kind evd term1, EConstr.kind evd term2 with | Sort s1, Sort s2 when app_empty -> @@ -794,11 +789,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Prod (n1,c1,c'1), Prod (n2,c2,c'2) when app_empty -> ise_and evd - [(fun i -> evar_conv_x ts env i CONV (inj c1) (inj c2)); + [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> - let c = nf_evar i (inj c1) in + let c = EConstr.to_constr i c1 in let na = Nameops.name_max n1 n2 in - evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty (inj c'1) (inj c'2))] + evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] | Rel x1, Rel x2 -> if Int.equal x1 x2 then @@ -842,11 +837,10 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else UnifFailure (evd,NotSameHead) | (Meta _, _) | (_, Meta _) -> - let inj = EConstr.Unsafe.to_constr in begin match ise_stack2 true env evd (evar_conv_x ts) sk1 sk2 with |_, (UnifFailure _ as x) -> x - |None, Success i' -> evar_conv_x ts env i' CONV (inj term1) (inj term2) - |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (inj (Stack.zip i' (term1,sk1'))) (inj (Stack.zip i' (term2,sk2'))) + |None, Success i' -> evar_conv_x ts env i' CONV term1 term2 + |Some (sk1',sk2'), Success i' -> evar_conv_x ts env i' CONV (Stack.zip i' (term1,sk1')) (Stack.zip i' (term2,sk2')) end | (Ind _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _), _ -> @@ -884,38 +878,39 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) had to be initially resolved *) + let open EConstr in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape sk1 sk2 then let (evd',ks,_,test) = List.fold_left (fun (i,ks,m,test) b -> if match n with Some n -> Int.equal m n | None -> false then - let ty = Retyping.get_type_of env i (EConstr.of_constr t2) in - let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in + let ty = EConstr.of_constr (Retyping.get_type_of env i t2) in + let test i = evar_conv_x trs env i CUMUL ty (Vars.substl ks b) in (i,t2::ks, m-1, test) else let dloc = (Loc.ghost,Evar_kinds.InternalHole) in let i = Sigma.Unsafe.of_evar_map i in - let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in + let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (EConstr.Unsafe.to_constr (Vars.substl ks b)) in let i' = Sigma.to_evar_map i' in - (i', ev :: ks, m - 1,test)) + (i', EConstr.of_constr ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in let app = mkApp (c, Array.rev_of_list ks) in ise_and evd' [(fun i -> exact_ise_stack2 env i - (fun env' i' cpb x1 x -> evar_conv_x trs env' i' cpb x1 (substl ks x)) + (fun env' i' cpb x1 x -> evar_conv_x trs env' i' cpb x1 (Vars.substl ks x)) params1 params); (fun i -> exact_ise_stack2 env i - (fun env' i' cpb u1 u -> evar_conv_x trs env' i' cpb u1 (substl ks u)) + (fun env' i' cpb u1 u -> evar_conv_x trs env' i' cpb u1 (Vars.substl ks u)) us2 us); (fun i -> evar_conv_x trs env i CONV c1 app); (fun i -> exact_ise_stack2 env i (evar_conv_x trs) sk1 sk2); test; (fun i -> evar_conv_x trs env i CONV h2 - (fst (decompose_app_vect i (EConstr.of_constr (substl ks h)))))] + (EConstr.of_constr (fst (decompose_app_vect i (Vars.substl ks h)))))] else UnifFailure(evd,(*dummy*)NotSameHead) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = @@ -956,66 +951,69 @@ let set_evar_conv f = Hook.set evar_conv_hook_set f (* We assume here |l1| <= |l2| *) let first_order_unification ts env evd (ev1,l1) (term2,l2) = + let open EConstr in let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in ise_and evd (* First compare extra args for better failure message *) - [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) (Array.map EConstr.of_constr rest2) (Array.map EConstr.of_constr l1)); + [(fun i -> ise_array2 i (fun i -> evar_conv_x ts env i CONV) rest2 l1); (fun i -> (* Then instantiate evar unless already done by unifying args *) let t2 = mkApp(term2,deb2) in if is_defined i (fst ev1) then evar_conv_x ts env i CONV t2 (mkEvar ev1) else - let ev1 = (fst ev1, Array.map EConstr.of_constr (snd ev1)) in - solve_simple_eqn ~choose:true (to_conv_fun (evar_conv_x ts)) env i (None,ev1, EConstr.of_constr t2))] + solve_simple_eqn ~choose:true (evar_conv_x ts) env i (None,ev1,t2))] let choose_less_dependent_instance evk evd term args = let evi = Evd.find_undefined evd evk in let subst = make_pure_subst evi args in - let subst' = List.filter (fun (id,c) -> Term.eq_constr c term) subst in + let subst' = List.filter (fun (id,c) -> EConstr.eq_constr evd c term) subst in match subst' with | [] -> None - | (id, _) :: _ -> Some (Evd.define evk (mkVar id) evd) + | (id, _) :: _ -> Some (Evd.define evk (Constr.mkVar id) evd) let apply_on_subterm env evdref f c t = + let open EConstr in let rec applyrec (env,(k,c) as acc) t = (* By using eq_constr, we make an approximation, for instance, we *) (* could also be interested in finding a term u convertible to t *) (* such that c occurs in u *) - if e_eq_constr_univs evdref c t then f k + if e_eq_constr_univs evdref (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr t) then f k else - match kind_of_term t with - | Evar (evk,args) when Evd.is_undefined !evdref evk -> + match EConstr.kind !evdref t with + | Evar (evk,args) -> let ctx = evar_filtered_context (Evd.find_undefined !evdref evk) in let g decl a = if is_local_assum decl then applyrec acc a else a in mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) | _ -> - map_constr_with_binders_left_to_right - (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) - applyrec acc t + let self acc c = EConstr.Unsafe.to_constr (applyrec acc (EConstr.of_constr c)) in + EConstr.of_constr (map_constr_with_binders_left_to_right + (fun d (env,(k,c)) -> (push_rel d env, (k+1,Vars.lift 1 c))) + self acc (EConstr.Unsafe.to_constr t)) in applyrec (env,(0,c)) t let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the fv of args to have a well-typed filter; don't know how necessary - it is however to have a well-typed filter here *) - let fv1 = free_rels evd (EConstr.of_constr (mkApp (c,args))) (* Hack: locally untyped *) in - let fv2 = collect_vars evd (EConstr.of_constr (mkApp (c,args))) in + it is however to have a well-typed filter here *) + let open EConstr in + let fv1 = free_rels evd (mkApp (c,args)) (* Hack: locally untyped *) in + let fv2 = collect_vars evd (mkApp (c,args)) in let len = Array.length args in - let tyvars = collect_vars evd (EConstr.of_constr ty) in + let tyvars = collect_vars evd ty in List.map_i (fun i decl -> let () = assert (i < len) in let a = Array.unsafe_get args i in (match decl with | NamedDecl.LocalAssum _ -> false - | NamedDecl.LocalDef (_,c,_) -> not (isRel c || isVar c)) || + | NamedDecl.LocalDef (_,c,_) -> not (isRel evd (EConstr.of_constr c) || isVar evd (EConstr.of_constr c))) || a == c || (* Here we make an approximation, for instance, we could also be *) (* interested in finding a term u convertible to c such that a occurs *) (* in u *) - isRel a && Int.Set.mem (destRel a) fv1 || - isVar a && Id.Set.mem (destVar a) fv2 || + isRel evd a && Int.Set.mem (destRel evd a) fv1 || + isVar evd a && Id.Set.mem (destVar evd a) fv2 || Id.Set.mem (NamedDecl.get_id decl) tyvars) 0 ctxt @@ -1042,6 +1040,7 @@ let set_solve_evars f = solve_evars := f exception TypingFailed of evar_map let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = + let open EConstr in try let evi = Evd.find_undefined evd evk in let env_evar = evar_filtered_env evi in @@ -1050,7 +1049,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let instance = List.map mkVar (List.map NamedDecl.get_id ctxt) in let rec make_subst = function - | decl'::ctxt', c::l, occs::occsl when isVarId (NamedDecl.get_id decl') c -> + | decl'::ctxt', c::l, occs::occsl when isVarId evd (NamedDecl.get_id decl') c -> begin match occs with | Some _ -> error "Cannot force abstraction on identity instance." @@ -1059,9 +1058,9 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = end | decl'::ctxt', c::l, occs::occsl -> let id = NamedDecl.get_id decl' in - let t = NamedDecl.get_type decl' in + let t = EConstr.of_constr (NamedDecl.get_type decl') in let evs = ref [] in - let ty = Retyping.get_type_of env_rhs evd (EConstr.of_constr c) in + let ty = EConstr.of_constr (Retyping.get_type_of env_rhs evd c) in let filter' = filter_possible_projections evd c ty ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) | _, _, [] -> [] @@ -1075,13 +1074,13 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | Some _ -> error "Selection of specific occurrences not supported" | None -> let evty = set_holes evdref cty subst in - let instance = Filter.filter_list filter instance in + let instance = List.map EConstr.Unsafe.to_constr (Filter.filter_list filter instance) in let evd = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in + let Sigma (ev, evd, _) = new_evar_instance sign evd (EConstr.Unsafe.to_constr evty) ~filter instance in let evd = Sigma.to_evar_map evd in evdref := evd; - evsref := (fst (destEvar ev),evty)::!evsref; - ev in + evsref := (fst (destEvar !evdref (EConstr.of_constr ev)),evty)::!evsref; + EConstr.of_constr ev in set_holes evdref (apply_on_subterm env_rhs evdref set_var c rhs) subst | [] -> rhs in @@ -1108,11 +1107,11 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = (* We force abstraction over this unconstrained occurrence *) (* and we use typing to propagate this instantiation *) (* This is an arbitrary choice *) - let evd = Evd.define evk (mkVar id) evd in + let evd = Evd.define evk (Constr.mkVar id) evd in match evar_conv_x ts env_evar evd CUMUL idty evty with | UnifFailure _ -> error "Cannot find an instance" | Success evd -> - match reconsider_conv_pbs (to_conv_fun (evar_conv_x ts)) evd with + match reconsider_conv_pbs (evar_conv_x ts) evd with | UnifFailure _ -> error "Cannot find an instance" | Success evd -> evd @@ -1126,16 +1125,20 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = force_instantiation evd !evsref | [] -> let evd = - try Evarsolve.check_evar_instance evd evk (EConstr.of_constr rhs) - (to_conv_fun (evar_conv_x full_transparent_state)) + try Evarsolve.check_evar_instance evd evk rhs + (evar_conv_x full_transparent_state) with IllTypedInstance _ -> raise (TypingFailed evd) in - Evd.define evk rhs evd + Evd.define evk (EConstr.Unsafe.to_constr rhs) evd in abstract_free_holes evd subst, true with TypingFailed evd -> evd, false +let to_pb (pb, env, t1, t2) = + (pb, env, EConstr.Unsafe.to_constr t1, EConstr.Unsafe.to_constr t2) + let second_order_matching_with_args ts env evd pbty ev l t = + let open EConstr in (* let evd,ev = evar_absorb_arguments env evd ev l in let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in @@ -1144,18 +1147,19 @@ let second_order_matching_with_args ts env evd pbty ev l t = else UnifFailure (evd, ConversionFailed (env,mkApp(mkEvar ev,l),t)) if b then Success evd else *) - let pb = (pbty,env,mkApp(mkEvar ev,l),t) in + let pb = to_pb (pbty,env,mkApp(mkEvar ev,l),t) in UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = + let open EConstr in let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in - let (term1,l1 as appr1) = try destApp t1 with DestKO -> (t1, [||]) in - let (term2,l2 as appr2) = try destApp t2 with DestKO -> (t2, [||]) in + let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in + let (term2,l2 as appr2) = try destApp evd t2 with DestKO -> (t2, [||]) in let app_empty = Array.is_empty l1 && Array.is_empty l2 in - match kind_of_term term1, kind_of_term term2 with + match EConstr.kind evd term1, EConstr.kind evd term2 with | Evar (evk1,args1), (Rel _|Var _) when app_empty - && List.for_all (fun a -> Term.eq_constr a term2 || isEvar a) + && List.for_all (fun a -> EConstr.eq_constr evd a term2 || isEvar evd a) (remove_instance_local_defs evd evk1 args1) -> (* The typical kind of constraint coming from pattern-matching return type inference *) @@ -1163,9 +1167,9 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | Some evd -> Success evd | None -> let reason = ProblemBeyondCapabilities in - UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) + UnifFailure (evd, CannotSolveConstraint (to_pb (pbty,env,t1,t2),reason))) | (Rel _|Var _), Evar (evk2,args2) when app_empty - && List.for_all (fun a -> Term.eq_constr a term1 || isEvar a) + && List.for_all (fun a -> EConstr.eq_constr evd a term1 || isEvar evd a) (remove_instance_local_defs evd evk2 args2) -> (* The typical kind of constraint coming from pattern-matching return type inference *) @@ -1173,16 +1177,14 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = | Some evd -> Success evd | None -> let reason = ProblemBeyondCapabilities in - UnifFailure (evd, CannotSolveConstraint ((pbty,env,t1,t2),reason))) + UnifFailure (evd, CannotSolveConstraint (to_pb (pbty,env,t1,t2),reason))) | Evar (evk1,args1), Evar (evk2,args2) when Evar.equal evk1 evk2 -> - let f env evd pbty x y = is_fconv ~reds:ts pbty env evd (EConstr.of_constr x) (EConstr.of_constr y) in - Success (solve_refl ~can_drop:true (to_conv_fun f) env evd - (position_problem true pbty) evk1 (Array.map EConstr.of_constr args1) (Array.map EConstr.of_constr args2)) + let f env evd pbty x y = is_fconv ~reds:ts pbty env evd x y in + Success (solve_refl ~can_drop:true f env evd + (position_problem true pbty) evk1 args1 args2) | Evar ev1, Evar ev2 when app_empty -> - let ev1 = (fst ev1, Array.map EConstr.of_constr (snd ev1)) in - let ev2 = (fst ev2, Array.map EConstr.of_constr (snd ev2)) in Success (solve_evar_evar ~force:true - (evar_define (to_conv_fun (evar_conv_x ts)) ~choose:true) (to_conv_fun (evar_conv_x ts)) env evd + (evar_define (evar_conv_x ts) ~choose:true) (evar_conv_x ts) env evd (position_problem true pbty) ev1 ev2) | Evar ev1,_ when Array.length l1 <= Array.length l2 -> (* On "?n t1 .. tn = u u1 .. u(n+p)", try first-order unification *) @@ -1244,9 +1246,9 @@ let rec solve_unconstrained_evars_with_candidates ts evd = | a::l -> try let conv_algo = evar_conv_x ts in - let evd = check_evar_instance evd evk (EConstr.of_constr a) (to_conv_fun conv_algo) in + let evd = check_evar_instance evd evk (EConstr.of_constr a) conv_algo in let evd = Evd.define evk a evd in - match reconsider_conv_pbs (to_conv_fun conv_algo) evd with + match reconsider_conv_pbs conv_algo evd with | Success evd -> solve_unconstrained_evars_with_candidates ts evd | UnifFailure _ -> aux l with @@ -1265,7 +1267,7 @@ let solve_unconstrained_impossible_cases env evd = let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc evd' ctx in let ty = j_type j in let conv_algo = evar_conv_x full_transparent_state in - let evd' = check_evar_instance evd' evk (EConstr.of_constr ty) (to_conv_fun conv_algo) in + let evd' = check_evar_instance evd' evk (EConstr.of_constr ty) conv_algo in Evd.define evk ty evd' | _ -> evd') evd evd @@ -1275,7 +1277,7 @@ let consider_remaining_unif_problems env let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> - (match apply_conversion_problem_heuristic ts env evd pbty t1 t2 with + (match apply_conversion_problem_heuristic ts env evd pbty (EConstr.of_constr t1) (EConstr.of_constr t2) with | Success evd' -> let (evd', rest) = extract_all_conv_pbs evd' in begin match rest with diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 6f736e562d..a0ff924efe 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Environ open Reductionops open Evd @@ -45,16 +46,16 @@ val check_problems_are_solved : env -> evar_map -> unit val check_conv_record : env -> evar_map -> state -> state -> Univ.universe_context_set * (constr * constr) - * constr * constr list * (EConstr.t Stack.t * EConstr.t Stack.t) * - (EConstr.t Stack.t * EConstr.t Stack.t) * - (EConstr.t Stack.t * EConstr.t Stack.t) * constr * + * constr * constr list * (constr Stack.t * constr Stack.t) * + (constr Stack.t * constr Stack.t) * + (constr Stack.t * constr Stack.t) * constr * (int option * constr) (** Try to solve problems of the form ?x[args] = c by second-order matching, using typing to select occurrences *) val second_order_matching : transparent_state -> env -> evar_map -> - existential -> occurrences option list -> constr -> evar_map * bool + EConstr.existential -> occurrences option list -> constr -> evar_map * bool (** Declare function to enforce evars resolution by using typing constraints *) diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 8026ff3e4f..f372dbf066 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -160,7 +160,7 @@ let define_evar_as_lambda env evd (evk,args) = evd, mkLambda (na, dom, evbody) let rec evar_absorb_arguments env evd (evk,args as ev) = function - | [] -> evd, (evk, Array.map EConstr.Unsafe.to_constr args) + | [] -> evd,ev | a::l -> let open EConstr in (* TODO: optimize and avoid introducing intermediate evars *) diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index f6d0efba62..f7bf4636b9 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -27,7 +27,7 @@ val mk_valcon : EConstr.constr -> val_constraint [?y[vars1:=args1,vars:=args]] with [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) val evar_absorb_arguments : env -> evar_map -> EConstr.existential -> EConstr.constr list -> - evar_map * existential + evar_map * EConstr.existential val split_tycon : Loc.t -> env -> evar_map -> type_constraint -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index fbba682fc1..570f95324a 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -626,7 +626,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fixi = match fixkind with | GFix (vn,i) -> i | GCoFix i -> i - in e_conv env.ExtraEnv.env evdref ftys.(fixi) t + in e_conv env.ExtraEnv.env evdref (EConstr.of_constr ftys.(fixi)) (EConstr.of_constr t) | None -> true in (* Note: bodies are not used by push_rec_types, so [||] is safe *) @@ -732,7 +732,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match candargs with | [] -> [], j_val hj | arg :: args -> - if e_conv env.ExtraEnv.env evdref (j_val hj) arg then + if e_conv env.ExtraEnv.env evdref (EConstr.of_constr (j_val hj)) (EConstr.of_constr arg) then args, nf_evar !evdref (j_val hj) else [], j_val hj in @@ -1088,7 +1088,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function match valcon with | None -> tj | Some v -> - if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj + if e_cumul env.ExtraEnv.env evdref (EConstr.of_constr v) (EConstr.of_constr tj.utj_val) then tj else error_unexpected_type ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 8c03329e24..11f71ee023 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -165,7 +165,7 @@ let rec is_class_type evd c = match kind_of_term c with | Prod (_, _, t) -> is_class_type evd t | Evar (e, _) when Evd.is_defined evd e -> - is_class_type evd (Evarutil.whd_head_evar evd c) + is_class_type evd (EConstr.Unsafe.to_constr (Evarutil.whd_head_evar evd (EConstr.of_constr c))) | _ -> is_class_constr c let is_class_evar evd evi = diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 1dcb5f9451..64264cf087 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -57,7 +57,7 @@ let e_judge_of_apply env evdref funj argjv = | hj::restjl -> match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref typ)) with | Prod (_,c1,c2) -> - if Evarconv.e_cumul env evdref hj.uj_type (EConstr.Unsafe.to_constr c1) then + if Evarconv.e_cumul env evdref (EConstr.of_constr hj.uj_type) c1 then apply_rec (n+1) (Vars.subst1 (EConstr.of_constr hj.uj_val) c2) restjl else error_cant_apply_bad_type env (n, EConstr.Unsafe.to_constr c1, hj.uj_type) funj argjv @@ -75,7 +75,7 @@ let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then error_number_branches env cj (Array.length explft); for i = 0 to Array.length explft - 1 do - if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then + if not (Evarconv.e_cumul env evdref (EConstr.of_constr lfj.(i).uj_type) (EConstr.of_constr explft.(i))) then error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) done @@ -91,7 +91,7 @@ let e_is_correct_arity env evdref c pj ind specif params = let pt' = whd_all env !evdref (EConstr.of_constr pt) in match kind_of_term pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> - if not (Evarconv.e_cumul env evdref a1 a1') then error (); + if not (Evarconv.e_cumul env evdref (EConstr.of_constr a1) (EConstr.of_constr a1')) then error (); srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Sort s, [] -> if not (Sorts.List.mem (Sorts.family s) allowed_sorts) @@ -131,8 +131,8 @@ let check_type_fixpoint loc env evdref lna lar vdefj = let lt = Array.length vdefj in if Int.equal (Array.length lar) lt then for i = 0 to lt-1 do - if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type - (lift lt lar.(i))) then + if not (Evarconv.e_cumul env evdref (EConstr.of_constr (vdefj.(i)).uj_type) + (EConstr.of_constr (lift lt lar.(i)))) then Pretype_errors.error_ill_typed_rec_body ~loc env !evdref i lna vdefj lar done @@ -150,7 +150,7 @@ let check_allowed_sort env sigma ind c p = let e_judge_of_cast env evdref cj k tj = let expected_type = tj.utj_val in - if not (Evarconv.e_cumul env evdref cj.uj_type expected_type) then + if not (Evarconv.e_cumul env evdref (EConstr.of_constr cj.uj_type) (EConstr.of_constr expected_type)) then error_actual_type env cj expected_type; { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } @@ -282,7 +282,7 @@ and execute_array env evdref = Array.map (execute env evdref) let e_check env evdref c t = let env = enrich_env env evdref in let j = execute env evdref c in - if not (Evarconv.e_cumul env evdref j.uj_type t) then + if not (Evarconv.e_cumul env evdref (EConstr.of_constr j.uj_type) (EConstr.of_constr t)) then error_actual_type env j (nf_evar !evdref t) (* Type of a constr *) @@ -328,4 +328,4 @@ let e_solve_evars env evdref c = (* side-effect on evdref *) nf_evar !evdref c -let _ = Evarconv.set_solve_evars e_solve_evars +let _ = Evarconv.set_solve_evars (fun env evdref c -> EConstr.of_constr (e_solve_evars env evdref (EConstr.Unsafe.to_constr c))) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index b8c9a93db3..ac2f140519 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -123,7 +123,7 @@ let abstract_list_all_with_dependencies env evd typ c l = let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = Evarconv.second_order_matching empty_transparent_state - env evd ev' argoccs c in + env evd ev' argoccs (EConstr.of_constr c) in if b then let p = nf_evar evd ev in evd, p @@ -607,7 +607,7 @@ let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN = match subst_defined_metas_evars (metasubst,[]) tyN with | None -> sigma | Some n -> - if is_ground_term sigma m && is_ground_term sigma n then + if is_ground_term sigma (EConstr.of_constr m) && is_ground_term sigma (EConstr.of_constr n) then let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n in if b then sigma else error_cannot_unify env sigma (m,n) @@ -659,8 +659,8 @@ let eta_constructor_app env f l1 term = let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n = let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn) curm curn = - let cM = Evarutil.whd_head_evar sigma curm - and cN = Evarutil.whd_head_evar sigma curn in + let cM = EConstr.Unsafe.to_constr (Evarutil.whd_head_evar sigma (EConstr.of_constr curm)) + and cN = EConstr.Unsafe.to_constr (Evarutil.whd_head_evar sigma (EConstr.of_constr curn)) in let () = if !debug_unification then Feedback.msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN) @@ -964,7 +964,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in if b then Some (sigma, metasubst, evarsubst) else - if is_ground_term sigma m1 && is_ground_term sigma n1 then + if is_ground_term sigma (EConstr.of_constr m1) && is_ground_term sigma (EConstr.of_constr n1) then error_cannot_unify curenv sigma (cM,cN) else None in @@ -1036,12 +1036,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb List.fold_left (fun (evd,ks,m) b -> if match n with Some n -> Int.equal m n | None -> false then - (evd,t2::ks, m-1) + (evd,EConstr.Unsafe.to_constr t2::ks, m-1) else let mv = new_meta () in let evd' = meta_declare mv (substl ks b) evd in (evd', mkMeta mv :: ks, m - 1)) - (sigma,[],List.length bs) bs + (sigma,[],List.length bs) (List.map EConstr.Unsafe.to_constr bs) in try let opt' = {opt with with_types = false} in @@ -1053,9 +1053,9 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb (fun s u1 u -> unirec_rec curenvnb pb opt' s (inj u1) (substl ks (inj u))) substn params1 params in let (substn,_,_) = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s (inj u1) (inj u2)) substn ts ts1 in - let app = mkApp (c, Array.rev_of_list ks) in + let app = mkApp (EConstr.Unsafe.to_constr c, Array.rev_of_list ks) in (* let substn = unirec_rec curenvnb pb b false substn t cN in *) - unirec_rec curenvnb pb opt' substn c1 app + unirec_rec curenvnb pb opt' substn (EConstr.Unsafe.to_constr c1) app with Invalid_argument "Reductionops.Stack.fold2" -> error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1271,11 +1271,8 @@ let order_metas metas = (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) -let to_conv_fun f = (); fun env sigma pb c1 c2 -> - f env sigma pb (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) - let solve_simple_evar_eqn ts env evd ev rhs = - match solve_simple_eqn (to_conv_fun (Evarconv.evar_conv_x ts)) env evd (None,ev,EConstr.of_constr rhs) with + match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,EConstr.of_constr rhs) with | UnifFailure (evd,reason) -> error_cannot_unify env evd ~reason (EConstr.Unsafe.to_constr (EConstr.mkEvar ev),rhs); | Success evd -> -- cgit v1.2.3 From e27949240f5b1ee212e7d0fe3326a21a13c4abb0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 17:21:44 +0100 Subject: Typing API using EConstr. --- pretyping/cases.ml | 10 +++--- pretyping/coercion.ml | 12 ++++---- pretyping/pretyping.ml | 10 +++--- pretyping/tacred.ml | 2 +- pretyping/typing.ml | 80 ++++++++++++++++++++++++++++++------------------ pretyping/typing.mli | 16 +++++----- pretyping/unification.ml | 4 +-- 7 files changed, 78 insertions(+), 56 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 04f50d50ed..882c052f60 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1381,7 +1381,7 @@ and match_current pb (initial,tomatch) = let case = make_case_or_project pb.env indf ci pred current brvals in - Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; + Typing.check_allowed_sort pb.env !(pb.evdref) mind (EConstr.of_constr current) (EConstr.of_constr pred); { uj_val = applist (case, inst); uj_type = prod_applist typ inst } @@ -1684,7 +1684,7 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in - let evd,tt = Typing.type_of extenv !evdref t in + let evd,tt = Typing.type_of extenv !evdref (EConstr.of_constr t) in evdref := evd; (t,tt) in let b = e_cumul env evdref (EConstr.of_constr tt) (EConstr.mkSort s) (* side effect *) in @@ -1920,7 +1920,7 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = assert (len == 0); let p = predicate 0 c in let env' = List.fold_right push_rel_context arsign env in - try let sigma' = fst (Typing.type_of env' sigma p) in + try let sigma' = fst (Typing.type_of env' sigma (EConstr.of_constr p)) in Some (sigma', p) with e when precatchable_exception e -> None @@ -2041,7 +2041,7 @@ let constr_of_pat env evdref arsign pat avoid = let IndType (indf, _) = try find_rectype env ( !evdref) (EConstr.of_constr (lift (-(List.length realargs)) ty)) with Not_found -> error_case_not_inductive env !evdref - {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} + {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref (EConstr.of_constr ty)} in let (ind,u), params = dest_ind_family indf in if not (eq_ind ind cind) then error_bad_constructor ~loc:l env cstr ind; @@ -2242,7 +2242,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = let j = typing_fun (mk_tycon (EConstr.of_constr tycon)) rhs_env eqn.rhs.it in let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in - let _btype = evd_comb1 (Typing.type_of env) evdref bbody in + let _btype = evd_comb1 (Typing.type_of env) evdref (EConstr.of_constr bbody) in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 0ea6758a70..04e235cc53 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -188,7 +188,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some (fun x -> - let term = co x in + let term = EConstr.of_constr (co x) in Typing.e_solve_evars env evdref term) in if isEvar c || isEvar c' || not (Program.is_program_generalized_coercion ()) then @@ -297,16 +297,16 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let evm = !evdref in (try subco () with NoSubtacCoercion -> - let typ = Typing.unsafe_type_of env evm c in - let typ' = Typing.unsafe_type_of env evm c' in + let typ = Typing.unsafe_type_of env evm (EConstr.of_constr c) in + let typ' = Typing.unsafe_type_of env evm (EConstr.of_constr c') in coerce_application typ typ' c c' l l') else subco () | x, y when Constr.equal c c' -> if Int.equal (Array.length l) (Array.length l') then let evm = !evdref in - let lam_type = Typing.unsafe_type_of env evm c in - let lam_type' = Typing.unsafe_type_of env evm c' in + let lam_type = Typing.unsafe_type_of env evm (EConstr.of_constr c) in + let lam_type' = Typing.unsafe_type_of env evm (EConstr.of_constr c') in coerce_application lam_type lam_type' c c' l l' else subco () | _ -> subco ()) @@ -337,7 +337,7 @@ let app_coercion env evdref coercion v = match coercion with | None -> v | Some f -> - let v' = Typing.e_solve_evars env evdref (f v) in + let v' = Typing.e_solve_evars env evdref (EConstr.of_constr (f v)) in whd_betaiota !evdref (EConstr.of_constr v') let coerce_itf loc env evd v t c1 = diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 570f95324a..28ba60812b 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -507,7 +507,7 @@ let pretype_ref loc evdref env ref us = | ref -> let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in - let ty = Typing.unsafe_type_of env.ExtraEnv.env evd c in + let ty = Typing.unsafe_type_of env.ExtraEnv.env evd (EConstr.of_constr c) in make_judge c ty let judge_of_Type loc evd s = @@ -644,7 +644,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in - Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names ftys vdefj; + Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names (Array.map EConstr.of_constr ftys) vdefj; let ftys = Array.map (nf_evar !evdref) ftys in let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in let fixj = match fixkind with @@ -898,7 +898,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fj = pretype (mk_tycon (EConstr.of_constr fty)) env_f evdref lvar d in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) (EConstr.of_constr p); obj ind p cj.uj_val fj.uj_val in { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } @@ -917,7 +917,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) (EConstr.of_constr p); obj ind p cj.uj_val fj.uj_val in { uj_val = v; uj_type = ccl }) @@ -981,7 +981,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let ind,_ = dest_ind_family indf in let ci = make_case_info env.ExtraEnv.env (fst ind) IfStyle in let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val pred; + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) (EConstr.of_constr pred); mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in let cj = { uj_val = v; uj_type = p } in diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 290d77b1b3..a3983737d2 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1164,7 +1164,7 @@ let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> let sigma = Sigma.to_evar_map sigma in let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (EConstr.Unsafe.to_constr c,sigma) in try - let _ = Typing.unsafe_type_of env sigma abstr_trm in + let _ = Typing.unsafe_type_of env sigma (EConstr.of_constr abstr_trm) in Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 64264cf087..c948f9b9a7 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -20,6 +20,11 @@ open Typeops open Arguments_renaming open Context.Rel.Declaration +let push_rec_types pfix env = + let (i, c, t) = pfix in + let inj c = EConstr.Unsafe.to_constr c in + push_rec_types (i, Array.map inj c, Array.map inj t) env + let meta_type evd mv = let ty = try Evd.meta_ftype evd mv @@ -28,12 +33,12 @@ let meta_type evd mv = let constant_type_knowing_parameters env cst jl = let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - type_of_constant_knowing_parameters_in env cst paramstyp + EConstr.of_constr (type_of_constant_knowing_parameters_in env cst paramstyp) let inductive_type_knowing_parameters env (ind,u) jl = let mspec = lookup_mind_specif env ind in let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp + EConstr.of_constr (Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp) let e_type_judgment env evdref j = match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref (EConstr.of_constr j.uj_type))) with @@ -44,7 +49,7 @@ let e_type_judgment env evdref j = | _ -> error_not_type env j let e_assumption_of_judgment env evdref j = - try (e_type_judgment env evdref j).utj_val + try EConstr.of_constr (e_type_judgment env evdref j).utj_val with TypeError _ -> error_assumption env j @@ -84,27 +89,28 @@ let max_sort l = if Sorts.List.mem InSet l then InSet else InProp let e_is_correct_arity env evdref c pj ind specif params = + let open EConstr in let arsign = make_arity_signature env true (make_ind_family (ind,params)) in let allowed_sorts = elim_sorts specif in let error () = error_elim_arity env ind allowed_sorts c pj None in let rec srec env pt ar = - let pt' = whd_all env !evdref (EConstr.of_constr pt) in - match kind_of_term pt', ar with + let pt' = EConstr.of_constr (whd_all env !evdref pt) in + match EConstr.kind !evdref pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> - if not (Evarconv.e_cumul env evdref (EConstr.of_constr a1) (EConstr.of_constr a1')) then error (); - srec (push_rel (LocalAssum (na1,a1)) env) t ar' + if not (Evarconv.e_cumul env evdref a1 (EConstr.of_constr a1')) then error (); + srec (push_rel (LocalAssum (na1,EConstr.Unsafe.to_constr a1)) env) t ar' | Sort s, [] -> if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in - evdref := Evd.define ev (mkSort s) evd + evdref := Evd.define ev (Constr.mkSort s) evd | _, (LocalDef _ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' + srec (push_rel d env) (Vars.lift 1 pt') ar' | _ -> error () in - srec env pj.uj_type (List.rev arsign) + srec env (EConstr.of_constr pj.uj_type) (List.rev arsign) let e_type_case_branches env evdref (ind,largs) pj c = let specif = lookup_mind_specif env (fst ind) in @@ -128,24 +134,25 @@ let e_judge_of_case env evdref ci pj cj lfj = uj_type = rslty } let check_type_fixpoint loc env evdref lna lar vdefj = + let open EConstr in let lt = Array.length vdefj in if Int.equal (Array.length lar) lt then for i = 0 to lt-1 do if not (Evarconv.e_cumul env evdref (EConstr.of_constr (vdefj.(i)).uj_type) - (EConstr.of_constr (lift lt lar.(i)))) then + (Vars.lift lt lar.(i))) then Pretype_errors.error_ill_typed_rec_body ~loc env !evdref - i lna vdefj lar + i lna vdefj (Array.map EConstr.Unsafe.to_constr lar) done (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = - let pj = Retyping.get_judgment_of env sigma (EConstr.of_constr p) in + let pj = Retyping.get_judgment_of env sigma p in let ksort = family_of_sort (sort_of_arity env sigma (EConstr.of_constr pj.uj_type)) in let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in - error_elim_arity env ind sorts c pj + error_elim_arity env ind sorts (EConstr.Unsafe.to_constr c) pj (Some(ksort,s,error_elim_explain ksort s)) let e_judge_of_cast env evdref cj k tj = @@ -160,21 +167,36 @@ let enrich_env env evdref = let penv' = Pre_env.({ penv with env_stratification = { penv.env_stratification with env_universes = Evd.universes !evdref } }) in Environ.env_of_pre_env penv' + +let check_fix env sigma pfix = + let inj c = EConstr.to_constr sigma c in + let (idx, (ids, cs, ts)) = pfix in + check_fix env (idx, (ids, Array.map inj cs, Array.map inj ts)) + +let check_cofix env sigma pcofix = + let inj c = EConstr.to_constr sigma c in + let (idx, (ids, cs, ts)) = pcofix in + check_cofix env (idx, (ids, Array.map inj cs, Array.map inj ts)) + +let make_judge c ty = + make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr ty) (* The typing machine with universes and existential variables. *) (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env evdref cstr = - match kind_of_term cstr with + let open EConstr in + let cstr = EConstr.of_constr (whd_evar !evdref (EConstr.Unsafe.to_constr cstr)) in + match EConstr.kind !evdref cstr with | Meta n -> - { uj_val = cstr; uj_type = meta_type !evdref n } + { uj_val = EConstr.Unsafe.to_constr cstr; uj_type = meta_type !evdref n } | Evar ev -> - let ty = Evd.existential_type !evdref ev in - let jty = execute env evdref (whd_evar !evdref ty) in + let ty = EConstr.existential_type !evdref ev in + let jty = execute env evdref ty in let jty = e_assumption_of_judgment env evdref jty in - { uj_val = cstr; uj_type = jty } + { uj_val = EConstr.Unsafe.to_constr cstr; uj_type = EConstr.Unsafe.to_constr jty } | Rel n -> judge_of_relative env n @@ -183,13 +205,13 @@ let rec execute env evdref cstr = judge_of_variable env id | Const c -> - make_judge cstr (rename_type_of_constant env c) + make_judge cstr (EConstr.of_constr (rename_type_of_constant env c)) | Ind ind -> - make_judge cstr (rename_type_of_inductive env ind) + make_judge cstr (EConstr.of_constr (rename_type_of_inductive env ind)) | Construct cstruct -> - make_judge cstr (rename_type_of_constructor env cstruct) + make_judge cstr (EConstr.of_constr (rename_type_of_constructor env cstruct)) | Case (ci,p,c,lf) -> let cj = execute env evdref c in @@ -200,13 +222,13 @@ let rec execute env evdref cstr = | Fix ((vn,i as vni),recdef) -> let (_,tys,_ as recdef') = execute_recdef env evdref recdef in let fix = (vni,recdef') in - check_fix env fix; + check_fix env !evdref fix; make_judge (mkFix fix) tys.(i) | CoFix (i,recdef) -> let (_,tys,_ as recdef') = execute_recdef env evdref recdef in let cofix = (i,recdef') in - check_cofix env cofix; + check_cofix env !evdref cofix; make_judge (mkCoFix cofix) tys.(i) | Sort (Prop c) -> @@ -222,7 +244,7 @@ let rec execute env evdref cstr = | App (f,args) -> let jl = execute_array env evdref args in let j = - match kind_of_term f with + match EConstr.kind !evdref f with | Ind ind when Environ.template_polymorphic_pind ind env -> (* Sort-polymorphism of inductive types *) make_judge f @@ -273,7 +295,7 @@ and execute_recdef env evdref (names,lar,vdef) = let lara = Array.map (e_assumption_of_judgment env evdref) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 evdref vdef in - let vdefv = Array.map j_val vdefj in + let vdefv = Array.map (j_val %> EConstr.of_constr) vdefj in let _ = check_type_fixpoint Loc.ghost env1 evdref names lara vdefj in (names,lara,vdefv) @@ -282,8 +304,8 @@ and execute_array env evdref = Array.map (execute env evdref) let e_check env evdref c t = let env = enrich_env env evdref in let j = execute env evdref c in - if not (Evarconv.e_cumul env evdref (EConstr.of_constr j.uj_type) (EConstr.of_constr t)) then - error_actual_type env j (nf_evar !evdref t) + if not (Evarconv.e_cumul env evdref (EConstr.of_constr j.uj_type) t) then + error_actual_type env j (EConstr.to_constr !evdref t) (* Type of a constr *) @@ -328,4 +350,4 @@ let e_solve_evars env evdref c = (* side-effect on evdref *) nf_evar !evdref c -let _ = Evarconv.set_solve_evars (fun env evdref c -> EConstr.of_constr (e_solve_evars env evdref (EConstr.Unsafe.to_constr c))) +let _ = Evarconv.set_solve_evars (fun env evdref c -> EConstr.of_constr (e_solve_evars env evdref c)) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 04e5e40bc2..3c1c4324dd 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -14,33 +14,33 @@ open Evd and universes. *) (** Typecheck a term and return its type. May trigger an evarmap leak. *) -val unsafe_type_of : env -> evar_map -> constr -> types +val unsafe_type_of : env -> evar_map -> EConstr.constr -> types (** Typecheck a term and return its type + updated evars, optionally refreshing universes *) -val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types +val type_of : ?refresh:bool -> env -> evar_map -> EConstr.constr -> evar_map * types (** Variant of [type_of] using references instead of state-passing. *) -val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types +val e_type_of : ?refresh:bool -> env -> evar_map ref -> EConstr.constr -> types (** Typecheck a type and return its sort *) -val e_sort_of : env -> evar_map ref -> types -> sorts +val e_sort_of : env -> evar_map ref -> EConstr.types -> sorts (** Typecheck a term has a given type (assuming the type is OK) *) -val e_check : env -> evar_map ref -> constr -> types -> unit +val e_check : env -> evar_map ref -> EConstr.constr -> EConstr.types -> unit (** Returns the instantiated type of a metavariable *) val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) -val e_solve_evars : env -> evar_map ref -> constr -> constr +val e_solve_evars : env -> evar_map ref -> EConstr.constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) -val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> +val check_allowed_sort : env -> evar_map -> pinductive -> EConstr.constr -> EConstr.constr -> unit (** Raise an error message if bodies have types not unifiable with the expected ones *) val check_type_fixpoint : Loc.t -> env -> evar_map ref -> - Names.Name.t array -> types array -> unsafe_judgment array -> unit + Names.Name.t array -> EConstr.types array -> unsafe_judgment array -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index ac2f140519..f418dc6a94 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -102,7 +102,7 @@ let abstract_list_all env evd typ c l = let l_with_all_occs = List.map (function a -> (LikeFirst,a)) l in let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in let evd,typp = - try Typing.type_of env evd p + try Typing.type_of env evd (EConstr.of_constr p) with | UserError _ -> error_cannot_find_well_typed_abstraction env evd p (List.map EConstr.of_constr l) None @@ -1214,7 +1214,7 @@ let applyHead env (type r) (evd : r Sigma.t) n c = apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' | _ -> error "Apply_Head_Then" in - apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd + apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) (EConstr.of_constr c)) Sigma.refl evd let is_mimick_head ts f = match kind_of_term f with -- cgit v1.2.3 From 77e638121b6683047be915da9d0499a58fcb6e52 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 19:30:24 +0100 Subject: Patternops API using EConstr. --- pretyping/patternops.ml | 43 +++++++++++++++++++++++++++++-------------- pretyping/patternops.mli | 3 ++- 2 files changed, 31 insertions(+), 15 deletions(-) (limited to 'pretyping') diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 938b6b18eb..d473f41bdf 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -114,17 +114,27 @@ let rec head_pattern_bound t = | PLambda _ -> raise BoundPattern | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type") -let head_of_constr_reference c = match kind_of_term c with +let head_of_constr_reference sigma c = match EConstr.kind sigma c with | Const (sp,_) -> ConstRef sp | Construct (sp,_) -> ConstructRef sp | Ind (sp,_) -> IndRef sp | Var id -> VarRef id | _ -> anomaly (Pp.str "Not a rigid reference") +let local_assum (na, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + let pattern_of_constr env sigma t = + let open EConstr in let rec pattern_of_constr env t = - let open Context.Rel.Declaration in - match kind_of_term t with + match EConstr.kind sigma t with | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) | Var id -> PVar id @@ -133,14 +143,14 @@ let pattern_of_constr env sigma t = | Sort (Type _) -> PSort (GType []) | Cast (c,_,_) -> pattern_of_constr env c | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c, - pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) + pattern_of_constr (push_rel (local_def (na,c,t)) env) b) | Prod (na,c,b) -> PProd (na,pattern_of_constr env c, - pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + pattern_of_constr (push_rel (local_assum (na, c)) env) b) | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c, - pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) + pattern_of_constr (push_rel (local_assum (na, c)) env) b) | App (f,a) -> (match - match kind_of_term f with + match EConstr.kind sigma f with | Evar (evk,args) -> (match snd (Evd.evar_source evk sigma) with Evar_kinds.MatchingVar (true,id) -> Some id @@ -153,17 +163,17 @@ let pattern_of_constr env sigma t = | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) | Proj (p, c) -> - pattern_of_constr env (Retyping.expand_projection env sigma p (EConstr.of_constr c) []) + pattern_of_constr env (EConstr.of_constr (Retyping.expand_projection env sigma p c [])) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> - let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in + let ty = existential_type sigma ev in let () = ignore (pattern_of_constr env ty) in assert (not b); PMeta (Some id) | Evar_kinds.GoalEvar -> PEvar (evk,Array.map (pattern_of_constr env) ctxt) | _ -> - let ty = Evarutil.nf_evar sigma (existential_type sigma ev) in + let ty = existential_type sigma ev in let () = ignore (pattern_of_constr env ty) in PMeta None) | Case (ci,p,a,br) -> @@ -178,8 +188,13 @@ let pattern_of_constr env sigma t = in PCase (cip, pattern_of_constr env p, pattern_of_constr env a, Array.to_list (Array.mapi branch_of_constr br)) - | Fix f -> PFix f - | CoFix f -> PCoFix f in + | Fix (idx, (nas, cs, ts)) -> + let inj c = EConstr.to_constr sigma c in + PFix (idx, (nas, Array.map inj cs, Array.map inj ts)) + | CoFix (idx, (nas, cs, ts)) -> + let inj c = EConstr.to_constr sigma c in + PCoFix (idx, (nas, Array.map inj cs, Array.map inj ts)) + in pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -220,7 +235,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - pattern_of_constr env sigma c + pattern_of_constr env sigma (EConstr.of_constr c) with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in @@ -245,7 +260,7 @@ let rec subst_pattern subst pat = | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else - pattern_of_constr (Global.env()) Evd.empty t + pattern_of_constr (Global.env()) Evd.empty (EConstr.of_constr t) | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 1f63565d6f..93d2c859a9 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -7,6 +7,7 @@ (************************************************************************) open Term +open EConstr open Globnames open Glob_term open Mod_subst @@ -32,7 +33,7 @@ val head_pattern_bound : constr_pattern -> global_reference (** [head_of_constr_reference c] assumes [r] denotes a reference and returns its label; raises an anomaly otherwise *) -val head_of_constr_reference : Term.constr -> global_reference +val head_of_constr_reference : Evd.evar_map -> constr -> global_reference (** [pattern_of_constr c] translates a term [c] with metavariables into a pattern; currently, no destructor (Cases, Fix, Cofix) and no -- cgit v1.2.3 From 258c8502eafd3e078a5c7478a452432b5c046f71 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 19:59:28 +0100 Subject: Constr_matching API using EConstr. --- pretyping/constr_matching.ml | 105 +++++++++++++++++++++++++----------------- pretyping/constr_matching.mli | 3 +- pretyping/tacred.ml | 9 ++-- 3 files changed, 69 insertions(+), 48 deletions(-) (limited to 'pretyping') diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 1261844a06..ecf6b11219 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -57,14 +57,15 @@ let warn_meta_collision = strbrk " and a metavariable of same name.") -let constrain n (ids, m as x) (names, terms as subst) = +let constrain sigma n (ids, m) (names, terms as subst) = + let open EConstr in try let (ids', m') = Id.Map.find n terms in - if List.equal Id.equal ids ids' && eq_constr m m' then subst + if List.equal Id.equal ids ids' && eq_constr sigma m (EConstr.of_constr m') then subst else raise PatternMatchingFailure with Not_found -> let () = if Id.Map.mem n names then warn_meta_collision n in - (names, Id.Map.add n x terms) + (names, Id.Map.add n (ids, EConstr.Unsafe.to_constr m) terms) let add_binders na1 na2 binding_vars (names, terms as subst) = match na1, na2 with @@ -82,8 +83,9 @@ let add_binders na1 na2 binding_vars (names, terms as subst) = let rec build_lambda sigma vars ctx m = match vars with | [] -> let len = List.length ctx in - lift (-1 * len) m + EConstr.Vars.lift (-1 * len) m | n :: vars -> + let open EConstr in (* change [ x1 ... xn y z1 ... zm |- t ] into [ x1 ... xn z1 ... zm |- lam y. t ] *) let len = List.length ctx in @@ -92,7 +94,7 @@ let rec build_lambda sigma vars ctx m = match vars with else if Int.equal i (pred n) then mkRel 1 else mkRel (i + 1) in - let m = substl (List.init len init) m in + let m = Vars.substl (List.init len init) m in let pre, suf = List.chop (pred n) ctx in match suf with | [] -> assert false @@ -100,7 +102,7 @@ let rec build_lambda sigma vars ctx m = match vars with let map i = if i > n then pred i else i in let vars = List.map map vars in (** Check that the abstraction is legal *) - let frels = free_rels sigma (EConstr.of_constr t) in + let frels = free_rels sigma t in let brels = List.fold_right Int.Set.add vars Int.Set.empty in let () = if not (Int.Set.subset frels brels) then raise PatternMatchingFailure in (** Create the abstraction *) @@ -123,41 +125,55 @@ let rec extract_bound_aux k accu frels ctx = match ctx with let extract_bound_vars frels ctx = extract_bound_aux 1 Id.Set.empty frels ctx -let dummy_constr = mkProp +let dummy_constr = EConstr.mkProp let make_renaming ids = function | (Name id, Name _, _) -> begin - try mkRel (List.index Id.equal id ids) + try EConstr.mkRel (List.index Id.equal id ids) with Not_found -> dummy_constr end | _ -> dummy_constr +let local_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + +let to_fix (idx, (nas, cs, ts)) = + let inj = EConstr.of_constr in + (idx, (nas, Array.map inj cs, Array.map inj ts)) + let merge_binding sigma allow_bound_rels ctx n cT subst = let c = match ctx with | [] -> (* Optimization *) ([], cT) | _ -> - let frels = free_rels sigma (EConstr.of_constr cT) in + let open EConstr in + let frels = free_rels sigma cT in if allow_bound_rels then let vars = extract_bound_vars frels ctx in let ordered_vars = Id.Set.elements vars in let rename binding = make_renaming ordered_vars binding in let renaming = List.map rename ctx in - (ordered_vars, substl renaming cT) + (ordered_vars, Vars.substl renaming cT) else let depth = List.length ctx in let min_elt = try Int.Set.min_elt frels with Not_found -> succ depth in if depth < min_elt then - ([], lift (- depth) cT) + ([], Vars.lift (- depth) cT) else raise PatternMatchingFailure in - constrain n c subst + constrain sigma n c subst let matches_core env sigma convert allow_partial_app allow_bound_rels (binding_vars,pat) c = + let open EConstr in let convref ref c = - match ref, kind_of_term c with + match ref, EConstr.kind sigma c with | VarRef id, Var id' -> Names.id_eq id id' | ConstRef c, Const (c',_) -> Names.eq_constant c c' | IndRef i, Ind (i', _) -> Names.eq_ind i i' @@ -165,12 +181,12 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | _, _ -> (if convert then let sigma,c' = Evd.fresh_global env sigma ref in - is_conv env sigma (EConstr.of_constr c') (EConstr.of_constr c) + is_conv env sigma (EConstr.of_constr c') c else false) in let rec sorec ctx env subst p t = - let cT = strip_outer_cast sigma (EConstr.of_constr t) in - match p,kind_of_term cT with + let cT = EConstr.of_constr (strip_outer_cast sigma t) in + match p, EConstr.kind sigma cT with | PSoApp (n,args),m -> let fold (ans, seen) = function | PRel n -> @@ -179,9 +195,9 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | _ -> error "Only bound indices allowed in second order pattern matching." in let relargs, relset = List.fold_left fold ([], Int.Set.empty) args in - let frels = free_rels sigma (EConstr.of_constr cT) in + let frels = free_rels sigma cT in if Int.Set.subset frels relset then - constrain n ([], build_lambda sigma relargs ctx cT) subst + constrain sigma n ([], build_lambda sigma relargs ctx cT) subst else raise PatternMatchingFailure @@ -219,15 +235,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | Some n -> merge_binding sigma allow_bound_rels ctx n c subst in Array.fold_left2 (sorec ctx env) subst args1 args22 else (* Might be a projection on the right *) - match kind_of_term c2 with + match EConstr.kind sigma c2 with | Proj (pr, c) when not (Projection.unfolded pr) -> - (try let term = Retyping.expand_projection env sigma pr (EConstr.of_constr c) (Array.map_to_list EConstr.of_constr args2) in - sorec ctx env subst p term + (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in + sorec ctx env subst p (EConstr.of_constr term) with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _ -> raise PatternMatchingFailure) | PApp (c1,arg1), App (c2,arg2) -> - (match c1, kind_of_term c2 with + (match c1, EConstr.kind sigma c2 with | PRef (ConstRef r), Proj (pr,c) when not (eq_constant r (Projection.constant pr)) || Projection.unfolded pr -> raise PatternMatchingFailure @@ -237,8 +253,8 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels with Invalid_argument _ -> raise PatternMatchingFailure else raise PatternMatchingFailure | _, Proj (pr,c) when not (Projection.unfolded pr) -> - (try let term = Retyping.expand_projection env sigma pr (EConstr.of_constr c) (Array.map_to_list EConstr.of_constr arg2) in - sorec ctx env subst p term + (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in + sorec ctx env subst p (EConstr.of_constr term) with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _, _ -> try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 @@ -249,32 +265,32 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels raise PatternMatchingFailure | PApp (c, args), Proj (pr, c2) -> - (try let term = Retyping.expand_projection env sigma pr (EConstr.of_constr c2) [] in - sorec ctx env subst p term + (try let term = Retyping.expand_projection env sigma pr c2 [] in + sorec ctx env subst p (EConstr.of_constr term) with Retyping.RetypeError _ -> raise PatternMatchingFailure) | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env) + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (local_assum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (Environ.push_rel (LocalAssum (na2,c2)) env) + sorec ((na1,na2,c2)::ctx) (Environ.push_rel (local_assum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::ctx) (Environ.push_rel (LocalDef (na2,c2,t2)) env) + sorec ((na1,na2,t2)::ctx) (Environ.push_rel (local_def (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> - let ctx_b2,b2 = decompose_lam_n_decls ci.ci_cstr_ndecls.(0) b2 in - let ctx_b2',b2' = decompose_lam_n_decls ci.ci_cstr_ndecls.(1) b2' in + let ctx_b2,b2 = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(0) b2 in + let ctx_b2',b2' = decompose_lam_n_decls sigma ci.ci_cstr_ndecls.(1) b2' in let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in - if noccur_between 1 n b2 && noccur_between 1 n' b2' then - let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in + if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then + let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,EConstr.of_constr t)::l in let ctx_br = List.fold_left f ctx ctx_b2 in let ctx_br' = List.fold_left f ctx ctx_b2' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in @@ -306,8 +322,8 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels let chk_head = sorec ctx env (sorec ctx env subst a1 a2) p1 p2 in List.fold_left chk_branch chk_head br1 - | PFix c1, Fix _ when eq_constr (mkFix c1) cT -> subst - | PCoFix c1, CoFix _ when eq_constr (mkCoFix c1) cT -> subst + | PFix c1, Fix _ when eq_constr sigma (mkFix (to_fix c1)) cT -> subst + | PCoFix c1, CoFix _ when eq_constr sigma (mkCoFix (to_fix c1)) cT -> subst | _ -> raise PatternMatchingFailure in @@ -328,13 +344,14 @@ type matching_result = { m_sub : bound_ident_map * patvar_map; m_ctx : constr; } -let mkresult s c n = IStream.Cons ( { m_sub=s; m_ctx=c; } , (IStream.thunk n) ) +let mkresult s c n = IStream.Cons ( { m_sub=s; m_ctx=EConstr.Unsafe.to_constr c; } , (IStream.thunk n) ) let isPMeta = function PMeta _ -> true | _ -> false let matches_head env sigma pat c = + let open EConstr in let head = - match pat, kind_of_term c with + match pat, EConstr.kind sigma c with | PApp (c1,arg1), App (c2,arg2) -> if isPMeta c1 then c else let n1 = Array.length arg1 in @@ -345,6 +362,7 @@ let matches_head env sigma pat c = (* Tells if it is an authorized occurrence and if the instance is closed *) let authorized_occ env sigma partial_app closed pat c mk_ctx = + let open EConstr in try let subst = matches_core_closed env sigma false partial_app pat c in if closed && Id.Map.exists (fun _ c -> not (closed0 c)) (snd subst) @@ -356,9 +374,10 @@ let subargs env v = Array.map_to_list (fun c -> (env, c)) v (* Tries to match a subterm of [c] with [pat] *) let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = + let open EConstr in let rec aux env c mk_ctx next = let here = authorized_occ env sigma partial_app closed pat c mk_ctx in - let next () = match kind_of_term c with + let next () = match EConstr.kind sigma c with | Cast (c1,k,c2) -> let next_mk_ctx = function | [c1] -> mk_ctx (mkCast (c1, k, c2)) @@ -370,21 +389,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2)) | _ -> assert false in - let env' = Environ.push_rel (LocalAssum (x,c1)) env in + let env' = Environ.push_rel (local_assum (x,c1)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | Prod (x,c1,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkProd (x, c1, c2)) | _ -> assert false in - let env' = Environ.push_rel (LocalAssum (x,c1)) env in + let env' = Environ.push_rel (local_assum (x,c1)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | LetIn (x,c1,t,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2)) | _ -> assert false in - let env' = Environ.push_rel (LocalDef (x,c1,t)) env in + let env' = Environ.push_rel (local_def (x,c1,t)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | App (c1,lc) -> let topdown = true in @@ -440,8 +459,8 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in if partial_app then try - let term = Retyping.expand_projection env sigma p (EConstr.of_constr c') [] in - aux env term mk_ctx next + let term = Retyping.expand_projection env sigma p c' [] in + aux env (EConstr.of_constr term) mk_ctx next with Retyping.RetypeError _ -> next () else try_aux [env, c'] next_mk_ctx next diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index ee6c5141b0..32bb48c937 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -10,6 +10,7 @@ open Names open Term +open EConstr open Environ open Pattern @@ -63,7 +64,7 @@ val matches_conv : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map (whose hole is denoted here with [special_meta]) *) type matching_result = { m_sub : bound_ident_map * patvar_map; - m_ctx : constr } + m_ctx : Constr.t } (** [match_subterm n pat c] returns the substitution and the context corresponding to each **closed** subterm of [c] matching [pat]. *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index a3983737d2..9581db23de 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -962,9 +962,10 @@ let simpl env sigma c = strong whd_simpl env sigma c (* Reduction at specific subterms *) let matches_head env sigma c t = - match kind_of_term t with + let open EConstr in + match EConstr.kind sigma t with | App (f,_) -> Constr_matching.matches env sigma c f - | Proj (p, _) -> Constr_matching.matches env sigma c (mkConst (Projection.constant p)) + | Proj (p, _) -> Constr_matching.matches env sigma c (mkConstU (Projection.constant p, Univ.Instance.empty)) | _ -> raise Constr_matching.PatternMatchingFailure (** FIXME: Specific function to handle projections: it ignores what happens on the @@ -999,8 +1000,8 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> else try let subst = - if byhead then matches_head env sigma c t - else Constr_matching.matches env sigma c t in + if byhead then matches_head env sigma c (EConstr.of_constr t) + else Constr_matching.matches env sigma c (EConstr.of_constr t) in let ok = if nowhere_except_in then Int.List.mem !pos locs else not (Int.List.mem !pos locs) in -- cgit v1.2.3 From b77579ac873975a15978c5a4ecf312d577746d26 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 21:59:18 +0100 Subject: Tacred API using EConstr. --- pretyping/evarconv.ml | 5 +- pretyping/find_subterm.ml | 17 ++- pretyping/find_subterm.mli | 3 +- pretyping/tacred.ml | 278 +++++++++++++++++++++++++-------------------- pretyping/tacred.mli | 10 +- pretyping/unification.ml | 6 +- 6 files changed, 176 insertions(+), 143 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index c8dcb19b40..cdcb993b5e 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -986,10 +986,9 @@ let apply_on_subterm env evdref f c t = let g decl a = if is_local_assum decl then applyrec acc a else a in mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) | _ -> - let self acc c = EConstr.Unsafe.to_constr (applyrec acc (EConstr.of_constr c)) in - EConstr.of_constr (map_constr_with_binders_left_to_right + map_constr_with_binders_left_to_right !evdref (fun d (env,(k,c)) -> (push_rel d env, (k+1,Vars.lift 1 c))) - self acc (EConstr.Unsafe.to_constr t)) + applyrec acc t in applyrec (env,(0,c)) t diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index d7f2d54aa2..2b243d5b9b 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -99,7 +99,7 @@ type 'a testing_function = { (b,l), b=true means no occurrence except the ones in l and b=false, means all occurrences except the ones in l *) -let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = +let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref occ in @@ -133,24 +133,23 @@ let replace_term_occ_gen_modulo occs like_first test bywhat cl occ t = with NotUnifiable _ -> subst_below k t and subst_below k t = - let substrec i c = EConstr.Unsafe.to_constr (substrec i (EConstr.of_constr c)) in - EConstr.of_constr (map_constr_with_binders_left_to_right (fun d k -> k+1) substrec k (EConstr.Unsafe.to_constr t)) + map_constr_with_binders_left_to_right sigma (fun d k -> k+1) substrec k t in let t' = substrec 0 t in (!pos, t') -let replace_term_occ_modulo occs test bywhat t = +let replace_term_occ_modulo evd occs test bywhat t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in EConstr.Unsafe.to_constr (proceed_with_occurrences - (replace_term_occ_gen_modulo occs' like_first test bywhat None) occs' t) + (replace_term_occ_gen_modulo evd occs' like_first test bywhat None) occs' t) -let replace_term_occ_decl_modulo occs test bywhat d = +let replace_term_occ_decl_modulo evd occs test bywhat d = let (plocs,hyploc),like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> (AllOccurrences,InHyp),true in proceed_with_occurrences (map_named_declaration_with_hyploc - (replace_term_occ_gen_modulo plocs like_first test bywhat) + (replace_term_occ_gen_modulo evd plocs like_first test bywhat) hyploc) plocs d @@ -172,7 +171,7 @@ let make_eq_univs_test env evd c = let subst_closed_term_occ env evd occs c t = let test = make_eq_univs_test env evd c in let bywhat () = mkRel 1 in - let t' = replace_term_occ_modulo occs test bywhat t in + let t' = replace_term_occ_modulo evd occs test bywhat t in t', test.testing_state let subst_closed_term_occ_decl env evd occs c d = @@ -182,6 +181,6 @@ let subst_closed_term_occ_decl env evd occs c d = let bywhat () = mkRel 1 in proceed_with_occurrences (map_named_declaration_with_hyploc - (fun _ -> replace_term_occ_gen_modulo plocs like_first test bywhat None) + (fun _ -> replace_term_occ_gen_modulo evd plocs like_first test bywhat None) hyploc) plocs d, test.testing_state diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 49a5dd7f26..e7f0da93fb 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -41,12 +41,13 @@ val make_eq_univs_test : env -> evar_map -> EConstr.constr -> evar_map testing_f matching subterms at the indicated occurrences [occl] with [mk ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) -val replace_term_occ_modulo : occurrences or_like_first -> +val replace_term_occ_modulo : evar_map -> occurrences or_like_first -> 'a testing_function -> (unit -> EConstr.constr) -> EConstr.constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : + evar_map -> (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> EConstr.constr) -> Context.Named.Declaration.t -> Context.Named.Declaration.t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9581db23de..9997976c44 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -31,7 +31,7 @@ module NamedDecl = Context.Named.Declaration (* Errors *) type reduction_tactic_error = - InvalidAbstraction of env * Evd.evar_map * constr * (env * Type_errors.type_error) + InvalidAbstraction of env * Evd.evar_map * EConstr.constr * (env * Type_errors.type_error) exception ReductionTacticError of reduction_tactic_error @@ -77,14 +77,14 @@ type evaluable_reference = | EvalConst of constant | EvalVar of Id.t | EvalRel of int - | EvalEvar of existential + | EvalEvar of EConstr.existential -let evaluable_reference_eq r1 r2 = match r1, r2 with +let evaluable_reference_eq sigma r1 r2 = match r1, r2 with | EvalConst c1, EvalConst c2 -> eq_constant c1 c2 | EvalVar id1, EvalVar id2 -> Id.equal id1 id2 | EvalRel i1, EvalRel i2 -> Int.equal i1 i2 | EvalEvar (e1, ctx1), EvalEvar (e2, ctx2) -> - Evar.equal e1 e2 && Array.equal eq_constr ctx1 ctx2 + Evar.equal e1 e2 && Array.equal (EConstr.eq_constr sigma) ctx1 ctx2 | _ -> false let mkEvalRef ref u = @@ -93,15 +93,15 @@ let mkEvalRef ref u = | EvalConst cst -> mkConstU (cst,u) | EvalVar id -> mkVar id | EvalRel n -> mkRel n - | EvalEvar ev -> EConstr.of_constr (Constr.mkEvar ev) + | EvalEvar ev -> EConstr.mkEvar ev -let isEvalRef env c = match kind_of_term c with +let isEvalRef env sigma c = match EConstr.kind sigma c with | Const (sp,_) -> is_evaluable env (EvalConstRef sp) | Var id -> is_evaluable env (EvalVarRef id) | Rel _ | Evar _ -> true | _ -> false -let destEvalRefU c = match kind_of_term c with +let destEvalRefU sigma c = match EConstr.kind sigma c with | Const (cst,u) -> EvalConst cst, u | Var id -> (EvalVar id, Univ.Instance.empty) | Rel n -> (EvalRel n, Univ.Instance.empty) @@ -109,31 +109,39 @@ let destEvalRefU c = match kind_of_term c with | _ -> anomaly (Pp.str "Not an unfoldable reference") let unsafe_reference_opt_value env sigma eval = + let open EConstr in match eval with | EvalConst cst -> (match (lookup_constant cst env).Declarations.const_body with - | Declarations.Def c -> Some (Mod_subst.force_constr c) + | Declarations.Def c -> Some (EConstr.of_constr (Mod_subst.force_constr c)) | _ -> None) | EvalVar id -> - env |> lookup_named id |> NamedDecl.get_value + env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr | EvalRel n -> - env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value - | EvalEvar ev -> Evd.existential_opt_value sigma ev + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value |> Option.map EConstr.of_constr + | EvalEvar ev -> + match EConstr.kind sigma (mkEvar ev) with + | Evar _ -> None + | c -> Some (EConstr.of_kind c) let reference_opt_value env sigma eval u = + let open EConstr in match eval with - | EvalConst cst -> constant_opt_value_in env (cst,u) + | EvalConst cst -> Option.map EConstr.of_constr (constant_opt_value_in env (cst,u)) | EvalVar id -> - env |> lookup_named id |> NamedDecl.get_value + env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr | EvalRel n -> - env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value - | EvalEvar ev -> Evd.existential_opt_value sigma ev + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value |> Option.map EConstr.of_constr + | EvalEvar ev -> + match EConstr.kind sigma (mkEvar ev) with + | Evar _ -> None + | c -> Some (EConstr.of_kind c) exception NotEvaluable let reference_value env sigma c u = match reference_opt_value env sigma c u with | None -> raise NotEvaluable - | Some d -> EConstr.of_constr d + | Some d -> d (************************************************************************) (* Reduction of constants hiding a fixpoint (e.g. for "simpl" tactic). *) @@ -179,6 +187,7 @@ let eval_table = Summary.ref (Cmap.empty : frozen) ~name:"evaluation" *) let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = + let open EConstr in let n = List.length labs in let nargs = List.length args in if nargs > n then raise Elimconst; @@ -188,8 +197,8 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = (function d -> match EConstr.kind sigma d with | Rel k -> if - Array.for_all (noccurn k) tys - && Array.for_all (noccurn (k+nbfix)) bds + Array.for_all (Vars.noccurn sigma k) tys + && Array.for_all (Vars.noccurn sigma (k+nbfix)) bds && k <= n then (k, List.nth labs (k-1)) @@ -223,6 +232,7 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = let invert_name labs l na0 env sigma ref = function | Name id -> + let open EConstr in let minfxargs = List.length l in begin match na0 with | Name id' when Id.equal id' id -> @@ -239,12 +249,13 @@ let invert_name labs l na0 env sigma ref = function try match unsafe_reference_opt_value env sigma ref with | None -> None | Some c -> - let labs',ccl = decompose_lam c in - let _, l' = whd_betalet_stack sigma (EConstr.of_constr ccl) in + let labs',ccl = decompose_lam sigma c in + let _, l' = whd_betalet_stack sigma ccl in let labs' = List.map snd labs' in (** ppedrot: there used to be generic equality on terms here *) + let eq_constr c1 c2 = EConstr.eq_constr sigma c1 c2 in if List.equal eq_constr labs' labs && - List.equal (fun c1 c2 -> EConstr.eq_constr sigma c1 c2) l l' then Some (minfxargs,ref) + List.equal eq_constr l l' then Some (minfxargs,ref) else None with Not_found (* Undefined ref *) -> None end @@ -254,20 +265,29 @@ let invert_name labs l na0 env sigma ref = function [compute_consteval_mutual_fix] only one by one, until finding the last one before the Fix if the latter is mutually defined *) +let local_assum (na, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + let compute_consteval_direct env sigma ref = + let open EConstr in let rec srec env n labs onlyproj c = - let c',l = whd_betadeltazeta_stack env sigma (EConstr.of_constr c) in - let c' = EConstr.Unsafe.to_constr c' in - match kind_of_term c' with + let c',l = whd_betadeltazeta_stack env sigma c in + match EConstr.kind sigma c' with | Lambda (id,t,g) when List.is_empty l && not onlyproj -> - let open Context.Rel.Declaration in - srec (push_rel (LocalAssum (id,t)) env) (n+1) (EConstr.of_constr t::labs) onlyproj g + srec (push_rel (local_assum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) - | Case (_,_,d,_) when isRel d && not onlyproj -> EliminationCases n + | Case (_,_,d,_) when isRel sigma d && not onlyproj -> EliminationCases n | Case (_,_,d,_) -> srec env n labs true d - | Proj (p, d) when isRel d -> EliminationProj n + | Proj (p, d) when isRel sigma d -> EliminationProj n | _ -> NotAnElimination in match unsafe_reference_opt_value env sigma ref with @@ -275,14 +295,13 @@ let compute_consteval_direct env sigma ref = | Some c -> srec env 0 [] false c let compute_consteval_mutual_fix env sigma ref = + let open EConstr in let rec srec env minarg labs ref c = - let c',l = whd_betalet_stack sigma (EConstr.of_constr c) in + let c',l = whd_betalet_stack sigma c in let nargs = List.length l in - let c' = EConstr.Unsafe.to_constr c' in - match kind_of_term c' with + match EConstr.kind sigma c' with | Lambda (na,t,g) when List.is_empty l -> - let open Context.Rel.Declaration in - srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g + srec (push_rel (local_assum (na,t)) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct env sigma ref with @@ -295,9 +314,9 @@ let compute_consteval_mutual_fix env sigma ref = let new_minarg = max (minarg'+minarg-nargs) minarg' in EliminationMutualFix (new_minarg,ref,(refs,infos)) | _ -> assert false) - | _ when isEvalRef env c' -> + | _ when isEvalRef env sigma c' -> (* Forget all \'s and args and do as if we had started with c' *) - let ref,_ = destEvalRefU c' in + let ref,_ = destEvalRefU sigma c' in (match unsafe_reference_opt_value env sigma ref with | None -> anomaly (Pp.str "Should have been trapped by compute_direct") | Some c -> srec env (minarg-nargs) [] ref c) @@ -417,23 +436,25 @@ let solve_arity_problem env sigma fxminargs c = let rec check strict c = let c' = EConstr.of_constr (whd_betaiotazeta sigma c) in let (h,rcargs) = decompose_app_vect sigma c' in - match kind_of_term h with + let rcargs = Array.map EConstr.of_constr rcargs in + let h = EConstr.of_constr h in + match EConstr.kind sigma h with Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> let minargs = Evar.Map.find i fxminargs in if Array.length rcargs < minargs then if strict then set_fix i else raise Partial; - Array.iter (EConstr.of_constr %> check strict) rcargs - | (Var _|Const _) when isEvalRef env h -> - (let ev, u = destEvalRefU h in + Array.iter (check strict) rcargs + | (Var _|Const _) when isEvalRef env sigma h -> + (let ev, u = destEvalRefU sigma h in match reference_opt_value env sigma ev u with | Some h' -> let bak = !evm in - (try Array.iter (EConstr.of_constr %> check false) rcargs + (try Array.iter (check false) rcargs with Partial -> evm := bak; - check strict (EConstr.of_constr (Constr.mkApp(h',rcargs)))) - | None -> Array.iter (EConstr.of_constr %> check strict) rcargs) + check strict (mkApp(h',rcargs))) + | None -> Array.iter (check strict) rcargs) | _ -> EConstr.iter sigma (check strict) c' in check true c; !evm @@ -445,14 +466,16 @@ let substl_checking_arity env subst sigma c = let sigma' = solve_arity_problem env sigma minargs body in (* we propagate the constraints: solved problems are substituted; the other ones are replaced by the function symbol *) - let rec nf_fix c = - match kind_of_term c with - Evar(i,[|fx;f|] as ev) when Evar.Map.mem i minargs -> - (match Evd.existential_opt_value sigma' ev with - Some c' -> c' - | None -> f) - | _ -> map_constr nf_fix c in - EConstr.of_constr (nf_fix (EConstr.Unsafe.to_constr body)) + let rec nf_fix c = match EConstr.kind sigma c with + | Evar (i,[|fx;f|]) when Evar.Map.mem i minargs -> + (** FIXME: find a less hackish way of doing this *) + begin match EConstr.kind sigma' c with + | Evar _ -> f + | c -> EConstr.of_kind c + end + | _ -> EConstr.map sigma nf_fix c + in + nf_fix body type fix_reduction_result = NotReducible | Reduced of (EConstr.t * EConstr.t list) @@ -540,21 +563,21 @@ let match_eval_ref env sigma constr = Some (EvalConst sp, u) | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty) | Rel i -> Some (EvalRel i, Univ.Instance.empty) - | Evar (evk, args) -> Some (EvalEvar (evk, Array.map EConstr.Unsafe.to_constr args), Univ.Instance.empty) + | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty) | _ -> None let match_eval_ref_value env sigma constr = - match kind_of_term constr with + match EConstr.kind sigma constr with | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> - Some (constant_value_in env (sp, u)) + Some (EConstr.of_constr (constant_value_in env (sp, u))) | Var id when is_evaluable env (EvalVarRef id) -> - env |> lookup_named id |> NamedDecl.get_value + env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr | Rel n -> - env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value - | Evar ev -> Evd.existential_opt_value sigma ev + env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value |> Option.map EConstr.of_constr | _ -> None let special_red_case env sigma whfun (ci, p, c, lf) = + let open EConstr in let rec redrec s = let (constr, cargs) = whfun s in match match_eval_ref env sigma constr with @@ -562,13 +585,12 @@ let special_red_case env sigma whfun (ci, p, c, lf) = (match reference_opt_value env sigma ref u with | None -> raise Redelimination | Some gvalue -> - let gvalue = EConstr.of_constr gvalue in if reducible_mind_case sigma gvalue then reduce_mind_case_use_function constr env sigma {mP=p; mconstr=gvalue; mcargs=cargs; mci=ci; mlf=lf} else - redrec (EConstr.applist(gvalue, cargs))) + redrec (applist(gvalue, cargs))) | None -> if reducible_mind_case sigma constr then reduce_mind_case sigma @@ -688,11 +710,11 @@ let rec red_elim_const env sigma ref u largs = | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> let rec descend (ref,u) args = let c = reference_value env sigma ref u in - if evaluable_reference_eq ref refgoal then + if evaluable_reference_eq sigma ref refgoal then (c,args) else let c', lrest = whd_betalet_stack sigma (applist(c,args)) in - descend (destEvalRefU (EConstr.Unsafe.to_constr c')) lrest in + descend (destEvalRefU sigma c') lrest in let (_, midargs as s) = descend (ref,u) largs in let d, lrest = whd_nothing_for_iota env sigma (applist s) in let f = make_elim_fun refinfos u midargs in @@ -803,7 +825,7 @@ and whd_construct_stack env sigma s = | Some (ref, u) -> (match reference_opt_value env sigma ref u with | None -> raise Redelimination - | Some gvalue -> whd_construct_stack env sigma (applist(EConstr.of_constr gvalue, cargs))) + | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs))) | _ -> raise Redelimination (************************************************************************) @@ -816,7 +838,6 @@ and whd_construct_stack env sigma s = let try_red_product env sigma c = let simpfun c = EConstr.of_constr (clos_norm_flags betaiotazeta env sigma c) in - let inj = EConstr.Unsafe.to_constr in let open EConstr in let rec redrec env x = let x = EConstr.of_constr (whd_betaiota sigma x) in @@ -834,8 +855,7 @@ let try_red_product env sigma c = | _ -> simpfun (mkApp (redrec env f, l))) | Cast (c,_,_) -> redrec env c | Prod (x,a,b) -> - let open Context.Rel.Declaration in - mkProd (x, a, redrec (push_rel (LocalAssum (x, inj a)) env) b) + mkProd (x, a, redrec (push_rel (local_assum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | Proj (p, c) -> @@ -855,7 +875,7 @@ let try_red_product env sigma c = (* to get true one-step reductions *) (match reference_opt_value env sigma ref u with | None -> raise Redelimination - | Some c -> EConstr.of_constr c) + | Some c -> c) | _ -> raise Redelimination) in EConstr.Unsafe.to_constr (redrec env c) @@ -931,9 +951,9 @@ let whd_simpl_orelse_delta_but_fix env sigma c = let open EConstr in let rec redrec s = let (constr, stack as s') = whd_simpl_stack env sigma s in - match match_eval_ref_value env sigma (EConstr.Unsafe.to_constr constr) with + match match_eval_ref_value env sigma constr with | Some c -> - (match kind_of_term (strip_lam c) with + (match EConstr.kind sigma (snd (decompose_lam sigma c)) with | CoFix _ | Fix _ -> s' | Proj (p,t) when (match EConstr.kind sigma constr with @@ -943,8 +963,8 @@ let whd_simpl_orelse_delta_but_fix env sigma c = if List.length stack <= pb.Declarations.proj_npars then (** Do not show the eta-expanded form *) s' - else redrec (applist (EConstr.of_constr c, stack)) - | _ -> redrec (applist(EConstr.of_constr c, stack))) + else redrec (applist (c, stack)) + | _ -> redrec (applist(c, stack))) | None -> s' in let simpfun = clos_norm_flags betaiota env sigma in @@ -973,22 +993,25 @@ let matches_head env sigma c t = of the projection and its eta expanded form. *) let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = - match kind_of_term c with + let open EConstr in + match EConstr.kind sigma c with | Proj (p, r) -> (* Treat specially for partial applications *) - let t = Retyping.expand_projection env sigma p (EConstr.of_constr r) [] in - let hdf, al = destApp t in + let t = Retyping.expand_projection env sigma p r [] in + let t = EConstr.of_constr t in + let hdf, al = destApp sigma t in let a = al.(Array.length al - 1) in let app = (mkApp (hdf, Array.sub al 0 (Array.length al - 1))) in let app' = f acc app in let a' = f acc a in - (match kind_of_term app' with + (match EConstr.kind sigma app' with | App (hdf', al') when hdf' == hdf -> (* Still the same projection, we ignore the change in parameters *) mkProj (p, a') | _ -> mkApp (app', [| a' |])) - | _ -> map_constr_with_binders_left_to_right g f acc c + | _ -> map_constr_with_binders_left_to_right sigma g f acc c let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> + let open EConstr in let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in @@ -1000,8 +1023,8 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> else try let subst = - if byhead then matches_head env sigma c (EConstr.of_constr t) - else Constr_matching.matches env sigma c (EConstr.of_constr t) in + if byhead then matches_head env sigma c t + else Constr_matching.matches env sigma c t in let ok = if nowhere_except_in then Int.List.mem !pos locs else not (Int.List.mem !pos locs) in @@ -1012,8 +1035,8 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> (* Skip inner occurrences for stable counting of occurrences *) if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); - let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) (EConstr.of_constr t) in - (evd := Sigma.to_evar_map evm; t) + let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in + (evd := Sigma.to_evar_map evm; EConstr.of_constr t) end else traverse_below nested envc t @@ -1022,7 +1045,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> and traverse_below nested envc t = (* when byhead, find other occurrences without matching again partial application with same head *) - match kind_of_term t with + match EConstr.kind !evd t with | App (f,l) when byhead -> mkApp (f, Array.map_left (traverse nested envc) l) | Proj (p,c) when byhead -> mkProj (p,traverse nested envc c) | _ -> @@ -1030,9 +1053,9 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> (fun d (env,c) -> (push_rel d env,lift_pattern 1 c)) (traverse nested) envc sigma t in - let t' = traverse None (env,c) (EConstr.Unsafe.to_constr t) in + let t' = traverse None (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - Sigma.Unsafe.of_pair (t', !evd) + Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr t', !evd) end } let contextually byhead occs f env sigma t = @@ -1068,10 +1091,9 @@ let substlin env sigma evalref n (nowhere_except_in,locs) c = incr pos; if ok then value u else c | None -> - let self () c = EConstr.Unsafe.to_constr (substrec () (EConstr.of_constr c)) in - EConstr.of_constr (map_constr_with_binders_left_to_right + map_constr_with_binders_left_to_right sigma (fun _ () -> ()) - self () (EConstr.Unsafe.to_constr c)) + substrec () c in let t' = substrec () c in (!pos, t') @@ -1082,9 +1104,9 @@ let string_of_evaluable_ref env = function string_of_qualid (Nametab.shortest_qualid_of_global (vars_of_env env) (ConstRef kn)) -let unfold env sigma name = +let unfold env sigma name c = if is_evaluable env name then - clos_norm_flags (unfold_red name) env sigma + EConstr.of_constr (clos_norm_flags (unfold_red name) env sigma c) else error (string_of_evaluable_ref env name^" is opaque.") @@ -1102,37 +1124,40 @@ let unfoldoccs env sigma (occs,name) c = | [] -> () | _ -> error_invalid_occurrence rest in - nf_betaiotazeta sigma uc + EConstr.of_constr (nf_betaiotazeta sigma uc) in match occs with - | NoOccurrences -> EConstr.Unsafe.to_constr c + | NoOccurrences -> c | AllOccurrences -> unfold env sigma name c | OnlyOccurrences l -> unfo true l | AllOccurrencesBut l -> unfo false l (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = - EConstr.Unsafe.to_constr (List.fold_left (fun c occname -> EConstr.of_constr (unfoldoccs env sigma occname c)) c loccname) + EConstr.Unsafe.to_constr (List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname) (* Re-folding constants tactics: refold com in term c *) let fold_one_com com env sigma c = + let open EConstr in let rcom = - try red_product env sigma (EConstr.of_constr com) + try EConstr.of_constr (red_product env sigma com) with Redelimination -> error "Not reducible." in (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) - let a = subst_term sigma (EConstr.of_constr (clos_norm_flags unfold_side_red env sigma (EConstr.of_constr rcom))) c in - if not (eq_constr a (EConstr.Unsafe.to_constr c)) then - subst1 com a + let a = subst_term sigma (EConstr.of_constr (clos_norm_flags unfold_side_red env sigma rcom)) c in + let a = EConstr.of_constr a in + if not (EConstr.eq_constr sigma a c) then + Vars.subst1 com a else (* Then reason on the non beta-iota-zeta form for compatibility - even if it is probably a useless configuration *) - let a = subst_term sigma (EConstr.of_constr rcom) c in - subst1 com a + let a = subst_term sigma rcom c in + let a = EConstr.of_constr a in + Vars.subst1 com a let fold_commands cl env sigma c = - EConstr.Unsafe.to_constr (List.fold_right (fun com c -> EConstr.of_constr (fold_one_com com env sigma c)) (List.rev cl) c) + EConstr.Unsafe.to_constr (List.fold_right (fun com c -> fold_one_com com env sigma c) (List.rev cl) c) (* call by value reduction functions *) @@ -1150,23 +1175,26 @@ let compute = cbv_betadeltaiota (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only * the specified occurrences. *) -let abstract_scheme env (locc,a) (c, sigma) = - let a = EConstr.of_constr a in +let abstract_scheme env sigma (locc,a) (c, sigma) = + let open EConstr in let ta = Retyping.get_type_of env sigma a in - let na = named_hd env ta Anonymous in - if occur_meta sigma (EConstr.of_constr ta) then error "Cannot find a type for the generalisation."; + let ta = EConstr.of_constr ta in + let na = named_hd env (EConstr.to_constr sigma ta) Anonymous in + if occur_meta sigma ta then error "Cannot find a type for the generalisation."; if occur_meta sigma a then mkLambda (na,ta,c), sigma else - let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a (EConstr.of_constr c) in + let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in + let c' = EConstr.of_constr c' in mkLambda (na,ta,c'), sigma' let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> + let open EConstr in let sigma = Sigma.to_evar_map sigma in - let abstr_trm, sigma = List.fold_right (abstract_scheme env) loccs_trm (EConstr.Unsafe.to_constr c,sigma) in + let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in try - let _ = Typing.unsafe_type_of env sigma (EConstr.of_constr abstr_trm) in - Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) + let _ = Typing.unsafe_type_of env sigma abstr_trm in + Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr (applist(abstr_trm, List.map snd loccs_trm)), sigma) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) end } @@ -1190,28 +1218,31 @@ let check_not_primitive_record env ind = return name, B and t' *) let reduce_to_ind_gen allow_product env sigma t = + let open EConstr in let rec elimrec env t l = - let t = hnf_constr env sigma (EConstr.of_constr t) in - match kind_of_term (fst (decompose_app t)) with - | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) + let t = hnf_constr env sigma t in + let t = EConstr.of_constr t in + match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t))) with + | Ind ind-> (check_privacy env ind, EConstr.Unsafe.to_constr (it_mkProd_or_LetIn t l)) | Prod (n,ty,t') -> let open Context.Rel.Declaration in if allow_product then - elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) + elimrec (push_rel (local_assum (n,ty)) env) t' ((local_assum (n,ty))::l) else user_err (str"Not an inductive definition.") | _ -> (* Last chance: we allow to bypass the Opaque flag (as it was partially the case between V5.10 and V8.1 *) - let t' = whd_all env sigma (EConstr.of_constr t) in - match kind_of_term (fst (decompose_app t')) with - | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) + let t' = whd_all env sigma t in + let t' = EConstr.of_constr t' in + match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t'))) with + | Ind ind-> (check_privacy env ind, EConstr.Unsafe.to_constr (it_mkProd_or_LetIn t' l)) | _ -> user_err (str"Not an inductive product.") in elimrec env t [] -let reduce_to_quantified_ind x = reduce_to_ind_gen true x -let reduce_to_atomic_ind x = reduce_to_ind_gen false x +let reduce_to_quantified_ind env sigma c = reduce_to_ind_gen true env sigma (EConstr.of_constr c) +let reduce_to_atomic_ind env sigma c = reduce_to_ind_gen false env sigma (EConstr.of_constr c) let find_hnf_rectype env sigma t = let ind,t = reduce_to_atomic_ind env sigma t in @@ -1243,13 +1274,13 @@ let one_step_reduce env sigma c = | Reduced s' -> s' | NotReducible -> raise NotStepReducible with Redelimination -> raise NotStepReducible) - | _ when isEvalRef env (EConstr.Unsafe.to_constr x) -> - let ref,u = destEvalRefU (EConstr.Unsafe.to_constr x) in + | _ when isEvalRef env sigma x -> + let ref,u = destEvalRefU sigma x in (try fst (red_elim_const env sigma ref u stack) with Redelimination -> match reference_opt_value env sigma ref u with - | Some d -> (EConstr.of_constr d, stack) + | Some d -> (d, stack) | None -> raise NotStepReducible) | _ -> raise NotStepReducible @@ -1271,26 +1302,29 @@ let reduce_to_ref_gen allow_product env sigma ref t = else (* lazily reduces to match the head of [t] with the expected [ref] *) let rec elimrec env t l = - let c, _ = decompose_app_vect sigma (EConstr.of_constr t) in - match kind_of_term c with + let open EConstr in + let c, _ = decompose_app_vect sigma t in + let c = EConstr.of_constr c in + match EConstr.kind sigma c with | Prod (n,ty,t') -> if allow_product then let open Context.Rel.Declaration in - elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l) + elimrec (push_rel (local_assum (n,t)) env) t' ((local_assum (n,ty))::l) else error_cannot_recognize ref | _ -> try - if eq_gr (global_of_constr c) ref + if eq_gr (global_of_constr (EConstr.to_constr sigma c)) ref then it_mkProd_or_LetIn t l else raise Not_found with Not_found -> try - let t' = nf_betaiota sigma (one_step_reduce env sigma (EConstr.of_constr t)) in + let t' = nf_betaiota sigma (one_step_reduce env sigma t) in + let t' = EConstr.of_constr t' in elimrec env t' l with NotStepReducible -> error_cannot_recognize ref in - elimrec env t [] + EConstr.Unsafe.to_constr (elimrec env t []) let reduce_to_quantified_ref = reduce_to_ref_gen true let reduce_to_atomic_ref = reduce_to_ref_gen false diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index f8dfe1adf2..d32fcf4917 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -17,7 +17,7 @@ open Locus open Univ type reduction_tactic_error = - InvalidAbstraction of env * evar_map * constr * (env * Type_errors.type_error) + InvalidAbstraction of env * evar_map * EConstr.constr * (env * Type_errors.type_error) exception ReductionTacticError of reduction_tactic_error @@ -58,10 +58,10 @@ val unfoldn : (occurrences * evaluable_global_reference) list -> reduction_function (** Fold *) -val fold_commands : constr list -> reduction_function +val fold_commands : EConstr.constr list -> reduction_function (** Pattern *) -val pattern_occs : (occurrences * constr) list -> e_reduction_function +val pattern_occs : (occurrences * EConstr.constr) list -> e_reduction_function (** Rem: Lazy strategies are defined in Reduction *) @@ -85,10 +85,10 @@ val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) val reduce_to_quantified_ref : - env -> evar_map -> global_reference -> types -> types + env -> evar_map -> global_reference -> EConstr.types -> types val reduce_to_atomic_ref : - env -> evar_map -> global_reference -> types -> types + env -> evar_map -> global_reference -> EConstr.types -> types val find_hnf_rectype : env -> evar_map -> types -> pinductive * constr list diff --git a/pretyping/unification.ml b/pretyping/unification.ml index f418dc6a94..786cfd31ff 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1611,7 +1611,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val d sign,depdecls) | AllOccurrences, InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - let newdecl = replace_term_occ_decl_modulo occ test mkvarid d in + let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in if Context.Named.Declaration.equal d newdecl && not (indirectly_dependent sigma c d depdecls) then @@ -1622,7 +1622,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = (push_named_context_val newdecl sign, newdecl :: depdecls) | occ -> (* There are specific occurrences, hence not like first *) - let newdecl = replace_term_occ_decl_modulo (AtOccs occ) test mkvarid d in + let newdecl = replace_term_occ_decl_modulo sigma (AtOccs occ) test mkvarid d in (push_named_context_val newdecl sign, newdecl :: depdecls) in try let sign,depdecls = @@ -1632,7 +1632,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo occ test mkvarid (EConstr.of_constr concl) + replace_term_occ_modulo sigma occ test mkvarid (EConstr.of_constr concl) in let lastlhyp = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in -- cgit v1.2.3 From 3b8acc174490878a3d0c9345e34a0ecb1d3abd66 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Nov 2016 13:27:16 +0100 Subject: Typeclasses API using EConstr. --- pretyping/tacred.ml | 2 +- pretyping/typeclasses.ml | 44 ++++++++++++++++++++-------------------- pretyping/typeclasses.mli | 10 ++++----- pretyping/typeclasses_errors.ml | 1 + pretyping/typeclasses_errors.mli | 1 + 5 files changed, 30 insertions(+), 28 deletions(-) (limited to 'pretyping') diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9997976c44..b729f3b9bc 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1314,7 +1314,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = error_cannot_recognize ref | _ -> try - if eq_gr (global_of_constr (EConstr.to_constr sigma c)) ref + if eq_gr (fst (global_of_constr sigma c)) ref then it_mkProd_or_LetIn t l else raise Not_found with Not_found -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 11f71ee023..a970c434f4 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -136,23 +136,24 @@ let typeclass_univ_instance (cl,u') = let class_info c = try Refmap.find c !classes - with Not_found -> not_a_class (Global.env()) (printable_constr_of_global c) + with Not_found -> not_a_class (Global.env()) (EConstr.of_constr (printable_constr_of_global c)) -let global_class_of_constr env c = - try let gr, u = Universes.global_of_constr c in +let global_class_of_constr env sigma c = + try let gr, u = Termops.global_of_constr sigma c in class_info gr, u with Not_found -> not_a_class env c -let dest_class_app env c = - let cl, args = decompose_app c in - global_class_of_constr env cl, args +let dest_class_app env sigma c = + let cl, args = EConstr.decompose_app sigma c in + global_class_of_constr env sigma cl, (List.map EConstr.Unsafe.to_constr args) -let dest_class_arity env c = - let rels, c = decompose_prod_assum c in - rels, dest_class_app env c +let dest_class_arity env sigma c = + let open EConstr in + let rels, c = decompose_prod_assum sigma c in + rels, dest_class_app env sigma c -let class_of_constr c = - try Some (dest_class_arity (Global.env ()) c) +let class_of_constr sigma c = + try Some (dest_class_arity (Global.env ()) sigma c) with e when CErrors.noncritical e -> None let is_class_constr c = @@ -161,15 +162,14 @@ let is_class_constr c = with Not_found -> false let rec is_class_type evd c = - let c, args = decompose_app c in - match kind_of_term c with + let c, _ = Termops.decompose_app_vect evd c in + match EConstr.kind evd (EConstr.of_constr c) with | Prod (_, _, t) -> is_class_type evd t - | Evar (e, _) when Evd.is_defined evd e -> - is_class_type evd (EConstr.Unsafe.to_constr (Evarutil.whd_head_evar evd (EConstr.of_constr c))) + | Cast (t, _, _) -> is_class_type evd t | _ -> is_class_constr c let is_class_evar evd evi = - is_class_type evd evi.Evd.evar_concl + is_class_type evd (EConstr.of_constr evi.Evd.evar_concl) (* * classes persistent object @@ -222,7 +222,7 @@ let discharge_class (_,cl) = let discharge_context ctx' subst (grs, ctx) = let grs' = let newgrs = List.map (fun decl -> - match decl |> RelDecl.get_type |> class_of_constr with + match decl |> RelDecl.get_type |> EConstr.of_constr |> class_of_constr Evd.empty with | None -> None | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) ctx' @@ -270,7 +270,7 @@ let add_class cl = let check_instance env sigma c = try let (evd, c) = resolve_one_typeclass env sigma - (Retyping.get_type_of env sigma c) in + (EConstr.of_constr (Retyping.get_type_of env sigma c)) in not (Evd.has_undefined evd) with e when CErrors.noncritical e -> false @@ -282,10 +282,10 @@ let build_subclasses ~check env sigma glob pri = Nameops.add_suffix _id ("_subinstance_" ^ string_of_int !i)) in let ty, ctx = Global.type_of_global_in_context env glob in + let ty = EConstr.of_constr ty in let sigma = Evd.merge_context_set Evd.univ_rigid sigma (Univ.ContextSet.of_context ctx) in let rec aux pri c ty path = - let ty = Evarutil.nf_evar sigma ty in - match class_of_constr ty with + match class_of_constr sigma ty with | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = @@ -313,7 +313,7 @@ let build_subclasses ~check env sigma glob pri = let declare_proj hints (cref, pri, body) = let path' = cref :: path in let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in - let rest = aux pri body ty path' in + let rest = aux pri body (EConstr.of_constr ty) path' in hints @ (path', pri, body) :: rest in List.fold_left declare_proj [] projs in @@ -406,7 +406,7 @@ let remove_instance i = let declare_instance pri local glob = let ty = Global.type_of_global_unsafe glob in - match class_of_constr ty with + match class_of_constr Evd.empty (EConstr.of_constr ty) with | Some (rels, ((tc,_), args) as _cl) -> add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob) (* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 2530f5dfae..ec36c57e04 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -61,13 +61,13 @@ val class_info : global_reference -> typeclass (** raises a UserError if not a c (** These raise a UserError if not a class. Caution: the typeclass structures is not instantiated w.r.t. the universe instance. This is done separately by typeclass_univ_instance. *) -val dest_class_app : env -> constr -> typeclass puniverses * constr list +val dest_class_app : env -> evar_map -> EConstr.constr -> typeclass puniverses * constr list (** Get the instantiated typeclass structure for a given universe instance. *) val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option +val class_of_constr : evar_map -> EConstr.constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference @@ -99,11 +99,11 @@ val mark_unresolvables : ?filter:evar_filter -> evar_map -> evar_map val mark_resolvables : ?filter:evar_filter -> evar_map -> evar_map val mark_resolvable : evar_info -> evar_info val is_class_evar : evar_map -> evar_info -> bool -val is_class_type : evar_map -> types -> bool +val is_class_type : evar_map -> EConstr.types -> bool val resolve_typeclasses : ?fast_path:bool -> ?filter:evar_filter -> ?unique:bool -> ?split:bool -> ?fail:bool -> env -> evar_map -> evar_map -val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> types -> open_constr +val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> EConstr.types -> open_constr val set_typeclass_transparency_hook : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) Hook.t val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit @@ -120,7 +120,7 @@ val add_instance_hint : global_reference_or_constr -> global_reference list -> val remove_instance_hint : global_reference -> unit val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t -val solve_one_instance_hook : (env -> evar_map -> types -> bool -> open_constr) Hook.t +val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> open_constr) Hook.t val declare_instance : int option -> bool -> global_reference -> unit diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml index b1dfb19a07..2db0e9e881 100644 --- a/pretyping/typeclasses_errors.ml +++ b/pretyping/typeclasses_errors.ml @@ -9,6 +9,7 @@ (*i*) open Names open Term +open EConstr open Environ open Constrexpr open Globnames diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli index ee76f63836..9bd430e4d6 100644 --- a/pretyping/typeclasses_errors.mli +++ b/pretyping/typeclasses_errors.mli @@ -9,6 +9,7 @@ open Loc open Names open Term +open EConstr open Environ open Constrexpr open Globnames -- cgit v1.2.3 From ce2b509734f3b70494a0a35b0b4eda593c1c8eb6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Nov 2016 19:07:16 +0100 Subject: Classops API using EConstr. --- pretyping/classops.ml | 16 ++++++++-------- pretyping/classops.mli | 12 ++++++------ pretyping/coercion.ml | 8 ++++---- 3 files changed, 18 insertions(+), 18 deletions(-) (limited to 'pretyping') diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 577f41a7d7..753127357a 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -193,7 +193,7 @@ let coercion_exists coe = CoeTypMap.mem coe !coercion_tab let find_class_type sigma t = let inj = EConstr.Unsafe.to_constr in - let t', args = Reductionops.whd_betaiotazeta_stack sigma (EConstr.of_constr t) in + let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match EConstr.kind sigma t' with | Var id -> CL_SECVAR id, Univ.Instance.empty, List.map inj args | Const (sp,u) -> CL_CONST sp, u, List.map inj args @@ -215,7 +215,7 @@ let subst_cl_typ subst ct = match ct with | CL_CONST c -> let c',t = subst_con_kn subst c in if c' == c then ct else - pi1 (find_class_type Evd.empty t) + pi1 (find_class_type Evd.empty (EConstr.of_constr t)) | CL_IND i -> let i' = subst_ind subst i in if i' == i then ct else CL_IND i' @@ -231,10 +231,10 @@ let class_of env sigma t = try let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, u, args) + (EConstr.Unsafe.to_constr t, n1, i, u, args) with Not_found -> - let t = Tacred.hnf_constr env sigma (EConstr.of_constr t) in - let (cl, u, args) = find_class_type sigma t in + let t = Tacred.hnf_constr env sigma t in + let (cl, u, args) = find_class_type sigma (EConstr.of_constr t) in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, u, args) in @@ -274,11 +274,11 @@ let apply_on_class_of env sigma t cont = let (cl,u,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; - t, cont i + EConstr.Unsafe.to_constr t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) - let t = Tacred.hnf_constr env sigma (EConstr.of_constr t) in - let (cl, u, args) = find_class_type sigma t in + let t = Tacred.hnf_constr env sigma t in + let (cl, u, args) = find_class_type sigma (EConstr.of_constr t) in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i diff --git a/pretyping/classops.mli b/pretyping/classops.mli index d509739cf4..4b8a2c1c07 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -59,15 +59,15 @@ val class_info_from_index : cl_index -> cl_typ * cl_info_typ (** [find_class_type env sigma c] returns the head reference of [c], its universe instance and its arguments *) -val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list +val find_class_type : evar_map -> EConstr.types -> cl_typ * Univ.universe_instance * constr list (** raises [Not_found] if not convertible to a class *) -val class_of : env -> evar_map -> types -> types * cl_index +val class_of : env -> evar_map -> EConstr.types -> types * cl_index (** raises [Not_found] if not mapped to a class *) val inductive_class_of : inductive -> cl_index -val class_args_of : env -> evar_map -> types -> constr list +val class_args_of : env -> evar_map -> EConstr.types -> constr list (** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) val declare_coercion : @@ -84,11 +84,11 @@ val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_univer (** @raise Not_found in the following functions when no path exists *) val lookup_path_between_class : cl_index * cl_index -> inheritance_path -val lookup_path_between : env -> evar_map -> types * types -> +val lookup_path_between : env -> evar_map -> EConstr.types * EConstr.types -> types * types * inheritance_path -val lookup_path_to_fun_from : env -> evar_map -> types -> +val lookup_path_to_fun_from : env -> evar_map -> EConstr.types -> types * inheritance_path -val lookup_path_to_sort_from : env -> evar_map -> types -> +val lookup_path_to_sort_from : env -> evar_map -> EConstr.types -> types * inheritance_path val lookup_pattern_path_between : env -> inductive * inductive -> (constructor * int) list diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 04e235cc53..90cd3b60b9 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -358,7 +358,7 @@ let apply_coercion env sigma p hj typ_cl = (fun (ja,typ_cl,sigma) i -> let ((fv,isid,isproj),ctx) = coercion_value i in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let argl = (class_args_of env sigma (EConstr.of_constr typ_cl))@[ja.uj_val] in let sigma, jres = apply_coercion_args env sigma true isproj argl fv in @@ -382,7 +382,7 @@ let inh_app_fun_core env evd j = (evd',{ uj_val = j.uj_val; uj_type = EConstr.Unsafe.to_constr t }) | _ -> try let t,p = - lookup_path_to_fun_from env evd j.uj_type in + lookup_path_to_fun_from env evd (EConstr.of_constr j.uj_type) in apply_coercion env evd p j t with Not_found | NoCoercion -> if Flags.is_program_mode () then @@ -407,7 +407,7 @@ let inh_app_fun resolve_tc env evd j = let inh_tosort_force loc env evd j = try - let t,p = lookup_path_to_sort_from env evd j.uj_type in + let t,p = lookup_path_to_sort_from env evd (EConstr.of_constr j.uj_type) in let evd,j1 = apply_coercion env evd p j t in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) @@ -448,7 +448,7 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = else let evd, v', t' = try - let t2,t1,p = lookup_path_between env evd (t,c1) in + let t2,t1,p = lookup_path_between env evd (EConstr.of_constr t,EConstr.of_constr c1) in match v with | Some v -> let evd,j = -- cgit v1.2.3 From e4f066238799a4598817dfeab8a044760ab670de Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Nov 2016 20:33:06 +0100 Subject: Coercion API using EConstr. --- pretyping/cases.ml | 5 +- pretyping/classops.ml | 19 +++--- pretyping/classops.mli | 15 ++-- pretyping/coercion.ml | 174 +++++++++++++++++++++++++---------------------- pretyping/coercion.mli | 8 +-- pretyping/pretyping.ml | 6 +- pretyping/program.ml | 3 +- pretyping/program.mli | 2 +- pretyping/unification.ml | 2 +- 9 files changed, 125 insertions(+), 109 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 882c052f60..96c61647c3 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -396,7 +396,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = current else (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env) - pb.evdref (make_judge current typ) indt).uj_val in + pb.evdref (make_judge current typ) (EConstr.of_constr indt)).uj_val in let sigma = !(pb.evdref) in (current,try_find_ind pb.env sigma indt names)) | _ -> (current,tmtyp) @@ -1867,7 +1867,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let inh_conv_coerce_to_tycon loc env evdref j tycon = match tycon with | Some p -> - let (evd',j) = Coercion.inh_conv_coerce_to true loc env !evdref j p in + let (evd',j) = Coercion.inh_conv_coerce_to true loc env !evdref j (EConstr.of_constr p) in evdref := evd'; j | None -> j @@ -2013,6 +2013,7 @@ let eq_id avoid id = let hid' = next_ident_away hid avoid in hid' +let papp evdref gr args = EConstr.Unsafe.to_constr (papp evdref gr (Array.map EConstr.of_constr args)) let mk_eq evdref typ x y = papp evdref coq_eq_ind [| typ; x ; y |] let mk_eq_refl evdref typ x = papp evdref coq_eq_refl [| typ; x |] let mk_JMeq evdref typ x typ' y = diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 753127357a..ad43bf3229 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -192,14 +192,13 @@ let coercion_exists coe = CoeTypMap.mem coe !coercion_tab (* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) let find_class_type sigma t = - let inj = EConstr.Unsafe.to_constr in let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match EConstr.kind sigma t' with - | Var id -> CL_SECVAR id, Univ.Instance.empty, List.map inj args - | Const (sp,u) -> CL_CONST sp, u, List.map inj args + | Var id -> CL_SECVAR id, Univ.Instance.empty, args + | Const (sp,u) -> CL_CONST sp, u, args | Proj (p, c) when not (Projection.unfolded p) -> - CL_PROJ (Projection.constant p), Univ.Instance.empty, List.map inj (c :: args) - | Ind (ind_sp,u) -> CL_IND ind_sp, u, List.map inj args + CL_PROJ (Projection.constant p), Univ.Instance.empty, (c :: args) + | Ind (ind_sp,u) -> CL_IND ind_sp, u, args | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, [] | Sort _ -> CL_SORT, Univ.Instance.empty, [] | _ -> raise Not_found @@ -231,10 +230,11 @@ let class_of env sigma t = try let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (EConstr.Unsafe.to_constr t, n1, i, u, args) + (t, n1, i, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let (cl, u, args) = find_class_type sigma (EConstr.of_constr t) in + let t = EConstr.of_constr t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, u, args) in @@ -274,11 +274,12 @@ let apply_on_class_of env sigma t cont = let (cl,u,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; - EConstr.Unsafe.to_constr t, cont i + t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let (cl, u, args) = find_class_type sigma (EConstr.of_constr t) in + let t = EConstr.of_constr t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 4b8a2c1c07..9fb70534fd 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Evd open Environ open Mod_subst @@ -59,15 +60,15 @@ val class_info_from_index : cl_index -> cl_typ * cl_info_typ (** [find_class_type env sigma c] returns the head reference of [c], its universe instance and its arguments *) -val find_class_type : evar_map -> EConstr.types -> cl_typ * Univ.universe_instance * constr list +val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list (** raises [Not_found] if not convertible to a class *) -val class_of : env -> evar_map -> EConstr.types -> types * cl_index +val class_of : env -> evar_map -> types -> types * cl_index (** raises [Not_found] if not mapped to a class *) val inductive_class_of : inductive -> cl_index -val class_args_of : env -> evar_map -> EConstr.types -> constr list +val class_args_of : env -> evar_map -> types -> constr list (** {6 [declare_coercion] adds a coercion in the graph of coercion paths } *) val declare_coercion : @@ -84,11 +85,11 @@ val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_univer (** @raise Not_found in the following functions when no path exists *) val lookup_path_between_class : cl_index * cl_index -> inheritance_path -val lookup_path_between : env -> evar_map -> EConstr.types * EConstr.types -> +val lookup_path_between : env -> evar_map -> types * types -> types * types * inheritance_path -val lookup_path_to_fun_from : env -> evar_map -> EConstr.types -> +val lookup_path_to_fun_from : env -> evar_map -> types -> types * inheritance_path -val lookup_path_to_sort_from : env -> evar_map -> EConstr.types -> +val lookup_path_to_sort_from : env -> evar_map -> types -> types * inheritance_path val lookup_pattern_path_between : env -> inductive * inductive -> (constructor * int) list @@ -104,7 +105,7 @@ val install_path_printer : val string_of_class : cl_typ -> string val pr_class : cl_typ -> std_ppcmds val pr_cl_index : cl_index -> std_ppcmds -val get_coercion_value : coe_index -> constr +val get_coercion_value : coe_index -> Constr.t val inheritance_graph : unit -> ((cl_index * cl_index) * inheritance_path) list val classes : unit -> cl_typ list val coercions : unit -> coe_index list diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 90cd3b60b9..cc121a96de 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -48,29 +48,30 @@ exception NoCoercionNoUnifier of evar_map * unification_error (* Here, funj is a coercion therefore already typed in global context *) let apply_coercion_args env evd check isproj argl funj = + let open EConstr in let evdref = ref evd in let rec apply_rec acc typ = function | [] -> if isproj then - let cst = fst (destConst (j_val funj)) in + let cst = fst (destConst !evdref (EConstr.of_constr (j_val funj))) in let p = Projection.make cst false in let pb = lookup_projection p env in let args = List.skipn pb.Declarations.proj_npars argl in let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in - { uj_val = applist (mkProj (p, hd), tl); - uj_type = typ } + { uj_val = EConstr.Unsafe.to_constr (applist (mkProj (p, hd), tl)); + uj_type = EConstr.Unsafe.to_constr typ } else - { uj_val = applist (j_val funj,argl); - uj_type = typ } + { uj_val = EConstr.Unsafe.to_constr (applist (EConstr.of_constr (j_val funj),argl)); + uj_type = EConstr.Unsafe.to_constr typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) - match kind_of_term (whd_all env evd (EConstr.of_constr typ)) with + match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref typ)) with | Prod (_,c1,c2) -> - if check && not (e_cumul env evdref (EConstr.of_constr (Retyping.get_type_of env evd (EConstr.of_constr h))) (EConstr.of_constr c1)) then + if check && not (e_cumul env evdref (EConstr.of_constr (Retyping.get_type_of env !evdref h)) c1) then raise NoCoercion; - apply_rec (h::acc) (subst1 h c2) restl + apply_rec (h::acc) (Vars.subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") in - let res = apply_rec [] funj.uj_type argl in + let res = apply_rec [] (EConstr.of_constr funj.uj_type) argl in !evdref, res (* appliquer le chemin de coercions de patterns p *) @@ -92,17 +93,17 @@ open Program let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c = let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in - Evarutil.e_new_evar env evdref ~src c + EConstr.of_constr (Evarutil.e_new_evar env evdref ~src (EConstr.Unsafe.to_constr c)) let app_opt env evdref f t = - whd_betaiota !evdref (EConstr.of_constr (app_opt f t)) + EConstr.of_constr (whd_betaiota !evdref (app_opt f t)) let pair_of_array a = (a.(0), a.(1)) -let disc_subset x = - match kind_of_term x with +let disc_subset sigma x = + match EConstr.kind sigma x with | App (c, l) -> - (match kind_of_term c with + (match EConstr.kind sigma c with Ind (i,_) -> let len = Array.length l in let sigty = delayed_force sig_typ in @@ -120,19 +121,25 @@ let hnf env evd c = whd_all env evd c let hnf_nodelta env evd c = whd_betaiota evd c let lift_args n sign = + let open EConstr in let rec liftrec k = function - | t::sign -> liftn n k t :: (liftrec (k-1) sign) + | t::sign -> Vars.liftn n k t :: (liftrec (k-1) sign) | [] -> [] in liftrec (List.length sign) sign +let local_assum (na, t) = + let open Context.Rel.Declaration in + LocalAssum (na, EConstr.Unsafe.to_constr t) + let mu env evdref t = let rec aux v = - let v' = hnf env !evdref (EConstr.of_constr v) in - match disc_subset v' with + let v' = hnf env !evdref v in + let v' = EConstr.of_constr v' in + match disc_subset !evdref v' with | Some (u, p) -> let f, ct = aux u in - let p = hnf_nodelta env !evdref (EConstr.of_constr p) in + let p = EConstr.of_constr (hnf_nodelta env !evdref p) in (Some (fun x -> app_opt env evdref f (papp evdref sig_proj1 [| u; p; x |])), @@ -140,21 +147,25 @@ let mu env evdref t = | None -> (None, v) in aux t -and coerce loc env evdref (x : Term.constr) (y : Term.constr) - : (Term.constr -> Term.constr) option +and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) + : (EConstr.constr -> EConstr.constr) option = + let open EConstr in + let open Vars in let open Context.Rel.Declaration in let rec coerce_unify env x y = - let x = hnf env !evdref (EConstr.of_constr x) and y = hnf env !evdref (EConstr.of_constr y) in + let x = hnf env !evdref x and y = hnf env !evdref y in + let x = EConstr.of_constr x in + let y = EConstr.of_constr y in try - evdref := the_conv_x_leq env (EConstr.of_constr x) (EConstr.of_constr y) !evdref; + evdref := the_conv_x_leq env x y !evdref; None with UnableToUnify _ -> coerce' env x y - and coerce' env x y : (Term.constr -> Term.constr) option = + and coerce' env x y : (EConstr.constr -> EConstr.constr) option = let subco () = subset_coerce env evdref x y in let dest_prod c = - match Reductionops.splay_prod_n env (!evdref) 1 (EConstr.of_constr c) with - | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na,t), c + match Reductionops.splay_prod_n env (!evdref) 1 c with + | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na, EConstr.of_constr t), EConstr.of_constr c | _ -> raise NoSubtacCoercion in let coerce_application typ typ' c c' l l' = @@ -162,7 +173,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let rec aux tele typ typ' i co = if i < len then let hdx = l.(i) and hdy = l'.(i) in - try evdref := the_conv_x_leq env (EConstr.of_constr hdx) (EConstr.of_constr hdy) !evdref; + try evdref := the_conv_x_leq env hdx hdy !evdref; let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in aux (hdx :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) co @@ -170,16 +181,16 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let (n, eqT), restT = dest_prod typ in let (n', eqT'), restT' = dest_prod typ' in let _ = - try evdref := the_conv_x_leq env (EConstr.of_constr eqT) (EConstr.of_constr eqT') !evdref + try evdref := the_conv_x_leq env eqT eqT' !evdref with UnableToUnify _ -> raise NoSubtacCoercion in (* Disallow equalities on arities *) - if Reduction.is_arity env eqT then raise NoSubtacCoercion; + if Reductionops.is_arity env !evdref eqT then raise NoSubtacCoercion; let restargs = lift_args 1 (List.rev (Array.to_list (Array.sub l (succ i) (len - (succ i))))) in let args = List.rev (restargs @ mkRel 1 :: List.map (lift 1) tele) in - let pred = mkLambda (n, eqT, applistc (lift 1 c) args) in + let pred = mkLambda (n, eqT, applist (lift 1 c, args)) in let eq = papp evdref coq_eq_ind [| eqT; hdx; hdy |] in let evar = make_existential loc env evdref eq in let eq_app x = papp evdref coq_eq_rect @@ -188,15 +199,15 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) aux (hdy :: tele) (subst1 hdx restT) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some (fun x -> - let term = EConstr.of_constr (co x) in - Typing.e_solve_evars env evdref term) + let term = co x in + EConstr.of_constr (Typing.e_solve_evars env evdref term)) in - if isEvar c || isEvar c' || not (Program.is_program_generalized_coercion ()) then + if isEvar !evdref c || isEvar !evdref c' || not (Program.is_program_generalized_coercion ()) then (* Second-order unification needed. *) raise NoSubtacCoercion; aux [] typ typ' 0 (fun x -> x) in - match (kind_of_term x, kind_of_term y) with + match (EConstr.kind !evdref x, EConstr.kind !evdref y) with | Sort s, Sort s' -> (match s, s' with | Prop x, Prop y when x == y -> None @@ -207,7 +218,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let name' = Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env)) in - let env' = push_rel (LocalAssum (name', a')) env in + let env' = push_rel (local_assum (name', a')) env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) let coec1 = app_opt env' evdref c1 (mkRel 1) in @@ -224,7 +235,7 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) (mkApp (lift 1 f, [| coec1 |]))))) | App (c, l), App (c', l') -> - (match kind_of_term c, kind_of_term c' with + (match EConstr.kind !evdref c, EConstr.kind !evdref c' with Ind (i, u), Ind (i', u') -> (* Inductive types *) let len = Array.length l in let sigT = delayed_force sigT_typ in @@ -241,23 +252,21 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) in let c1 = coerce_unify env a a' in let remove_head a c = - match kind_of_term c with + match EConstr.kind !evdref c with | Lambda (n, t, t') -> c, t' | Evar (k, args) -> - let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k, Array.map EConstr.of_constr args) in + let (evs, t) = Evardefine.define_evar_as_lambda env !evdref (k,args) in evdref := evs; - let t = EConstr.Unsafe.to_constr t in - let (n, dom, rng) = destLambda t in - let dom = whd_evar !evdref dom in - if isEvar dom then - let (domk, args) = destEvar dom in - evdref := define domk a !evdref; + let (n, dom, rng) = destLambda !evdref t in + if isEvar !evdref dom then + let (domk, args) = destEvar !evdref dom in + evdref := define domk (EConstr.Unsafe.to_constr a) !evdref; else (); t, rng | _ -> raise NoSubtacCoercion in let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in - let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in + let env' = push_rel (local_assum (Name Namegen.default_dependent_ident, a)) env in let c2 = coerce_unify env' b b' in match c1, c2 with | None, None -> None @@ -297,30 +306,30 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) let evm = !evdref in (try subco () with NoSubtacCoercion -> - let typ = Typing.unsafe_type_of env evm (EConstr.of_constr c) in - let typ' = Typing.unsafe_type_of env evm (EConstr.of_constr c') in - coerce_application typ typ' c c' l l') + let typ = Typing.unsafe_type_of env evm c in + let typ' = Typing.unsafe_type_of env evm c' in + coerce_application (EConstr.of_constr typ) (EConstr.of_constr typ') c c' l l') else subco () - | x, y when Constr.equal c c' -> + | x, y when EConstr.eq_constr !evdref c c' -> if Int.equal (Array.length l) (Array.length l') then let evm = !evdref in - let lam_type = Typing.unsafe_type_of env evm (EConstr.of_constr c) in - let lam_type' = Typing.unsafe_type_of env evm (EConstr.of_constr c') in - coerce_application lam_type lam_type' c c' l l' + let lam_type = Typing.unsafe_type_of env evm c in + let lam_type' = Typing.unsafe_type_of env evm c' in + coerce_application (EConstr.of_constr lam_type) (EConstr.of_constr lam_type') c c' l l' else subco () | _ -> subco ()) | _, _ -> subco () and subset_coerce env evdref x y = - match disc_subset x with + match disc_subset !evdref x with Some (u, p) -> let c = coerce_unify env u y in let f x = app_opt env evdref c (papp evdref sig_proj1 [| u; p; x |]) in Some f | None -> - match disc_subset y with + match disc_subset !evdref y with Some (u, p) -> let c = coerce_unify env x u in Some @@ -337,8 +346,8 @@ let app_coercion env evdref coercion v = match coercion with | None -> v | Some f -> - let v' = Typing.e_solve_evars env evdref (EConstr.of_constr (f v)) in - whd_betaiota !evdref (EConstr.of_constr v') + let v' = Typing.e_solve_evars env evdref (f v) in + EConstr.of_constr (whd_betaiota !evdref (EConstr.of_constr v')) let coerce_itf loc env evd v t c1 = let evdref = ref evd in @@ -358,7 +367,7 @@ let apply_coercion env sigma p hj typ_cl = (fun (ja,typ_cl,sigma) i -> let ((fv,isid,isproj),ctx) = coercion_value i in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - let argl = (class_args_of env sigma (EConstr.of_constr typ_cl))@[ja.uj_val] in + let argl = (class_args_of env sigma typ_cl)@[EConstr.of_constr ja.uj_val] in let sigma, jres = apply_coercion_args env sigma true isproj argl fv in @@ -366,7 +375,7 @@ let apply_coercion env sigma p hj typ_cl = { uj_val = ja.uj_val; uj_type = jres.uj_type } else jres), - jres.uj_type,sigma) + EConstr.of_constr jres.uj_type,sigma) (hj,typ_cl,sigma) p in evd, j with NoCoercion as e -> raise e @@ -375,7 +384,8 @@ let apply_coercion env sigma p hj typ_cl = (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core env evd j = let t = whd_all env evd (EConstr.of_constr j.uj_type) in - match EConstr.kind evd (EConstr.of_constr t) with + let t = EConstr.of_constr t in + match EConstr.kind evd t with | Prod (_,_,_) -> (evd,j) | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product evd ev in @@ -389,7 +399,7 @@ let inh_app_fun_core env evd j = try let evdref = ref evd in let coercef, t = mu env evdref t in - let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in + let res = { uj_val = EConstr.Unsafe.to_constr (app_opt env evdref coercef (EConstr.of_constr j.uj_val)); uj_type = EConstr.Unsafe.to_constr t } in (!evdref, res) with NoSubtacCoercion | NoCoercion -> (evd,j) @@ -427,10 +437,10 @@ let inh_coerce_to_sort loc env evd j = let inh_coerce_to_base loc env evd j = if Flags.is_program_mode () then let evdref = ref evd in - let ct, typ' = mu env evdref j.uj_type in + let ct, typ' = mu env evdref (EConstr.of_constr j.uj_type) in let res = - { uj_val = app_coercion env evdref ct j.uj_val; - uj_type = typ' } + { uj_val = EConstr.Unsafe.to_constr (app_coercion env evdref ct (EConstr.of_constr j.uj_val)); + uj_type = EConstr.Unsafe.to_constr typ' } in !evdref, res else (evd, j) @@ -442,33 +452,35 @@ let inh_coerce_to_prod loc env evd t = else (evd, t) let inh_coerce_to_fail env evd rigidonly v t c1 = - if rigidonly && not (Heads.is_rigid env c1 && Heads.is_rigid env t) + if rigidonly && not (Heads.is_rigid env (EConstr.Unsafe.to_constr c1) && Heads.is_rigid env (EConstr.Unsafe.to_constr t)) then raise NoCoercion else let evd, v', t' = try - let t2,t1,p = lookup_path_between env evd (EConstr.of_constr t,EConstr.of_constr c1) in + let t2,t1,p = lookup_path_between env evd (t,c1) in match v with | Some v -> let evd,j = apply_coercion env evd p - {uj_val = v; uj_type = t} t2 in - evd, Some j.uj_val, j.uj_type + {uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr t} t2 in + evd, Some (EConstr.of_constr j.uj_val), (EConstr.of_constr j.uj_type) | None -> evd, None, t with Not_found -> raise NoCoercion in - try (the_conv_x_leq env (EConstr.of_constr t') (EConstr.of_constr c1) evd, v') + try (the_conv_x_leq env t' c1 evd, v') with UnableToUnify _ -> raise NoCoercion let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = - try (the_conv_x_leq env (EConstr.of_constr t) (EConstr.of_constr c1) evd, v) + let open EConstr in + let open Vars in + try (the_conv_x_leq env t c1 evd, v) with UnableToUnify (best_failed_evd,e) -> try inh_coerce_to_fail env evd rigidonly v t c1 with NoCoercion -> match - kind_of_term (whd_all env evd (EConstr.of_constr t)), - kind_of_term (whd_all env evd (EConstr.of_constr c1)) + EConstr.kind evd (EConstr.of_constr (whd_all env evd t)), + EConstr.kind evd (EConstr.of_constr (whd_all env evd c1)) with | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) @@ -481,16 +493,16 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = | Anonymous -> Name Namegen.default_dependent_ident | _ -> name in let open Context.Rel.Declaration in - let env1 = push_rel (LocalAssum (name,u1)) env in + let env1 = push_rel (local_assum (name,u1)) env in let (evd', v1) = inh_conv_coerce_to_fail loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in let v1 = Option.get v1 in - let v2 = Option.map (fun v -> beta_applist evd' (EConstr.of_constr (lift 1 v),[EConstr.of_constr v1])) v in + let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in let t2 = match v2 with - | None -> subst_term evd' (EConstr.of_constr v1) (EConstr.of_constr t2) + | None -> subst_term evd' v1 t2 | Some v2 -> Retyping.get_type_of env1 evd' (EConstr.of_constr v2) in - let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in + let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly (Option.map EConstr.of_constr v2) (EConstr.of_constr t2) u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) @@ -498,27 +510,27 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = let (evd', val') = try - inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail loc env evd rigidonly (Some (EConstr.of_constr cj.uj_val)) (EConstr.of_constr cj.uj_type) t with NoCoercionNoUnifier (best_failed_evd,e) -> try if Flags.is_program_mode () then - coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t + coerce_itf loc env evd (Some (EConstr.of_constr cj.uj_val)) (EConstr.of_constr cj.uj_type) t else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> - error_actual_type ~loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj (EConstr.Unsafe.to_constr t) e | NoSubtacCoercion -> let evd' = saturate_evd env evd in try if evd' == evd then - error_actual_type ~loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj (EConstr.Unsafe.to_constr t) e else - inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t + inh_conv_coerce_to_fail loc env evd' rigidonly (Some (EConstr.of_constr cj.uj_val)) (EConstr.of_constr cj.uj_type) t with NoCoercionNoUnifier (_evd,_error) -> - error_actual_type ~loc env best_failed_evd cj t e + error_actual_type ~loc env best_failed_evd cj (EConstr.Unsafe.to_constr t) e in let val' = match val' with Some v -> v | None -> assert(false) in - (evd',{ uj_val = val'; uj_type = t }) + (evd',{ uj_val = EConstr.Unsafe.to_constr val'; uj_type = EConstr.Unsafe.to_constr t }) let inh_conv_coerce_to resolve_tc = inh_conv_coerce_to_gen resolve_tc false let inh_conv_coerce_rigid_to resolve_tc = inh_conv_coerce_to_gen resolve_tc true diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index 68f9a2e681..62d4fb004d 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -36,7 +36,7 @@ val inh_coerce_to_base : Loc.t -> (** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *) val inh_coerce_to_prod : Loc.t -> - env -> evar_map -> types -> evar_map * types + env -> evar_map -> EConstr.types -> evar_map * EConstr.types (** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an object of type [t]; i.e. it inserts a coercion into [j], if needed, in such @@ -44,16 +44,16 @@ val inh_coerce_to_prod : Loc.t -> applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) val inh_conv_coerce_to : bool -> Loc.t -> - env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment + env -> evar_map -> unsafe_judgment -> EConstr.types -> evar_map * unsafe_judgment val inh_conv_coerce_rigid_to : bool -> Loc.t -> - env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment + env -> evar_map -> unsafe_judgment -> EConstr.types -> evar_map * unsafe_judgment (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) val inh_conv_coerces_to : Loc.t -> - env -> evar_map -> types -> types -> evar_map + env -> evar_map -> EConstr.types -> EConstr.types -> evar_map (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 28ba60812b..18731f1e90 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -359,7 +359,7 @@ let allow_anonymous_refs = ref false let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function | None -> j | Some t -> - evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j t + evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j (EConstr.of_constr t) let check_instance loc subst = function | [] -> () @@ -770,8 +770,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match tycon with | None -> evd, tycon | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd ty in - evd, Some ty') + let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd (EConstr.of_constr ty) in + evd, Some (EConstr.Unsafe.to_constr ty')) evdref tycon in let (name',dom,rng) = evd_comb1 (split_tycon loc env.ExtraEnv.env) evdref tycon' in diff --git a/pretyping/program.ml b/pretyping/program.ml index 4b6137b539..2606d91f35 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -29,8 +29,9 @@ let init_constant dir s () = coq_constant "Program" dir s let init_reference dir s () = coq_reference "Program" dir s let papp evdref r args = + let open EConstr in let gr = delayed_force r in - mkApp (Evarutil.e_new_global evdref gr, args) + mkApp (EConstr.of_constr (Evarutil.e_new_global evdref gr), args) let sig_typ = init_reference ["Init"; "Specif"] "sig" let sig_intro = init_reference ["Init"; "Specif"] "exist" diff --git a/pretyping/program.mli b/pretyping/program.mli index 023ff8ca58..64c4ca2c24 100644 --- a/pretyping/program.mli +++ b/pretyping/program.mli @@ -36,7 +36,7 @@ val mk_coq_and : constr list -> constr val mk_coq_not : constr -> constr (** Polymorphic application of delayed references *) -val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr +val papp : Evd.evar_map ref -> (unit -> global_reference) -> EConstr.constr array -> EConstr.constr val get_proofs_transparency : unit -> bool val is_program_cases : unit -> bool diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 786cfd31ff..b568dd044e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1225,7 +1225,7 @@ let is_mimick_head ts f = let try_to_coerce env evd c cty tycon = let j = make_judge c cty in - let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in + let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j (EConstr.of_constr tycon) in let evd' = Evarconv.consider_remaining_unif_problems env evd' in let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in (evd',j'.uj_val) -- cgit v1.2.3 From 67dc22d8389234d0c9b329944ff579e7056b7250 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Nov 2016 10:57:05 +0100 Subject: Cases API using EConstr. --- pretyping/cases.ml | 454 ++++++++++++++++++++++++++------------------- pretyping/cases.mli | 11 +- pretyping/indrec.ml | 5 +- pretyping/inductiveops.ml | 13 +- pretyping/inductiveops.mli | 4 +- pretyping/program.ml | 6 +- pretyping/program.mli | 4 +- 7 files changed, 282 insertions(+), 215 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 96c61647c3..1a181202c7 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -6,14 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open Pp open CErrors open Util open Names open Nameops open Term -open Vars open Termops +open EConstr +open Vars open Namegen open Declarations open Inductiveops @@ -35,6 +38,14 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration +let local_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + RelDecl.LocalAssum (na, inj t) + +let local_def (na, b, t) = + let inj = EConstr.Unsafe.to_constr in + RelDecl.LocalDef (na, inj b, inj t) + (* Pattern-matching errors *) type pattern_matching_error = @@ -78,6 +89,9 @@ let list_try_compile f l = let force_name = let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na +let make_judge c ty = + make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr ty) + (************************************************************************) (* Pattern-matching compilation (Cases) *) (************************************************************************) @@ -99,11 +113,13 @@ let make_anonymous_patvars n = let relocate_rel n1 n2 k j = if Int.equal j (n1 + k) then n2+k else j -let rec relocate_index n1 n2 k t = match kind_of_term t with +let rec relocate_index sigma n1 n2 k t = + let open EConstr in + match EConstr.kind sigma t with | Rel j when Int.equal j (n1 + k) -> mkRel (n2+k) | Rel j when j < n1+k -> t | Rel j when j > n1+k -> t - | _ -> map_constr_with_binders succ (relocate_index n1 n2) k t + | _ -> EConstr.map_with_binders sigma succ (relocate_index sigma n1 n2) k t (**********************************************************************) (* Structures used in compiling pattern-matching *) @@ -283,16 +299,18 @@ let inductive_template evdref env tmloc ind = (fun decl (subst,evarl,n) -> match decl with | LocalAssum (na,ty) -> + let ty = EConstr.of_constr ty in let ty' = substl subst ty in - let e = e_new_evar env evdref ~src:(hole_source n) ty' in + let e = EConstr.of_constr (e_new_evar env evdref ~src:(hole_source n) (EConstr.Unsafe.to_constr ty')) in (e::subst,e::evarl,n+1) | LocalDef (na,b,ty) -> + let b = EConstr.of_constr b in (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = - let (IndType(indf,realargs) as ind) = find_rectype env sigma (EConstr.of_constr typ) in + let (IndType(indf,realargs) as ind) = find_rectype env sigma typ in let names = match realnames with | Some names -> names @@ -308,21 +326,23 @@ let inh_coerce_to_ind evdref env loc ty tyi = constructor and renounce if not able to give more information *) (* devrait être indifférent d'exiger leq ou pas puisque pour un inductif cela doit être égal *) - if not (e_cumul env evdref (EConstr.of_constr expected_typ) (EConstr.of_constr ty)) then evdref := sigma + if not (e_cumul env evdref expected_typ ty) then evdref := sigma -let binding_vars_of_inductive = function +let binding_vars_of_inductive sigma = function | NotInd _ -> [] - | IsInd (_,IndType(_,realargs),_) -> List.filter isRel realargs + | IsInd (_,IndType(_,realargs),_) -> List.filter (isRel sigma) (List.map EConstr.of_constr realargs) let extract_inductive_data env sigma decl = match decl with | LocalAssum (_,t) -> + let t = EConstr.of_constr t in let tmtyp = try try_find_ind env sigma t None with Not_found -> NotInd (None,t) in - let tmtypvars = binding_vars_of_inductive tmtyp in + let tmtypvars = binding_vars_of_inductive sigma tmtyp in (tmtyp,tmtypvars) | LocalDef (_,_,t) -> + let t = EConstr.of_constr t in (NotInd (None, t), []) let unify_tomatch_with_patterns evdref env loc typ pats realnames = @@ -336,7 +356,7 @@ let unify_tomatch_with_patterns evdref env loc typ pats realnames = let find_tomatch_tycon evdref env loc = function (* Try if some 'in I ...' is present and can be used as a constraint *) | Some (_,ind,realnal) -> - mk_tycon (EConstr.of_constr (inductive_template evdref env loc ind)),Some (List.rev realnal) + mk_tycon (inductive_template evdref env loc ind),Some (List.rev realnal) | None -> empty_tycon,None @@ -346,12 +366,12 @@ let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = let j = typing_fun tycon env evdref tomatch in let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !evdref j in evdref := evd; - let typ = nf_evar !evdref j.uj_type in + let typ = EConstr.of_constr (nf_evar !evdref j.uj_type) in let t = try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in - (j.uj_val,t) + (EConstr.of_constr j.uj_val,t) let coerce_to_indtype typing_fun evdref env matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in @@ -364,7 +384,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = - let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in e + let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in EConstr.of_constr e let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in @@ -390,13 +410,13 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = | Some (_,(ind,_)) -> let indt = inductive_template pb.evdref pb.env None ind in let current = - if List.is_empty deps && isEvar typ then + if List.is_empty deps && isEvar !(pb.evdref) typ then (* Don't insert coercions if dependent; only solve evars *) - let _ = e_cumul pb.env pb.evdref (EConstr.of_constr indt) (EConstr.of_constr typ) in + let _ = e_cumul pb.env pb.evdref indt typ in current else - (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env) - pb.evdref (make_judge current typ) (EConstr.of_constr indt)).uj_val in + EConstr.of_constr (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env) + pb.evdref (make_judge current typ) indt).uj_val in let sigma = !(pb.evdref) in (current,try_find_ind pb.env sigma indt names)) | _ -> (current,tmtyp) @@ -406,10 +426,10 @@ let type_of_tomatch = function | NotInd (_,t) -> t let map_tomatch_type f = function - | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type f ind,names) + | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type (fun c -> EConstr.Unsafe.to_constr (f (EConstr.of_constr c))) ind,names) | NotInd (c,t) -> NotInd (Option.map f c, f t) -let liftn_tomatch_type n depth = map_tomatch_type (liftn n depth) +let liftn_tomatch_type n depth = map_tomatch_type (Vars.liftn n depth) let lift_tomatch_type n = liftn_tomatch_type n 1 (**********************************************************************) @@ -435,7 +455,7 @@ let remove_current_pattern eqn = let push_current_pattern (cur,ty) eqn = match eqn.patterns with | pat::pats -> - let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in + let rhs_env = push_rel (local_def (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -537,8 +557,8 @@ let dependencies_in_pure_rhs nargs eqns = let dependent_decl sigma a = function - | LocalAssum (na,t) -> dependent sigma (EConstr.of_constr a) (EConstr.of_constr t) - | LocalDef (na,c,t) -> dependent sigma (EConstr.of_constr a) (EConstr.of_constr t) || dependent sigma (EConstr.of_constr a) (EConstr.of_constr c) + | LocalAssum (na,t) -> dependent sigma a (EConstr.of_constr t) + | LocalDef (na,c,t) -> dependent sigma a (EConstr.of_constr t) || dependent sigma a (EConstr.of_constr c) let rec dep_in_tomatch sigma n = function | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch sigma n l @@ -546,7 +566,7 @@ let rec dep_in_tomatch sigma n = function | [] -> false let dependencies_in_rhs sigma nargs current tms eqns = - match kind_of_term current with + match EConstr.kind sigma current with | Rel n when dep_in_tomatch sigma n tms -> List.make nargs true | _ -> dependencies_in_pure_rhs nargs eqns @@ -593,31 +613,31 @@ let find_dependencies_signature sigma deps_in_rhs typs = [relocate_index_tomatch 1 n tomatch] will go the way back. *) -let relocate_index_tomatch n1 n2 = +let relocate_index_tomatch sigma n1 n2 = let rec genrec depth = function | [] -> [] | Pushed (b,((c,tm),l,na)) :: rest -> - let c = relocate_index n1 n2 depth c in - let tm = map_tomatch_type (relocate_index n1 n2 depth) tm in + let c = relocate_index sigma n1 n2 depth c in + let tm = map_tomatch_type (relocate_index sigma n1 n2 depth) tm in let l = List.map (relocate_rel n1 n2 depth) l in Pushed (b,((c,tm),l,na)) :: genrec depth rest | Alias (initial,(na,c,d)) :: rest -> (* [c] is out of relocation scope *) - Alias (initial,(na,c,map_pair (relocate_index n1 n2 depth) d)) :: genrec depth rest + Alias (initial,(na,c,map_pair (relocate_index sigma n1 n2 depth) d)) :: genrec depth rest | NonDepAlias :: rest -> NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in - Abstract (i, RelDecl.map_constr (relocate_index n1 n2 depth) d) + Abstract (i, RelDecl.map_constr (fun c -> EConstr.Unsafe.to_constr (relocate_index sigma n1 n2 depth (EConstr.of_constr c))) d) :: genrec (depth+1) rest in genrec 0 (* [replace_tomatch n c tomatch] replaces [Rel n] by [c] in [tomatch] *) -let rec replace_term n c k t = - if isRel t && Int.equal (destRel t) (n + k) then lift k c - else map_constr_with_binders succ (replace_term n c) k t +let rec replace_term sigma n c k t = + if isRel sigma t && Int.equal (destRel sigma t) (n + k) then Vars.lift k c + else EConstr.map_with_binders sigma succ (replace_term sigma n c) k t let length_of_tomatch_type_sign na t = let l = match na with @@ -628,21 +648,21 @@ let length_of_tomatch_type_sign na t = | NotInd _ -> l | IsInd (_, _, names) -> List.length names + l -let replace_tomatch n c = +let replace_tomatch sigma n c = let rec replrec depth = function | [] -> [] | Pushed (initial,((b,tm),l,na)) :: rest -> - let b = replace_term n c depth b in - let tm = map_tomatch_type (replace_term n c depth) tm in + let b = replace_term sigma n c depth b in + let tm = map_tomatch_type (replace_term sigma n c depth) tm in List.iter (fun i -> if Int.equal i (n + depth) then anomaly (Pp.str "replace_tomatch")) l; Pushed (initial,((b,tm),l,na)) :: replrec depth rest | Alias (initial,(na,b,d)) :: rest -> (* [b] is out of replacement scope *) - Alias (initial,(na,b,map_pair (replace_term n c depth) d)) :: replrec depth rest + Alias (initial,(na,b,map_pair (replace_term sigma n c depth) d)) :: replrec depth rest | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> - Abstract (i, RelDecl.map_constr (replace_term n c depth) d) + Abstract (i, RelDecl.map_constr (fun t -> EConstr.Unsafe.to_constr (replace_term sigma n c depth (EConstr.of_constr t))) d) :: replrec (depth+1) rest in replrec 0 @@ -667,7 +687,7 @@ let rec liftn_tomatch_stack n depth = function NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i map_predicate f (k+1) ccl rest -let noccur_predicate_between n = map_predicate (noccur_between n) +let noccur_predicate_between sigma n = map_predicate (noccur_between sigma n) let liftn_predicate n = map_predicate (liftn n) let lift_predicate n = liftn_predicate n 1 -let regeneralize_index_predicate n = map_predicate (relocate_index n 1) 0 +let regeneralize_index_predicate sigma n = map_predicate (relocate_index sigma n 1) 0 let substnl_predicate sigma = map_predicate (substnl sigma) @@ -857,7 +877,7 @@ let specialize_predicate_var (cur,typ,dep) tms ccl = let l = match typ with | IsInd (_, IndType (_, _), []) -> [] - | IsInd (_, IndType (_, realargs), names) -> realargs + | IsInd (_, IndType (_, realargs), names) -> List.map EConstr.of_constr realargs | NotInd _ -> [] in subst_predicate (l,c) ccl tms @@ -870,13 +890,13 @@ let specialize_predicate_var (cur,typ,dep) tms ccl = (* We first need to lift t(x) s.t. it is typed in Gamma, X:=rargs, x' *) (* then we have to replace x by x' in t(x) and y by y' in P *) (*****************************************************************************) -let generalize_predicate (names,na) ny d tms ccl = +let generalize_predicate sigma (names,na) ny d tms ccl = let () = match na with | Anonymous -> anomaly (Pp.str "Undetected dependency") | _ -> () in let p = List.length names + 1 in let ccl = lift_predicate 1 ccl tms in - regeneralize_index_predicate (ny+p+1) ccl tms + regeneralize_index_predicate sigma (ny+p+1) ccl tms (*****************************************************************************) (* We just matched over cur:ind(realargs) in the following matching problem *) @@ -906,7 +926,7 @@ let rec extract_predicate ccl = function subst1 cur pred end | Pushed (_,((cur,IsInd (_,IndType(_,realargs),_)),_,na))::tms -> - let realargs = List.rev realargs in + let realargs = List.rev_map EConstr.of_constr realargs in let k, nrealargs = match na with | Anonymous -> 0, realargs | Name _ -> 1, (cur :: realargs) @@ -925,9 +945,9 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = (* that are rels, consistently with the specialization made in *) (* build_branch *) let tms = List.fold_right2 (fun par arg tomatch -> - match kind_of_term par with - | Rel i -> relocate_index_tomatch (i+n) (destRel arg) tomatch - | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list 0 sign) + match EConstr.kind sigma par with + | Rel i -> relocate_index_tomatch sigma (i+n) (destRel sigma arg) tomatch + | _ -> tomatch) (realargs@[cur]) (List.map EConstr.of_constr (Context.Rel.to_extended_list 0 sign)) (lift_tomatch_stack n tms) in (* Pred is already dependent in the current term to match (if *) (* (na<>Anonymous) and its realargs; we just need to adjust it to *) @@ -939,7 +959,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = let pred = extract_predicate ccl tms in (* Build the predicate properly speaking *) let sign = List.map2 set_name (na::names) sign in - it_mkLambda_or_LetIn_name env pred sign + EConstr.of_constr (it_mkLambda_or_LetIn_name env (EConstr.Unsafe.to_constr pred) sign) (* [expand_arg] is used by [specialize_predicate] if Yk denotes [Xk;xk] or [Xk], @@ -974,6 +994,10 @@ let add_assert_false_case pb tomatch = let adjust_impossible_cases pb pred tomatch submat = match submat with | [] -> + (** FIXME: This breaks if using evar-insensitive primitives. In particular, + this means that the Evd.define below may redefine an already defined + evar. See e.g. first definition of test for bug #3388. *) + let pred = EConstr.Unsafe.to_constr pred in begin match kind_of_term pred with | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> if not (Evd.is_defined !(pb.evdref) evk) then begin @@ -1024,27 +1048,30 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* We prepare the substitution of X and x:I(X) *) let realargsi = if not (Int.equal nrealargs 0) then - subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs) + CVars.subst_of_rel_context_instance arsign (Array.to_list cs.cs_concl_realargs) else [] in + let realargsi = List.map EConstr.of_constr realargsi in let copti = match depna with | Anonymous -> None - | Name _ -> Some (build_dependent_constructor cs) + | Name _ -> Some (EConstr.of_constr (build_dependent_constructor cs)) in (* The substituends realargsi, copti are all defined in gamma, x1...xn *) (* We need _parallel_ bindings to get gamma, x1...xn |- PI tms. ccl'' *) (* Note: applying the substitution in tms is not important (is it sure?) *) let ccl'' = - whd_betaiota Evd.empty (EConstr.of_constr (subst_predicate (realargsi, copti) ccl' tms)) in + whd_betaiota Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in + let ccl'' = EConstr.of_constr ccl'' in (* We adjust ccl st: gamma, x'1..x'n, x1..xn, tms |- ccl'' *) let ccl''' = liftn_predicate n (n+1) ccl'' tms in (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*) snd (List.fold_left (expand_arg tms) (1,ccl''') newtomatchs) let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms = + let realargs = List.map EConstr.of_constr realargs in let pred = abstract_predicate env !evdref indf current realargs dep tms p in - (pred, whd_betaiota !evdref - (EConstr.of_constr (applist (pred, realargs@[current])))) + (pred, EConstr.of_constr (whd_betaiota !evdref + (applist (pred, realargs@[current])))) (* Take into account that a type has been discovered to be inductive, leading to more dependencies in the predicate if the type has indices *) @@ -1065,40 +1092,40 @@ let adjust_predicate_from_tomatch tomatch (current,typ as ct) pb = (* Remove commutative cuts that turn out to be non-dependent after some evars have been instantiated *) -let rec ungeneralize n ng body = - match kind_of_term body with +let rec ungeneralize sigma n ng body = + match EConstr.kind sigma body with | Lambda (_,_,c) when Int.equal ng 0 -> subst1 (mkRel n) c | Lambda (na,t,c) -> (* We traverse an inner generalization *) - mkLambda (na,t,ungeneralize (n+1) (ng-1) c) + mkLambda (na,t,ungeneralize sigma (n+1) (ng-1) c) | LetIn (na,b,t,c) -> (* We traverse an alias *) - mkLetIn (na,b,t,ungeneralize (n+1) ng c) + mkLetIn (na,b,t,ungeneralize sigma (n+1) ng c) | Case (ci,p,c,brs) -> (* We traverse a split *) let p = - let sign,p = decompose_lam_assum p in - let sign2,p = decompose_prod_n_assum ng p in - let p = prod_applist p [mkRel (n+List.length sign+ng)] in + let sign,p = decompose_lam_assum sigma p in + let sign2,p = decompose_prod_n_assum sigma ng p in + let p = prod_applist sigma p [mkRel (n+List.length sign+ng)] in it_mkLambda_or_LetIn (it_mkProd_or_LetIn p sign2) sign in mkCase (ci,p,c,Array.map2 (fun q c -> - let sign,b = decompose_lam_n_decls q c in - it_mkLambda_or_LetIn (ungeneralize (n+q) ng b) sign) + let sign,b = decompose_lam_n_decls sigma q c in + it_mkLambda_or_LetIn (ungeneralize sigma (n+q) ng b) sign) ci.ci_cstr_ndecls brs) | App (f,args) -> (* We traverse an inner generalization *) - assert (isCase f); - mkApp (ungeneralize n (ng+Array.length args) f,args) + assert (isCase sigma f); + mkApp (ungeneralize sigma n (ng+Array.length args) f,args) | _ -> assert false -let ungeneralize_branch n k (sign,body) cs = - (sign,ungeneralize (n+cs.cs_nargs) k body) +let ungeneralize_branch sigma n k (sign,body) cs = + (sign,ungeneralize sigma (n+cs.cs_nargs) k body) let rec is_dependent_generalization sigma ng body = - match kind_of_term body with + match EConstr.kind sigma body with | Lambda (_,_,c) when Int.equal ng 0 -> - not (EConstr.Vars.noccurn sigma 1 (EConstr.of_constr c)) + not (noccurn sigma 1 c) | Lambda (na,t,c) -> (* We traverse an inner generalization *) is_dependent_generalization sigma (ng-1) c @@ -1108,12 +1135,12 @@ let rec is_dependent_generalization sigma ng body = | Case (ci,p,c,brs) -> (* We traverse a split *) Array.exists2 (fun q c -> - let _,b = decompose_lam_n_decls q c in + let _,b = decompose_lam_n_decls sigma q c in is_dependent_generalization sigma ng b) ci.ci_cstr_ndecls brs | App (g,args) -> (* We traverse an inner generalization *) - assert (isCase g); + assert (isCase sigma g); is_dependent_generalization sigma (ng+Array.length args) g | _ -> assert false @@ -1140,9 +1167,9 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = (* terms by its actual value in both the remaining terms to match and *) (* the bodies of the Case *) let pred = lift_predicate (-1) pred tomatch in - let tomatch = relocate_index_tomatch 1 (n+1) tomatch in + let tomatch = relocate_index_tomatch evd 1 (n+1) tomatch in let tomatch = lift_tomatch_stack (-1) tomatch in - let brs = Array.map2 (ungeneralize_branch n k) brs cs in + let brs = Array.map2 (ungeneralize_branch evd n k) brs cs in aux k brs tomatch pred tocheck deps | _ -> assert false in aux 0 brs tomatch pred tocheck deps @@ -1194,24 +1221,24 @@ let rec generalize_problem names pb = function | [] -> pb, [] | i::l -> let pb',deps = generalize_problem names pb l in - let d = map_constr (lift i) (Environ.lookup_rel i pb.env) in + let d = map_constr (CVars.lift i) (Environ.lookup_rel i pb.env) in begin match d with | LocalDef (Anonymous,_,_) -> pb', deps | _ -> (* for better rendering *) let d = RelDecl.map_type (fun c -> whd_betaiota !(pb.evdref) (EConstr.of_constr c)) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in - let tomatch = relocate_index_tomatch (i+1) 1 tomatch in + let tomatch = relocate_index_tomatch !(pb.evdref) (i+1) 1 tomatch in { pb' with tomatch = Abstract (i,d) :: tomatch; - pred = generalize_predicate names i d pb'.tomatch pb'.pred }, + pred = generalize_predicate !(pb'.evdref) names i d pb'.tomatch pb'.pred }, i::deps end (* No more patterns: typing the right-hand side of equations *) let build_leaf pb = let rhs = extract_rhs pb in - let j = pb.typing_function (mk_tycon (EConstr.of_constr pb.pred)) rhs.rhs_env pb.evdref rhs.it in + let j = pb.typing_function (mk_tycon pb.pred) rhs.rhs_env pb.evdref rhs.it in j_nf_evar !(pb.evdref) j (* Build the sub-pattern-matching problem for a given branch "C x1..xn as x" *) @@ -1238,7 +1265,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* We adjust the terms to match in the context they will be once the *) (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *) let typs' = - List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in + List.map_i (fun i d -> (mkRel i, map_constr (CVars.lift i) d)) 1 typs in let extenv = push_rel_context typs pb.env in @@ -1255,24 +1282,24 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* The dependent term to subst in the types of the remaining UnPushed terms is relative to the current context enriched by topushs *) - let ci = build_dependent_constructor const_info in + let ci = EConstr.of_constr (build_dependent_constructor const_info) in (* Current context Gamma has the form Gamma1;cur:I(realargs);Gamma2 *) (* We go from Gamma |- PI tms. pred to *) (* Gamma;x1..xn;curalias:I(x1..xn) |- PI tms'. pred' *) (* where, in tms and pred, those realargs that are vars are *) (* replaced by the corresponding xi and cur replaced by curalias *) - let cirealargs = Array.to_list const_info.cs_concl_realargs in + let cirealargs = Array.map_to_list EConstr.of_constr const_info.cs_concl_realargs in (* Do the specialization for terms to match *) let tomatch = List.fold_right2 (fun par arg tomatch -> - match kind_of_term par with - | Rel i -> replace_tomatch (i+const_info.cs_nargs) arg tomatch + match EConstr.kind !(pb.evdref) par with + | Rel i -> replace_tomatch !(pb.evdref) (i+const_info.cs_nargs) arg tomatch | _ -> tomatch) (current::realargs) (ci::cirealargs) (lift_tomatch_stack const_info.cs_nargs pb.tomatch) in let pred_is_not_dep = - noccur_predicate_between 1 (List.length realnames + 1) pb.pred tomatch in + noccur_predicate_between !(pb.evdref) 1 (List.length realnames + 1) pb.pred tomatch in let typs' = List.map2 @@ -1298,10 +1325,10 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn | Name _ -> let cur_alias = lift const_info.cs_nargs current in let ind = - appvect ( + mkApp ( applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), snd const_info.cs_cstr), - List.map (lift const_info.cs_nargs) const_info.cs_params), - const_info.cs_concl_realargs) in + List.map (EConstr.of_constr %> lift const_info.cs_nargs) const_info.cs_params), + Array.map EConstr.of_constr const_info.cs_concl_realargs) in Alias (initial,(aliasname,cur_alias,(ci,ind))) in let tomatch = List.rev_append (alias :: currents) tomatch in @@ -1361,13 +1388,14 @@ and match_current pb (initial,tomatch) = if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then compile_all_variables initial tomatch pb else + let realargs = List.map EConstr.of_constr realargs in (* We generalize over terms depending on current term to match *) let pb,deps = generalize_problem (names,dep) pb deps in (* We compile branches *) let brvals = Array.map2 (compile_branch initial current realargs (names,dep) deps pb arsign) eqns cstrs in (* We build the (elementary) case analysis *) - let depstocheck = current::binding_vars_of_inductive typ in + let depstocheck = current::binding_vars_of_inductive !(pb.evdref) typ in let brvals,tomatch,pred,inst = postprocess_dependencies !(pb.evdref) depstocheck brvals pb.tomatch pb.pred deps cstrs in @@ -1377,13 +1405,14 @@ and match_current pb (initial,tomatch) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in let ci = make_case_info pb.env (fst mind) pb.casestyle in - let pred = nf_betaiota !(pb.evdref) (EConstr.of_constr pred) in + let pred = nf_betaiota !(pb.evdref) pred in + let pred = EConstr.of_constr pred in let case = - make_case_or_project pb.env indf ci pred current brvals + make_case_or_project pb.env !(pb.evdref) indf ci pred current brvals in - Typing.check_allowed_sort pb.env !(pb.evdref) mind (EConstr.of_constr current) (EConstr.of_constr pred); - { uj_val = applist (case, inst); - uj_type = prod_applist typ inst } + Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; + { uj_val = EConstr.Unsafe.to_constr (applist (case, inst)); + uj_type = EConstr.Unsafe.to_constr (prod_applist !(pb.evdref) typ inst) } (* Building the sub-problem when all patterns are variables. Case @@ -1394,14 +1423,14 @@ and shift_problem ((current,t),_,na) pb = let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in let pb = { pb with - env = push_rel (LocalDef (na,current,ty)) pb.env; + env = push_rel (local_def (na,current,ty)) pb.env; tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; mat = List.map (push_current_pattern (current,ty)) pb.mat } in let j = compile pb in - { uj_val = subst1 current j.uj_val; - uj_type = subst1 current j.uj_type } + { uj_val = EConstr.Unsafe.to_constr (subst1 current (EConstr.of_constr j.uj_val)); + uj_type = EConstr.Unsafe.to_constr (subst1 current (EConstr.of_constr j.uj_type)) } (* Building the sub-problem when all patterns are variables, non-initial case. Variables which appear as subterms of constructor @@ -1424,7 +1453,7 @@ and compile_all_variables initial cur pb = (* Building the sub-problem when all patterns are variables *) and compile_branch initial current realargs names deps pb arsign eqns cstr = let sign, pb = build_branch initial current realargs deps names pb arsign eqns cstr in - sign, (compile pb).uj_val + sign, EConstr.of_constr (compile pb).uj_val (* Abstract over a declaration before continuing splitting *) and compile_generalization pb i d rest = @@ -1434,15 +1463,15 @@ and compile_generalization pb i d rest = tomatch = rest; mat = List.map (push_generalized_decl_eqn pb.env i d) pb.mat } in let j = compile pb in - { uj_val = mkLambda_or_LetIn d j.uj_val; - uj_type = mkProd_wo_LetIn d j.uj_type } + { uj_val = Term.mkLambda_or_LetIn d j.uj_val; + uj_type = Term.mkProd_wo_LetIn d j.uj_type } (* spiwack: the [initial] argument keeps track whether the alias has been introduced by a toplevel branch ([true]) or a deep one ([false]). *) and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = let f c t = - let alias = LocalDef (na,c,t) in + let alias = local_def (na,c,t) in let pb = { pb with env = push_rel alias pb.env; @@ -1451,12 +1480,13 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = history = pop_history_pattern pb.history; mat = List.map (push_alias_eqn alias) pb.mat } in let j = compile pb in + let sigma = !(pb.evdref) in { uj_val = - if isRel c || isVar c || count_occurrences !(pb.evdref) (EConstr.mkRel 1) (EConstr.of_constr j.uj_val) <= 1 then - subst1 c j.uj_val + if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) (EConstr.of_constr j.uj_val) <= 1 then + EConstr.Unsafe.to_constr (subst1 c (EConstr.of_constr j.uj_val)) else - mkLetIn (na,c,t,j.uj_val); - uj_type = subst1 c j.uj_type } in + EConstr.Unsafe.to_constr (mkLetIn (na,c,t,EConstr.of_constr j.uj_val)); + uj_type = EConstr.Unsafe.to_constr (subst1 c (EConstr.of_constr j.uj_type)) } in (* spiwack: when an alias appears on a deep branch, its non-expanded form is automatically a variable of the same name. We avoid introducing such superfluous aliases so that refines are elegant. *) @@ -1477,10 +1507,10 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = evaluation; the drawback is that it might duplicate the instances of the term to match when the corresponding variable is substituted by a non-evaluated expression *) - if not (Flags.is_program_mode ()) && (isRel orig || isVar orig) then + if not (Flags.is_program_mode ()) && (isRel sigma orig || isVar sigma orig) then (* Try to compile first using non expanded alias *) try - if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) (EConstr.of_constr orig)) + if initial then f orig (EConstr.of_constr (Retyping.get_type_of pb.env sigma orig)) else just_pop () with e when precatchable_exception e -> (* Try then to compile using expanded alias *) @@ -1495,7 +1525,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = (* Could be needed in case of a recursive call which requires to be on a variable for size reasons *) pb.evdref := sigma; - if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) (EConstr.of_constr orig)) + if initial then f orig (EConstr.of_constr (Retyping.get_type_of pb.env !(pb.evdref) orig)) else just_pop () @@ -1579,11 +1609,11 @@ let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = let (p, _, _) = lookup_rel_id x (rel_context extenv) in let rec traverse_local_defs p = match lookup_rel p extenv with - | LocalDef (_,c,_) -> assert (isRel c); traverse_local_defs (p + destRel c) + | LocalDef (_,c,_) -> assert (isRel sigma (EConstr.of_constr c)); traverse_local_defs (p + destRel sigma (EConstr.of_constr c)) | LocalAssum _ -> p in let p = traverse_local_defs p in let u = lift (n' - n) u in - try Some (p, u, EConstr.Unsafe.to_constr (expand_vars_in_term extenv sigma (EConstr.of_constr u))) + try Some (p, u, expand_vars_in_term extenv sigma u) (* pedrot: does this really happen to raise [Failure _]? *) with Failure _ -> None in let subst0 = List.map_filter map subst in @@ -1613,8 +1643,9 @@ let rec list_assoc_in_triple x = function *) let abstract_tycon loc env evdref subst tycon extenv t = - let t = nf_betaiota !evdref (EConstr.of_constr t) in (* it helps in some cases to remove K-redex*) - let src = match kind_of_term t with + let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*) + let t = EConstr.of_constr t in + let src = match EConstr.kind !evdref t with | Evar (evk,_) -> (loc,Evar_kinds.SubEvar evk) | _ -> (loc,Evar_kinds.CasesType true) in let subst0,t0 = adjust_to_extended_env_and_remove_deps env extenv !evdref subst t in @@ -1624,10 +1655,10 @@ let abstract_tycon loc env evdref subst tycon extenv t = by an evar that may depend (and only depend) on the corresponding convertible subterms of the substitution *) let rec aux (k,env,subst as x) t = - let t = whd_evar !evdref t in match kind_of_term t with + match EConstr.kind !evdref t with | Rel n when is_local_def (lookup_rel n env) -> t | Evar ev -> - let ty = get_type_of env !evdref (EConstr.of_constr t) in + let ty = get_type_of env !evdref t in let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref (EConstr.of_constr ty) in let inst = List.map_i @@ -1635,39 +1666,43 @@ let abstract_tycon loc env evdref subst tycon extenv t = try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context env) in let ev' = e_new_evar env evdref ~src ty in - let ev = (fst ev, Array.map EConstr.of_constr (snd ev)) in - begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,EConstr.of_constr (substl inst ev')) with + let ev' = EConstr.of_constr ev' in + begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false end; ev' | _ -> - let good = List.filter (fun (_,u,_) -> is_conv_leq env !evdref (EConstr.of_constr t) (EConstr.of_constr u)) subst in + let good = List.filter (fun (_,u,_) -> is_conv_leq env !evdref t u) subst in match good with | [] -> - let self env c = EConstr.of_constr (aux env (EConstr.Unsafe.to_constr c)) in - EConstr.Unsafe.to_constr (map_constr_with_full_binders !evdref push_binder self x (EConstr.of_constr t)) + map_constr_with_full_binders !evdref push_binder aux x t | (_, _, u) :: _ -> (* u is in extenv *) let vl = List.map pi1 good in let ty = - let ty = get_type_of env !evdref (EConstr.of_constr t) in - Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref (EConstr.of_constr ty) + let ty = get_type_of env !evdref t in + let ty = EConstr.of_constr ty in + Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in + let ty = EConstr.of_constr ty in let ty = lift (-k) (aux x ty) in - let depvl = free_rels !evdref (EConstr.of_constr ty) in + let depvl = free_rels !evdref ty in let inst = List.map_i (fun i _ -> if Int.List.mem i vl then u else mkRel i) 1 (rel_context extenv) in let rel_filter = - List.map (fun a -> not (isRel a) || dependent !evdref (EConstr.of_constr a) (EConstr.of_constr u) - || Int.Set.mem (destRel a) depvl) inst in + List.map (fun a -> not (isRel !evdref a) || dependent !evdref a u + || Int.Set.mem (destRel !evdref a) depvl) inst in let named_filter = - List.map (fun d -> local_occur_var !evdref (NamedDecl.get_id d) (EConstr.of_constr u)) + List.map (fun d -> local_occur_var !evdref (NamedDecl.get_id d) u) (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in + let candidates = List.map EConstr.Unsafe.to_constr candidates in + let ty = EConstr.Unsafe.to_constr ty in let ev = e_new_evar extenv evdref ~src ~filter ~candidates ty in + let ev = EConstr.of_constr ev in lift k ev in aux (0,extenv,subst0) t0 @@ -1681,15 +1716,17 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let n' = Context.Rel.length (rel_context tycon_env) in let impossible_case_type, u = e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in + let impossible_case_type = EConstr.of_constr impossible_case_type in (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in - let evd,tt = Typing.type_of extenv !evdref (EConstr.of_constr t) in + let evd,tt = Typing.type_of extenv !evdref t in + let tt = EConstr.of_constr tt in evdref := evd; (t,tt) in - let b = e_cumul env evdref (EConstr.of_constr tt) (EConstr.mkSort s) (* side effect *) in + let b = e_cumul env evdref tt (mkSort s) (* side effect *) in if not b then anomaly (Pp.str "Build_tycon: should be a type"); - { uj_val = t; uj_type = tt } + { uj_val = EConstr.Unsafe.to_constr t; uj_type = EConstr.Unsafe.to_constr tt } (* For a multiple pattern-matching problem Xi on t1..tn with return * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return @@ -1703,13 +1740,13 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = - let id = next_name_away (named_hd env t Anonymous) avoid in + let id = next_name_away (named_hd env (EConstr.Unsafe.to_constr t) Anonymous) avoid in PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = - match kind_of_term (whd_all env sigma (EConstr.of_constr t)) with + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc - | App (f,v) when isConstruct f -> - let cstr,u = destConstruct f in + | App (f,v) when isConstruct sigma f -> + let cstr,u = destConstruct sigma f in let n = constructor_nrealargs_env env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_map' reveal_pattern l acc in @@ -1719,6 +1756,7 @@ let build_inversion_problem loc env sigma tms t = match tms with | [] -> [], acc_sign, acc | (t, IsInd (_,IndType(indf,realargs),_)) :: tms -> + let realargs = List.map EConstr.of_constr realargs in let patl,acc = List.fold_map' reveal_pattern realargs acc in let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in @@ -1731,7 +1769,7 @@ let build_inversion_problem loc env sigma tms t = List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in - let d = LocalAssum (alias_of_pat pat,typ) in + let d = local_assum (alias_of_pat pat,typ) in let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = ids_of_context env in @@ -1748,7 +1786,7 @@ let build_inversion_problem loc env sigma tms t = let n = List.length sign in let decls = - List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in + List.map_i (fun i d -> (mkRel i, map_constr (CVars.lift i) d)) 1 sign in let pb_env = push_rel_context sign env in let decls = @@ -1799,7 +1837,7 @@ let build_inversion_problem loc env sigma tms t = it = None } } ] in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) - let s' = Retyping.get_sort_of env sigma (EConstr.of_constr t) in + let s' = Retyping.get_sort_of env sigma t in let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in let sigma = Evd.set_leq_sort env sigma s' s in let evdref = ref sigma in @@ -1813,7 +1851,7 @@ let build_inversion_problem loc env sigma tms t = caseloc = loc; casestyle = RegularStyle; typing_function = build_tycon loc env pb_env s subst} in - let pred = (compile pb).uj_val in + let pred = EConstr.of_constr (compile pb).uj_val in (!evdref,pred) (* Here, [pred] is assumed to be in the context built from all *) @@ -1835,8 +1873,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | NotInd (bo,typ) -> (match t with | None -> (match bo with - | None -> [LocalAssum (na, lift n typ)] - | Some b -> [LocalDef (na, lift n b, lift n typ)]) + | None -> [local_assum (na, lift n typ)] + | Some b -> [local_def (na, lift n b, lift n typ)]) | Some (loc,_,_) -> user_err ~loc (str"Unexpected type annotation for a term of non inductive type.")) @@ -1879,8 +1917,8 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = let subst, len = List.fold_right2 (fun (tm, tmtype) sign (subst, len) -> let signlen = List.length sign in - match kind_of_term tm with - | Rel n when dependent sigma (EConstr.of_constr tm) (EConstr.of_constr c) + match EConstr.kind sigma tm with + | Rel n when dependent sigma tm c && Int.equal signlen 1 (* The term to match is not of a dependent type itself *) -> ((n, len) :: subst, len - signlen) | Rel n when signlen > 1 (* The term is of a dependent type, @@ -1888,24 +1926,25 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = (match tmtype with NotInd _ -> (subst, len - signlen) | IsInd (_, IndType(indf,realargs),_) -> + let realargs = List.map EConstr.of_constr realargs in let subst, len = List.fold_left (fun (subst, len) arg -> - match kind_of_term arg with - | Rel n when dependent sigma (EConstr.of_constr arg) (EConstr.of_constr c) -> + match EConstr.kind sigma arg with + | Rel n when dependent sigma arg c -> ((n, len) :: subst, pred len) | _ -> (subst, pred len)) (subst, len) realargs in let subst = - if dependent sigma (EConstr.of_constr tm) (EConstr.of_constr c) && List.for_all isRel realargs + if dependent sigma tm c && List.for_all (isRel sigma) realargs then (n, len) :: subst else subst in (subst, pred len)) | _ -> (subst, len - signlen)) (List.rev tomatchs) arsign ([], nar) in let rec predicate lift c = - match kind_of_term c with + match EConstr.kind sigma c with | Rel n when n > lift -> (try (* Make the predicate dependent on the matched variable *) @@ -1915,12 +1954,12 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = (* A variable that is not matched, lift over the arsign. *) mkRel (n + nar)) | _ -> - map_constr_with_binders succ predicate lift c + EConstr.map_with_binders sigma succ predicate lift c in assert (len == 0); let p = predicate 0 c in let env' = List.fold_right push_rel_context arsign env in - try let sigma' = fst (Typing.type_of env' sigma (EConstr.of_constr p)) in + try let sigma' = fst (Typing.type_of env' sigma p) in Some (sigma', p) with e when precatchable_exception e -> None @@ -1935,11 +1974,26 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = * tycon to make the predicate if it is not closed. *) +exception LocalOccur + +let noccur_with_meta sigma n m term = + let rec occur_rec n c = match EConstr.kind sigma c with + | Rel p -> if n<=p && p + (match EConstr.kind sigma f with + | Cast (c,_,_) when isMeta sigma c -> () + | Meta _ -> () + | _ -> EConstr.iter_with_binders sigma succ occur_rec n c) + | Evar (_, _) -> () + | _ -> EConstr.iter_with_binders sigma succ occur_rec n c + in + try (occur_rec n term; true) with LocalOccur -> false + let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let preds = match pred, tycon with (* No return clause *) - | None, Some t when not (noccur_with_meta 0 max_int t) -> + | None, Some t when not (noccur_with_meta sigma 0 max_int t) -> (* If the tycon is not closed w.r.t real variables, we try *) (* two different strategies *) (* First strategy: we abstract the tycon wrt to the dependencies *) @@ -1960,7 +2014,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let Sigma ((t, _), sigma, _) = new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in let sigma = Sigma.to_evar_map sigma in - sigma, t + sigma, EConstr.of_constr t in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in @@ -1975,7 +2029,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let evdref = ref sigma in let predcclj = typing_fun (mk_tycon (EConstr.mkSort newt)) envar evdref rtntyp in let sigma = !evdref in - let predccl = (j_nf_evar sigma predcclj).uj_val in + let predccl = EConstr.of_constr (j_nf_evar sigma predcclj).uj_val in [sigma, predccl] in List.map @@ -2013,7 +2067,6 @@ let eq_id avoid id = let hid' = next_ident_away hid avoid in hid' -let papp evdref gr args = EConstr.Unsafe.to_constr (papp evdref gr (Array.map EConstr.of_constr args)) let mk_eq evdref typ x y = papp evdref coq_eq_ind [| typ; x ; y |] let mk_eq_refl evdref typ x = papp evdref coq_eq_refl [| typ; x |] let mk_JMeq evdref typ x typ' y = @@ -2035,16 +2088,17 @@ let constr_of_pat env evdref arsign pat avoid = let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in - (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, + (PatVar (l, name), [local_assum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in let IndType (indf, _) = - try find_rectype env ( !evdref) (EConstr.of_constr (lift (-(List.length realargs)) ty)) + try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env !evdref - {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref (EConstr.of_constr ty)} + {uj_val = EConstr.Unsafe.to_constr ty; uj_type = Typing.unsafe_type_of env !evdref ty} in let (ind,u), params = dest_ind_family indf in + let params = List.map EConstr.of_constr params in if not (eq_ind ind cind) then error_bad_constructor ~loc:l env cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in @@ -2053,7 +2107,7 @@ let constr_of_pat env evdref arsign pat avoid = let patargs, args, sign, env, n, m, avoid = List.fold_right2 (fun decl ua (patargs, args, sign, env, n, m, avoid) -> - let t = RelDecl.get_type decl in + let t = EConstr.of_constr (RelDecl.get_type decl) in let pat', sign', arg', typ', argtypargs, n', avoid = let liftt = liftn (List.length sign) (succ (List.length args)) t in typ env (substl args liftt, []) ua avoid @@ -2067,34 +2121,36 @@ let constr_of_pat env evdref arsign pat avoid = let patargs = List.rev patargs in let pat' = PatCstr (l, cstr, patargs, alias) in let cstr = mkConstructU ci.cs_cstr in - let app = applistc cstr (List.map (lift (List.length sign)) params) in - let app = applistc app args in - let apptype = Retyping.get_type_of env ( !evdref) (EConstr.of_constr app) in - let IndType (indf, realargs) = find_rectype env (!evdref) (EConstr.of_constr apptype) in + let app = applist (cstr, List.map (lift (List.length sign)) params) in + let app = applist (app, args) in + let apptype = Retyping.get_type_of env ( !evdref) app in + let apptype = EConstr.of_constr apptype in + let IndType (indf, realargs) = find_rectype env (!evdref) apptype in + let realargs = List.map EConstr.of_constr realargs in match alias with Anonymous -> pat', sign, app, apptype, realargs, n, avoid | Name id -> - let sign = LocalAssum (alias, lift m ty) :: sign in + let sign = local_assum (alias, lift m ty) :: sign in let avoid = id :: avoid in let sign, i, avoid = try let env = push_rel_context sign env in evdref := the_conv_x_leq (push_rel_context sign env) - (EConstr.of_constr (lift (succ m) ty)) (EConstr.of_constr (lift 1 apptype)) !evdref; + (lift (succ m) ty) (lift 1 apptype) !evdref; let eq_t = mk_eq evdref (lift (succ m) ty) (mkRel 1) (* alias *) (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in - LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid + local_def (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, patc, patty, args, z, avoid = typ env (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in - pat', (sign, patc, (RelDecl.get_type (List.hd arsign), args), pat'), avoid + let pat', sign, patc, patty, args, z, avoid = typ env (EConstr.of_constr (RelDecl.get_type (List.hd arsign)), List.tl arsign) pat avoid in + pat', (sign, patc, (EConstr.of_constr (RelDecl.get_type (List.hd arsign)), args), pat'), avoid (* shadows functional version *) @@ -2104,22 +2160,22 @@ let eq_id avoid id = avoid := hid' :: !avoid; hid' -let is_topvar t = -match kind_of_term t with +let is_topvar sigma t = +match EConstr.kind sigma t with | Rel 0 -> true | _ -> false -let rels_of_patsign = +let rels_of_patsign sigma = List.map (fun decl -> match decl with - | LocalDef (na,t',t) when is_topvar t' -> LocalAssum (na,t) + | LocalDef (na,t',t) when is_topvar sigma (EConstr.of_constr t') -> LocalAssum (na,t) | _ -> decl) -let vars_of_ctx ctx = +let vars_of_ctx sigma ctx = let _, y = List.fold_right (fun decl (prev, vars) -> match decl with - | LocalDef (na,t',t) when is_topvar t' -> + | LocalDef (na,t',t) when is_topvar sigma (EConstr.of_constr t') -> prev, (GApp (Loc.ghost, (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), @@ -2213,12 +2269,12 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = (* lift to get outside of past patterns to get terms in the combined environment. *) (fun (pats, n) (sign, c, (s, args), p) -> let len = List.length sign in - ((rels_of_patsign sign, lift n c, + ((rels_of_patsign !evdref sign, lift n c, (s, List.map (lift n) args), p) :: pats, len + n)) ([], 0) pats in let ineqs = build_ineqs evdref prevpatterns pats signlen in - let rhs_rels' = rels_of_patsign rhs_rels in + let rhs_rels' = rels_of_patsign !evdref rhs_rels in let _signenv = push_rel_context rhs_rels' env in let arity = let args, nargs = @@ -2234,21 +2290,21 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = match ineqs with | None -> [], arity | Some ineqs -> - [LocalAssum (Anonymous, ineqs)], lift 1 arity + [local_assum (Anonymous, ineqs)], lift 1 arity in - let eqs_rels, arity = decompose_prod_n_assum neqs arity in + let eqs_rels, arity = decompose_prod_n_assum !evdref neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity in let rhs_env = push_rel_context rhs_rels' env in - let j = typing_fun (mk_tycon (EConstr.of_constr tycon)) rhs_env eqn.rhs.it in - let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' - and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in - let _btype = evd_comb1 (Typing.type_of env) evdref (EConstr.of_constr bbody) in + let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in + let bbody = it_mkLambda_or_LetIn (EConstr.of_constr j.uj_val) rhs_rels' + and btype = it_mkProd_or_LetIn (EConstr.of_constr j.uj_type) rhs_rels' in + let _btype = evd_comb1 (Typing.type_of env) evdref bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in - let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in + let branch_decl = local_def (Name branch_name, lift !i bbody, lift !i btype) in let branch = let bref = GVar (Loc.ghost, branch_name) in - match vars_of_ctx rhs_rels with + match vars_of_ctx !evdref rhs_rels with [] -> bref | l -> GApp (Loc.ghost, bref, l) in @@ -2287,14 +2343,14 @@ let abstract_tomatch env sigma tomatchs tycon = List.fold_left (fun (prev, ctx, names, tycon) (c, t) -> let lenctx = List.length ctx in - match kind_of_term c with + match EConstr.kind sigma c with Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon | _ -> let tycon = Option.map - (fun t -> subst_term sigma (EConstr.of_constr (lift 1 c)) (EConstr.of_constr (lift 1 t))) tycon in + (fun t -> EConstr.of_constr (subst_term sigma (lift 1 c) (lift 1 t))) tycon in let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, + local_def (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) ([], [], [], tycon) tomatchs in List.rev prev, ctx, tycon @@ -2315,21 +2371,25 @@ let build_dependent_signature env evdref avoid tomatchs arsign = *) match ty with | IsInd (ty, IndType (indf, args), _) when List.length args > 0 -> + let args = List.map EConstr.of_constr args in (* Build the arity signature following the names in matched terms as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) let app_decl = List.hd arsign in (* The matched argument *) let appn = RelDecl.get_name app_decl in let appt = RelDecl.get_type app_decl in + let appt = EConstr.of_constr appt in let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> let name = RelDecl.get_name decl in let t = RelDecl.get_type decl in - let argt = Retyping.get_type_of env !evdref (EConstr.of_constr arg) in + let t = EConstr.of_constr t in + let argt = Retyping.get_type_of env !evdref arg in + let argt = EConstr.of_constr argt in let eq, refl_arg = - if Reductionops.is_conv env !evdref (EConstr.of_constr argt) (EConstr.of_constr t) then + if Reductionops.is_conv env !evdref argt t then (mk_eq evdref (lift (nargeqs + slift) argt) (mkRel (nargeqs + slift)) (lift (nargeqs + nar) arg), @@ -2343,14 +2403,14 @@ let build_dependent_signature env evdref avoid tomatchs arsign = in let previd, id = let name = - match kind_of_term arg with + match EConstr.kind !evdref arg with Rel n -> RelDecl.get_name (lookup_rel n env) | _ -> name in make_prime avoid name in (env, succ nargeqs, - (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, + (local_assum (Name (eq_id avoid previd), eq)) :: argeqs, refl_arg :: refl_args, pred slift, RelDecl.set_name (Name id) decl :: argsign')) @@ -2364,7 +2424,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = in let refl_eq = mk_JMeq_refl evdref ty tm in let previd, id = make_prime avoid appn in - ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, + ((local_assum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, succ nargeqs, refl_eq :: refl_args, pred slift, @@ -2380,7 +2440,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = mk_eq evdref (lift nar tomatch_ty) (mkRel slift) (lift nar tm) in - ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, + ([local_assum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, (mk_eq_refl evdref tomatch_ty tm) :: refl_args, pred slift, (arsign' :: []) :: arsigns)) ([], 0, [], nar, []) tomatchs arsign @@ -2409,6 +2469,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_function evdref env matx tomatchl in let tycon = valcon_of_tycon tycon in + let tycon = Option.map EConstr.of_constr tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env !evdref tomatchs tycon in let env = push_rel_context tomatchs_lets env in let len = List.length eqns in @@ -2454,9 +2515,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) - | NotInd (Some b, t) -> LocalDef (na,b,t) - | IsInd (typ,_,_) -> LocalAssum (na,typ) in + let out_tmt na = function NotInd (None,t) -> local_assum (na,t) + | NotInd (Some b, t) -> local_def (na,b,t) + | IsInd (typ,_,_) -> local_assum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = @@ -2470,7 +2531,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env let typs' = List.map3 (fun (tm,tmt) deps na -> - let deps = if not (isRel tm) then [] else deps in + let deps = if not (isRel !evdref tm) then [] else deps in ((tm,tmt),deps,na)) tomatchs dep_sign nal in @@ -2494,10 +2555,10 @@ let compile_program_cases loc style (typing_function, evdref) tycon env let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; - let body = it_mkLambda_or_LetIn (applistc j.uj_val args) lets in + let body = it_mkLambda_or_LetIn (applist (EConstr.of_constr j.uj_val, args)) lets in let j = - { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; - uj_type = nf_evar !evdref tycon; } + { uj_val = EConstr.Unsafe.to_constr (it_mkLambda_or_LetIn body tomatchs_lets); + uj_type = EConstr.to_constr !evdref tycon; } in j (**************************************************************************) @@ -2522,6 +2583,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e with the type of arguments to match; if none is provided, we build alternative possible predicates *) let arsign = extract_arity_signature env tomatchs tomatchl in + let tycon = Option.map EConstr.of_constr tycon in let preds = prepare_predicate loc typing_fun env !evdref tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = @@ -2529,9 +2591,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* names of aliases will be recovered from patterns (hence Anonymous *) (* here) *) - let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) - | NotInd (Some b,t) -> LocalDef (na,b,t) - | IsInd (typ,_,_) -> LocalAssum (na,typ) in + let out_tmt na = function NotInd (None,t) -> local_assum (na,t) + | NotInd (Some b,t) -> local_def (na,b,t) + | IsInd (typ,_,_) -> local_assum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = @@ -2545,7 +2607,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e let typs' = List.map3 (fun (tm,tmt) deps na -> - let deps = if not (isRel tm) then [] else deps in + let deps = if not (isRel !evdref tm) then [] else deps in ((tm,tmt),deps,na)) tomatchs dep_sign nal in @@ -2572,7 +2634,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e let j = compile pb in (* We coerce to the tycon (if an elim predicate was provided) *) - let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in + let j = inh_conv_coerce_to_tycon loc env myevdref j (Option.map EConstr.Unsafe.to_constr tycon) in evdref := !myevdref; j in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 6bc61f6dda..9016ca5f3f 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Evd open Environ open Inductiveops @@ -50,8 +51,8 @@ val constr_of_pat : Glob_term.cases_pattern -> Names.Id.t list -> Glob_term.cases_pattern * - (Context.Rel.Declaration.t list * Term.constr * - (Term.types * Term.constr list) * Glob_term.cases_pattern) * + (Context.Rel.Declaration.t list * constr * + (types * constr list) * Glob_term.cases_pattern) * Names.Id.t list type 'a rhs = @@ -117,7 +118,7 @@ val prepare_predicate : Loc.t -> Environ.env -> Evd.evar_map ref -> 'a -> Environ.unsafe_judgment) -> Environ.env -> Evd.evar_map -> - (Term.types * tomatch_type) list -> + (types * tomatch_type) list -> Context.Rel.t list -> - Constr.constr option -> - 'a option -> (Evd.evar_map * Names.name list * Term.constr) list + constr option -> + 'a option -> (Evd.evar_map * Names.name list * constr) list diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 4025ca8b84..4fa5ad06d3 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -382,9 +382,10 @@ let mis_make_indrec env sigma listdepkind mib u = arsign' in let obj = - Inductiveops.make_case_or_project env indf ci pred - (mkRel 1) branches + Inductiveops.make_case_or_project env !evdref indf ci (EConstr.of_constr pred) + (EConstr.mkRel 1) (Array.map EConstr.of_constr branches) in + let obj = EConstr.to_constr !evdref obj in it_mkLambda_or_LetIn_name env obj (Termops.lift_rel_context nrec deparsign) in diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index a9184777d0..a93f2846b5 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -343,24 +343,25 @@ let get_projections env (ind,params) = | Some (Some (id, projs, pbs)) -> Some projs | _ -> None -let make_case_or_project env indf ci pred c branches = +let make_case_or_project env sigma indf ci pred c branches = + let open EConstr in let projs = get_projections env indf in match projs with | None -> (mkCase (ci, pred, c, branches)) | Some ps -> assert(Array.length branches == 1); let () = - let _, _, t = destLambda pred in + let _, _, t = destLambda sigma pred in let (ind, _), _ = dest_ind_family indf in let mib, _ = Inductive.lookup_mind_specif env ind in - if (* dependent *) not (noccurn 1 t) && + if (* dependent *) not (Vars.noccurn sigma 1 t) && not (has_dependent_elim mib) then user_err ~hdr:"make_case_or_project" Pp.(str"Dependent case analysis not allowed" ++ str" on inductive type " ++ Names.MutInd.print (fst ind)) in let branch = branches.(0) in - let ctx, br = decompose_lam_n_assum (Array.length ps) branch in + let ctx, br = decompose_lam_n_assum sigma (Array.length ps) branch in let n, subst = List.fold_right (fun decl (i, subst) -> @@ -368,9 +369,9 @@ let make_case_or_project env indf ci pred c branches = | LocalAssum (na, t) -> let t = mkProj (Projection.make ps.(i) true, c) in (i + 1, t :: subst) - | LocalDef (na, b, t) -> (i, substl subst b :: subst)) + | LocalDef (na, b, t) -> (i, Vars.substl subst (EConstr.of_constr b) :: subst)) ctx (0, []) - in substl subst br + in Vars.substl subst br (* substitution in a signature *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index e375a2c6be..cf5523a50d 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -185,8 +185,8 @@ val make_case_info : env -> inductive -> case_style -> case_info Fail with an error if the elimination is dependent while the inductive type does not allow dependent elimination. *) val make_case_or_project : - env -> inductive_family -> case_info -> - (* pred *) constr -> (* term *) constr -> (* branches *) constr array -> constr + env -> evar_map -> inductive_family -> case_info -> + (* pred *) EConstr.constr -> (* term *) EConstr.constr -> (* branches *) EConstr.constr array -> EConstr.constr (*i Compatibility val make_default_case_info : env -> case_style -> inductive -> case_info diff --git a/pretyping/program.ml b/pretyping/program.ml index 2606d91f35..8ec6083f71 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -58,7 +58,9 @@ let coq_JMeq_refl = init_reference ["Logic";"JMeq"] "JMeq_refl" let coq_not = init_constant ["Init";"Logic"] "not" let coq_and = init_constant ["Init";"Logic"] "and" -let mk_coq_not x = mkApp (delayed_force coq_not, [| x |]) +let delayed_force c = EConstr.of_constr (c ()) + +let mk_coq_not x = EConstr.mkApp (delayed_force coq_not, [| x |]) let unsafe_fold_right f = function hd :: tl -> List.fold_right f tl hd @@ -68,7 +70,7 @@ let mk_coq_and l = let and_typ = delayed_force coq_and in unsafe_fold_right (fun c conj -> - mkApp (and_typ, [| c ; conj |])) + EConstr.mkApp (and_typ, [| c ; conj |])) l (* true = transparent by default, false = opaque if possible *) diff --git a/pretyping/program.mli b/pretyping/program.mli index 64c4ca2c24..94a7bdcb6d 100644 --- a/pretyping/program.mli +++ b/pretyping/program.mli @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Term +open EConstr open Globnames (** A bunch of Coq constants used by Progam *) @@ -36,7 +36,7 @@ val mk_coq_and : constr list -> constr val mk_coq_not : constr -> constr (** Polymorphic application of delayed references *) -val papp : Evd.evar_map ref -> (unit -> global_reference) -> EConstr.constr array -> EConstr.constr +val papp : Evd.evar_map ref -> (unit -> global_reference) -> constr array -> constr val get_proofs_transparency : unit -> bool val is_program_cases : unit -> bool -- cgit v1.2.3 From 85ab3e298aa1d7333787c1fa44d25df189ac255c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Nov 2016 19:02:40 +0100 Subject: Pretyping API using EConstr. --- pretyping/cases.ml | 6 +- pretyping/coercion.ml | 2 +- pretyping/evarconv.ml | 6 +- pretyping/evardefine.ml | 19 +-- pretyping/evardefine.mli | 15 +-- pretyping/evarsolve.ml | 3 +- pretyping/nativenorm.ml | 2 - pretyping/pretyping.ml | 285 +++++++++++++++++++++++++-------------------- pretyping/pretyping.mli | 8 +- pretyping/reductionops.ml | 2 + pretyping/reductionops.mli | 8 +- pretyping/tacred.ml | 2 +- pretyping/unification.ml | 16 +-- 13 files changed, 207 insertions(+), 167 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 1a181202c7..92bd1e3895 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -301,7 +301,7 @@ let inductive_template evdref env tmloc ind = | LocalAssum (na,ty) -> let ty = EConstr.of_constr ty in let ty' = substl subst ty in - let e = EConstr.of_constr (e_new_evar env evdref ~src:(hole_source n) (EConstr.Unsafe.to_constr ty')) in + let e = EConstr.of_constr (e_new_evar env evdref ~src:(hole_source n) ty') in (e::subst,e::evarl,n+1) | LocalDef (na,b,ty) -> let b = EConstr.of_constr b in @@ -1665,6 +1665,7 @@ let abstract_tycon loc env evdref subst tycon extenv t = (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context env) in + let ty = EConstr.of_constr ty in let ev' = e_new_evar env evdref ~src ty in let ev' = EConstr.of_constr ev' in begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with @@ -1700,7 +1701,6 @@ let abstract_tycon loc env evdref subst tycon extenv t = let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in let candidates = List.map EConstr.Unsafe.to_constr candidates in - let ty = EConstr.Unsafe.to_constr ty in let ev = e_new_evar extenv evdref ~src ~filter ~candidates ty in let ev = EConstr.of_constr ev in lift k ev @@ -2469,7 +2469,6 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (* constructors found in patterns *) let tomatchs = coerce_to_indtype typing_function evdref env matx tomatchl in let tycon = valcon_of_tycon tycon in - let tycon = Option.map EConstr.of_constr tycon in let tomatchs, tomatchs_lets, tycon' = abstract_tomatch env !evdref tomatchs tycon in let env = push_rel_context tomatchs_lets env in let len = List.length eqns in @@ -2583,7 +2582,6 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e with the type of arguments to match; if none is provided, we build alternative possible predicates *) let arsign = extract_arity_signature env tomatchs tomatchl in - let tycon = Option.map EConstr.of_constr tycon in let preds = prepare_predicate loc typing_fun env !evdref tomatchs arsign tycon predopt in let compile_for_one_predicate (sigma,nal,pred) = diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index cc121a96de..b9f14aa43c 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -93,7 +93,7 @@ open Program let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c = let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in - EConstr.of_constr (Evarutil.e_new_evar env evdref ~src (EConstr.Unsafe.to_constr c)) + EConstr.of_constr (Evarutil.e_new_evar env evdref ~src c) let app_opt env evdref f t = EConstr.of_constr (whd_betaiota !evdref (app_opt f t)) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index cdcb993b5e..683b33b89f 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -338,7 +338,7 @@ let rec evar_conv_x ts env evd pbty term1 term2 = let e = try let evd, b = infer_conv ~catch_incon:false ~pb:pbty ~ts:(fst ts) - env evd (EConstr.Unsafe.to_constr term1) (EConstr.Unsafe.to_constr term2) + env evd term1 term2 in if b then Success evd else UnifFailure (evd, ConversionFailed (env,term1,term2)) @@ -891,7 +891,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) else let dloc = (Loc.ghost,Evar_kinds.InternalHole) in let i = Sigma.Unsafe.of_evar_map i in - let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (EConstr.Unsafe.to_constr (Vars.substl ks b)) in + let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (Vars.substl ks b) in let i' = Sigma.to_evar_map i' in (i', EConstr.of_constr ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs @@ -1075,7 +1075,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let evty = set_holes evdref cty subst in let instance = List.map EConstr.Unsafe.to_constr (Filter.filter_list filter instance) in let evd = Sigma.Unsafe.of_evar_map !evdref in - let Sigma (ev, evd, _) = new_evar_instance sign evd (EConstr.Unsafe.to_constr evty) ~filter instance in + let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in let evd = Sigma.to_evar_map evd in evdref := evd; evsref := (fst (destEvar !evdref (EConstr.of_constr ev)),evty)::!evsref; diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index f372dbf066..ff40a69381 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -39,9 +39,9 @@ let env_nf_betaiotaevar sigma env = (* Operations on value/type constraints *) (****************************************) -type type_constraint = types option +type type_constraint = EConstr.types option -type val_constraint = constr option +type val_constraint = EConstr.constr option (* Old comment... * Basically, we have the following kind of constraints (in increasing @@ -61,13 +61,13 @@ type val_constraint = constr option let empty_tycon = None (* Builds a type constraint *) -let mk_tycon ty = Some (EConstr.Unsafe.to_constr ty) +let mk_tycon ty = Some ty (* Constrains the value of a type *) let empty_valcon = None (* Builds a value constraint *) -let mk_valcon c = Some (EConstr.Unsafe.to_constr c) +let mk_valcon c = Some c let idx = Namegen.default_dependent_ident @@ -80,7 +80,8 @@ let define_pure_evar_as_product evd evk = let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in - let s = destSort evd (EConstr.of_constr concl) in + let concl = EConstr.of_constr concl in + let s = destSort evd concl in let evd1,(dom,u1) = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (e, evd1, _) = new_type_evar evenv evd univ_flexible_alg ~filter:(evar_filter evi) in @@ -146,7 +147,7 @@ let define_pure_evar_as_lambda env evd evk = let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in - let evd2,body = new_evar_unsafe newenv evd1 ~src (EConstr.Unsafe.to_constr (Vars.subst1 (mkVar id) rng)) ~filter in + let evd2,body = new_evar_unsafe newenv evd1 ~src (Vars.subst1 (mkVar id) rng) ~filter in let lam = mkLambda (Name id, EConstr.of_constr dom, Vars.subst_var id (EConstr.of_constr body)) in Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam @@ -203,12 +204,12 @@ let split_tycon loc env evd tycon = match tycon with | None -> evd,(Anonymous,None,None) | Some c -> - let evd', (n, dom, rng) = real_split evd (EConstr.of_constr c) in + let evd', (n, dom, rng) = real_split evd c in evd', (n, mk_tycon dom, mk_tycon rng) let valcon_of_tycon x = x -let lift_tycon n = Option.map (lift n) +let lift_tycon n = Option.map (EConstr.Vars.lift n) let pr_tycon env = function None -> str "None" - | Some t -> Termops.print_constr_env env t + | Some t -> Termops.print_constr_env env (EConstr.Unsafe.to_constr t) diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index f7bf4636b9..9c03a6e3f1 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Evd open Environ @@ -18,16 +19,16 @@ type type_constraint = types option type val_constraint = constr option val empty_tycon : type_constraint -val mk_tycon : EConstr.constr -> type_constraint +val mk_tycon : constr -> type_constraint val empty_valcon : val_constraint -val mk_valcon : EConstr.constr -> val_constraint +val mk_valcon : constr -> val_constraint (** Instantiate an evar by as many lambda's as needed so that its arguments are moved to the evar substitution (i.e. turn [?x[vars1:=args1] args] into [?y[vars1:=args1,vars:=args]] with [vars1 |- ?x:=\vars.?y[vars1:=vars1,vars:=vars]] *) -val evar_absorb_arguments : env -> evar_map -> EConstr.existential -> EConstr.constr list -> - evar_map * EConstr.existential +val evar_absorb_arguments : env -> evar_map -> existential -> constr list -> + evar_map * existential val split_tycon : Loc.t -> env -> evar_map -> type_constraint -> @@ -36,9 +37,9 @@ val split_tycon : val valcon_of_tycon : type_constraint -> val_constraint val lift_tycon : int -> type_constraint -> type_constraint -val define_evar_as_product : evar_map -> EConstr.existential -> evar_map * EConstr.types -val define_evar_as_lambda : env -> evar_map -> EConstr.existential -> evar_map * EConstr.types -val define_evar_as_sort : env -> evar_map -> EConstr.existential -> evar_map * sorts +val define_evar_as_product : evar_map -> existential -> evar_map * types +val define_evar_as_lambda : env -> evar_map -> existential -> evar_map * types +val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts (** {6 debug pretty-printer:} *) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 8a22aed2f2..3bcea4cee5 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -606,7 +606,7 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = let open EConstr in let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src (List.map EConstr.Unsafe.to_constr inst_in_env) in + let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd (EConstr.of_constr ty_t_in_sign) ~filter ~src (List.map EConstr.Unsafe.to_constr inst_in_env) in let evd = Sigma.to_evar_map evd in let t_in_env = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr t_in_env)) in let evar_in_env = EConstr.of_constr evar_in_env in @@ -682,6 +682,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in let evd = Sigma.Unsafe.of_evar_map evd in + let ev2ty_in_sign = EConstr.of_constr ev2ty_in_sign in let Sigma (ev2_in_sign, evd, _) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src (List.map EConstr.Unsafe.to_constr inst2_in_sign) in let evd = Sigma.to_evar_map evd in diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index c8bcae0c85..ff3424c44b 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -409,7 +409,5 @@ let native_conv_generic pb sigma t = Nativeconv.native_conv_gen pb (evars_of_evar_map sigma) t let native_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = - let t1 = EConstr.Unsafe.to_constr t1 in - let t2 = EConstr.Unsafe.to_constr t2 in Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> native_conv_generic pb sigma) ~catch_incon:true ~pb env sigma t1 t2 diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 18731f1e90..cac31a1c57 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -27,8 +27,9 @@ open Util open Names open Evd open Term -open Vars open Termops +open EConstr +open Vars open Reductionops open Environ open Type_errors @@ -59,7 +60,7 @@ type ltac_var_map = { ltac_genargs : unbound_ltac_var_map; } type glob_constr_ltac_closure = ltac_var_map * glob_constr -type pure_open_constr = evar_map * constr +type pure_open_constr = evar_map * Constr.constr (************************************************************************) (* This concerns Cases *) @@ -68,6 +69,16 @@ open Inductiveops (************************************************************************) +let local_assum (na, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + module ExtraEnv = struct @@ -104,7 +115,7 @@ let lookup_named id env = lookup_named id env.env let e_new_evar env evdref ?src ?naming typ = let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in let open Context.Named.Declaration in - let inst_vars = List.map (get_id %> mkVar) (named_context env.env) in + let inst_vars = List.map (get_id %> Constr.mkVar) (named_context env.env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in let (subst, vsubst, _, nc) = Lazy.force env.extra in let typ' = subst2 subst vsubst typ in @@ -116,7 +127,7 @@ let e_new_evar env evdref ?src ?naming typ = e let push_rec_types (lna,typarray,_) env = - let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> local_assum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt end @@ -127,6 +138,13 @@ open ExtraEnv exception Found of int array +let nf_fix sigma (nas, cs, ts) = + let inj c = EConstr.to_constr sigma c in + (nas, Array.map inj cs, Array.map inj ts) + +let nf_evar sigma c = + EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr c)) + let search_guard loc env possible_indexes fixdefs = (* Standard situation with only one possibility for each fix. *) (* We treat it separately in order to get proper error msg. *) @@ -282,7 +300,7 @@ let apply_inference_hook hook evdref pending = then try let sigma, c = hook sigma evk in - Evd.define evk c sigma + Evd.define evk (EConstr.Unsafe.to_constr c) sigma with Exit -> sigma else @@ -313,17 +331,15 @@ let check_extra_evars_are_solved env current_sigma pending = let check_evars env initial_sigma sigma c = let rec proc_rec c = - match kind_of_term c with - | Evar (evk,_ as ev) -> - (match existential_opt_value sigma ev with - | Some c -> proc_rec c - | None -> - if not (Evd.mem initial_sigma evk) then - let (loc,k) = evar_source evk sigma in - match k with - | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () - | _ -> Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None) - | _ -> Constr.iter proc_rec c + match EConstr.kind sigma c with + | Evar (evk, _) -> + if not (Evd.mem initial_sigma evk) then + let (loc,k) = evar_source evk sigma in + begin match k with + | Evar_kinds.ImplicitArg (gr, (i, id), false) -> () + | _ -> Pretype_errors.error_unsolvable_implicit ~loc env sigma evk None + end + | _ -> EConstr.iter sigma proc_rec c in proc_rec c let check_evars_are_solved env current_sigma frozen pending = @@ -359,7 +375,7 @@ let allow_anonymous_refs = ref false let inh_conv_coerce_to_tycon resolve_tc loc env evdref j = function | None -> j | Some t -> - evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j (EConstr.of_constr t) + evd_comb2 (Coercion.inh_conv_coerce_to resolve_tc loc env.ExtraEnv.env) evdref j t let check_instance loc subst = function | [] -> () @@ -409,26 +425,29 @@ let invert_ltac_bound_name lvar env id0 id = str " which is not bound in current context.") let protected_get_type_of env sigma c = - try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma (EConstr.of_constr c) + try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c with Retyping.RetypeError _ -> user_err - (str "Cannot reinterpret " ++ quote (print_constr c) ++ + (str "Cannot reinterpret " ++ quote (print_constr (EConstr.Unsafe.to_constr c)) ++ str " in the current environment.") +let j_val j = EConstr.of_constr (j_val j) + let pretype_id pretype k0 loc env evdref lvar id = let sigma = !evdref in (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in - { uj_val = mkRel n; uj_type = lift n typ } + let typ = EConstr.of_constr typ in + { uj_val = EConstr.Unsafe.to_constr (mkRel n); uj_type = EConstr.Unsafe.to_constr (lift n typ) } with Not_found -> let env = ltac_interp_name_env k0 lvar env in (* Check if [id] is an ltac variable *) try let (ids,c) = Id.Map.find id lvar.ltac_constrs in let subst = List.map (invert_ltac_bound_name lvar env id) ids in - let c = substl subst c in - { uj_val = c; uj_type = protected_get_type_of env sigma c } + let c = substl subst (EConstr.of_constr c) in + { uj_val = EConstr.Unsafe.to_constr c; uj_type = protected_get_type_of env sigma c } with Not_found -> try let {closure;term} = Id.Map.find id lvar.ltac_uconstrs in let lvar = { @@ -453,14 +472,11 @@ let pretype_id pretype k0 loc env evdref lvar id = end; (* Check if [id] is a section or goal variable *) try - { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } + { uj_val = Constr.mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } with Not_found -> (* [id] not found, standard error message *) error_var_not_found ~loc id -let evar_kind_of_term sigma c = - kind_of_term (whd_evar sigma c) - (*************************************************************************) (* Main pretyping function *) @@ -492,13 +508,17 @@ let pretype_global loc rigid env evd gr us = str " universe instances must be greater or equal to Set."); evd, Some (Univ.Instance.of_array (Array.of_list (List.rev l'))) in - Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.env evd gr + let (sigma, c) = Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.env evd gr in + (sigma, EConstr.of_constr c) + +let make_judge c t = + make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr t) let pretype_ref loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) - (try make_judge (mkVar id) (NamedDecl.get_type (lookup_named id env)) + (try make_judge (mkVar id) (EConstr.of_constr (NamedDecl.get_type (lookup_named id env))) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal @@ -507,13 +527,14 @@ let pretype_ref loc evdref env ref us = | ref -> let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in - let ty = Typing.unsafe_type_of env.ExtraEnv.env evd (EConstr.of_constr c) in + let ty = Typing.unsafe_type_of env.ExtraEnv.env evd c in + let ty = EConstr.of_constr ty in make_judge c ty let judge_of_Type loc evd s = let evd, s = interp_universe ~loc evd s in let judge = - { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } + { uj_val = Constr.mkSort (Type s); uj_type = Constr.mkSort (Type (Univ.super s)) } in evd, judge @@ -563,32 +584,32 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let hyps = evar_filtered_context (Evd.find !evdref evk) in let args = pretype_instance k0 resolve_tc env evdref lvar loc hyps evk inst in let c = mkEvar (evk, args) in - let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref (EConstr.of_constr c)) in + let j = (Retyping.get_judgment_of env.ExtraEnv.env !evdref c) in inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with - | Some ty -> ty + | Some ty -> EConstr.Unsafe.to_constr ty | None -> new_type_evar env evdref loc in let k = Evar_kinds.MatchingVar (someta,n) in - { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } + { uj_val = e_new_evar env evdref ~src:(loc,k) (EConstr.of_constr ty); uj_type = ty } | GHole (loc, k, naming, None) -> let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with - | Some ty -> ty + | Some ty -> EConstr.Unsafe.to_constr ty | None -> new_type_evar env evdref loc in - { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty } + { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming (EConstr.of_constr ty); uj_type = ty } | GHole (loc, k, _naming, Some arg) -> let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with - | Some ty -> ty + | Some ty -> EConstr.Unsafe.to_constr ty | None -> new_type_evar env evdref loc in let ist = lvar.ltac_genargs in @@ -616,8 +637,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (fun e ar -> pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) ctxtv lar in - let lara = Array.map (fun a -> a.utj_val) larj in - let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let lara = Array.map (fun a -> EConstr.of_constr a.utj_val) larj in + let ftys = Array.map2 (fun e a -> EConstr.it_mkProd_or_LetIn a e) ctxtv lara in let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in let _ = @@ -626,7 +647,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fixi = match fixkind with | GFix (vn,i) -> i | GCoFix i -> i - in e_conv env.ExtraEnv.env evdref (EConstr.of_constr ftys.(fixi)) (EConstr.of_constr t) + in e_conv env.ExtraEnv.env evdref ftys.(fixi) t | None -> true in (* Note: bodies are not used by push_rec_types, so [||] is safe *) @@ -637,16 +658,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) let (ctxt,ty) = - decompose_prod_n_assum (Context.Rel.length ctxt) + decompose_prod_n_assum !evdref (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon (EConstr.of_constr ty)) nenv evdref lvar def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + let j = pretype (mk_tycon ty) nenv evdref lvar def in + { uj_val = Termops.it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = Termops.it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in - Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names (Array.map EConstr.of_constr ftys) vdefj; - let ftys = Array.map (nf_evar !evdref) ftys in - let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in + Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names ftys vdefj; + let nf c = nf_evar !evdref c in + let ftys = Array.map nf ftys in (** FIXME *) + let fdefs = Array.map (fun x -> nf (j_val x)) vdefj in let fixj = match fixkind with | GFix (vn,i) -> (* First, let's find the guard indexes. *) @@ -665,12 +687,13 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fixdecls = (names,ftys,fdefs) in let indexes = search_guard - loc env.ExtraEnv.env possible_indexes fixdecls + loc env.ExtraEnv.env possible_indexes (nf_fix !evdref fixdecls) in make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) | GCoFix i -> - let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env.ExtraEnv.env cofix + let fixdecls = (names,ftys,fdefs) in + let cofix = (i, fixdecls) in + (try check_cofix env.ExtraEnv.env (i, nf_fix !evdref fixdecls) with reraise -> let (e, info) = CErrors.push reraise in let info = Loc.add_loc info loc in @@ -691,24 +714,24 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then + if Flags.is_program_mode () && length > 0 && isConstruct !evdref (EConstr.of_constr fj.uj_val) then match tycon with | None -> [] | Some ty -> - let ((ind, i), u) = destConstruct fj.uj_val in + let ((ind, i), u) = destConstruct !evdref (EConstr.of_constr fj.uj_val) in let npars = inductive_nparams ind in if Int.equal npars 0 then [] else try - let IndType (indf, args) = find_rectype env.ExtraEnv.env !evdref (EConstr.of_constr ty) in + let IndType (indf, args) = find_rectype env.ExtraEnv.env !evdref ty in let ((ind',u'),pars) = dest_ind_family indf in - if eq_ind ind ind' then pars + if eq_ind ind ind' then List.map EConstr.of_constr pars else (* Let the usual code throw an error *) [] with Not_found -> [] else [] in let app_f = - match kind_of_term fj.uj_val with + match EConstr.kind !evdref (EConstr.of_constr fj.uj_val) with | Const (p, u) when Environ.is_projection p env.ExtraEnv.env -> let p = Projection.make p false in let pb = Environ.lookup_projection p env.ExtraEnv.env in @@ -724,7 +747,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let argloc = loc_of_glob_constr c in let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in let resty = whd_all env.ExtraEnv.env !evdref (EConstr.of_constr resj.uj_type) in - match kind_of_term resty with + let resty = EConstr.of_constr resty in + match EConstr.kind !evdref resty with | Prod (na,c1,c2) -> let tycon = Some c1 in let hj = pretype tycon env evdref lvar c in @@ -732,12 +756,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match candargs with | [] -> [], j_val hj | arg :: args -> - if e_conv env.ExtraEnv.env evdref (EConstr.of_constr (j_val hj)) (EConstr.of_constr arg) then + if e_conv env.ExtraEnv.env evdref (j_val hj) arg then args, nf_evar !evdref (j_val hj) else [], j_val hj in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in - let j = { uj_val = value; uj_type = typ } in + let j = { uj_val = EConstr.Unsafe.to_constr value; uj_type = EConstr.Unsafe.to_constr typ } in apply_rec env (n+1) j candargs rest | _ -> @@ -748,16 +772,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre in let resj = apply_rec env 1 fj candargs args in let resj = - match evar_kind_of_term !evdref resj.uj_val with + match EConstr.kind !evdref (EConstr.of_constr resj.uj_val) with | App (f,args) -> - let f = whd_evar !evdref f in - if is_template_polymorphic env.ExtraEnv.env !evdref (EConstr.of_constr f) then + if is_template_polymorphic env.ExtraEnv.env !evdref f then (* Special case for inductive type applications that must be refreshed right away. *) - let sigma = !evdref in - let c = mkApp (f,Array.map (whd_evar sigma) args) in - let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref (EConstr.of_constr c) in - let t = Retyping.get_type_of env.ExtraEnv.env !evdref (EConstr.of_constr c) in + let c = mkApp (f, args) in + let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in + let c = EConstr.of_constr c in + let t = Retyping.get_type_of env.ExtraEnv.env !evdref c in + let t = EConstr.of_constr t in make_judge c (* use this for keeping evars: resj.uj_val *) t else resj | _ -> resj @@ -770,8 +794,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match tycon with | None -> evd, tycon | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd (EConstr.of_constr ty) in - evd, Some (EConstr.Unsafe.to_constr ty')) + let evd, ty' = Coercion.inh_coerce_to_prod loc env.ExtraEnv.env evd ty in + evd, Some ty') evdref tycon in let (name',dom,rng) = evd_comb1 (split_tycon loc env.ExtraEnv.env) evdref tycon' in @@ -794,7 +818,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let j' = match name with | Anonymous -> let j = pretype_type empty_valcon env evdref lvar c2 in - { j with utj_val = lift 1 j.utj_val } + { j with utj_val = EConstr.Unsafe.to_constr (lift 1 (EConstr.of_constr j.utj_val)) } | Name _ -> let var = LocalAssum (name, j.utj_val) in let env' = push_rel var env in @@ -825,11 +849,12 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre the substitution must also be applied on variables before they are looked up in the rel context. *) let var = LocalDef (name, j.uj_val, t) in + let t = EConstr.of_constr t in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in let name = ltac_interp_name lvar name in - { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; - uj_type = subst1 j.uj_val j'.uj_type } + { uj_val = EConstr.Unsafe.to_constr (mkLetIn (name, EConstr.of_constr j.uj_val, t, EConstr.of_constr j'.uj_val)) ; + uj_type = EConstr.Unsafe.to_constr (subst1 (EConstr.of_constr j.uj_val) (EConstr.of_constr j'.uj_type)) } | GLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in @@ -839,6 +864,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let cloc = loc_of_glob_constr c in error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in + let realargs = List.map EConstr.of_constr realargs in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then user_err ~loc (str "Destructing let is only for inductive types" ++ @@ -855,8 +881,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let rec aux n k names l = match names, l with | na :: names, (LocalAssum (_,t) :: l) -> + let t = EConstr.of_constr t in let proj = Projection.make ps.(cs.cs_nargs - k) true in - LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) + local_def (na, lift (cs.cs_nargs - n) (mkProj (proj, EConstr.of_constr cj.uj_val)), t) :: aux (n+1) (k + 1) names l | na :: names, (decl :: l) -> set_name na decl :: aux (n+1) k names l @@ -870,7 +897,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fsign = List.map2 set_name nal fsign in let f = it_mkLambda_or_LetIn f fsign in let ci = make_case_info env.ExtraEnv.env (fst ind) LetStyle in - mkCase (ci, p, cj.uj_val,[|f|]) + mkCase (ci, p, EConstr.of_constr cj.uj_val,[|f|]) else it_mkLambda_or_LetIn f fsign in let env_f = push_rel_context fsign env in @@ -887,28 +914,28 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | Some p -> let env_p = push_rel_context psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in + let ccl = nf_evar !evdref (EConstr.of_constr pj.utj_val) in let psign = make_arity_signature env.ExtraEnv.env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in let inst = - (Array.to_list cs.cs_concl_realargs) - @[build_dependent_constructor cs] in + (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) + @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env.ExtraEnv.env !evdref (EConstr.of_constr lp) (List.map EConstr.of_constr inst) in + let fty = hnf_lam_applist env.ExtraEnv.env !evdref lp inst in let fj = pretype (mk_tycon (EConstr.of_constr fty)) env_f evdref lvar d in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) (EConstr.of_constr p); - obj ind p cj.uj_val fj.uj_val + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) p; + obj ind p cj.uj_val (EConstr.of_constr fj.uj_val) in - { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr (substl (realargs@[EConstr.of_constr cj.uj_val]) ccl) } | None -> let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in - let ccl = nf_evar !evdref fj.uj_type in + let ccl = nf_evar !evdref (EConstr.of_constr fj.uj_type) in let ccl = - if noccur_between 1 cs.cs_nargs ccl then + if noccur_between !evdref 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl else error_cant_find_case_type ~loc env.ExtraEnv.env !evdref @@ -917,9 +944,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) (EConstr.of_constr p); - obj ind p cj.uj_val fj.uj_val - in { uj_val = v; uj_type = ccl }) + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) p; + obj ind p cj.uj_val (EConstr.of_constr fj.uj_val) + in { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr ccl }) | GIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in @@ -946,16 +973,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | Some p -> let env_p = push_rel_context psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in + let ccl = nf_evar !evdref (EConstr.of_constr pj.utj_val) in let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist !evdref (EConstr.of_constr pred,[EConstr.of_constr cj.uj_val])) in + let typ = lift (- nar) (EConstr.of_constr (beta_applist !evdref (pred,[EConstr.of_constr cj.uj_val]))) in pred, typ | None -> let p = match tycon with | Some ty -> ty | None -> let env = ltac_interp_name_env k0 lvar env in - new_type_evar env evdref loc + EConstr.of_constr (new_type_evar env evdref loc) in it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar !evdref pred in @@ -963,7 +990,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let f cs b = let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist !evdref (EConstr.of_constr pi, [EConstr.of_constr (build_dependent_constructor cs)]) in + let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in let csgn = if not !allow_anonymous_refs then List.map (set_name Anonymous) cs.cs_args @@ -974,17 +1001,17 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre in let env_c = push_rel_context csgn env in let bj = pretype (mk_tycon (EConstr.of_constr pi)) env_c evdref lvar b in - it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + it_mkLambda_or_LetIn (EConstr.of_constr bj.uj_val) cs.cs_args in let b1 = f cstrs.(0) b1 in let b2 = f cstrs.(1) b2 in let v = let ind,_ = dest_ind_family indf in let ci = make_case_info env.ExtraEnv.env (fst ind) IfStyle in let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) (EConstr.of_constr pred); - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) pred; + mkCase (ci, pred, EConstr.of_constr cj.uj_val, [|b1;b2|]) in - let cj = { uj_val = v; uj_type = p } in + let cj = { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr p } in inh_conv_coerce_to_tycon loc env evdref cj tycon | GCases (loc,sty,po,tml,eqns) -> @@ -1004,53 +1031,56 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let tval = evd_comb1 (Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) evdref (EConstr.of_constr tj.utj_val) in + let tval = EConstr.of_constr tval in let tval = nf_evar !evdref tval in let cj, tval = match k with | VMcast -> let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in - if not (occur_existential !evdref (EConstr.of_constr cty) || occur_existential !evdref (EConstr.of_constr tval)) then + let cty = nf_evar !evdref (EConstr.of_constr cj.uj_type) and tval = nf_evar !evdref tval in + if not (occur_existential !evdref cty || occur_existential !evdref tval) then let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type ~loc env.ExtraEnv.env !evdref cj tval - (ConversionFailed (env.ExtraEnv.env,EConstr.of_constr cty,EConstr.of_constr tval)) + error_actual_type ~loc env.ExtraEnv.env !evdref cj (EConstr.Unsafe.to_constr tval) + (ConversionFailed (env.ExtraEnv.env,cty,tval)) else user_err ~loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in + let cty = nf_evar !evdref (EConstr.of_constr cj.uj_type) and tval = nf_evar !evdref tval in begin - let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref (EConstr.of_constr cty) (EConstr.of_constr tval) in + let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type ~loc env.ExtraEnv.env !evdref cj tval - (ConversionFailed (env.ExtraEnv.env,EConstr.of_constr cty,EConstr.of_constr tval)) + error_actual_type ~loc env.ExtraEnv.env !evdref cj (EConstr.Unsafe.to_constr tval) + (ConversionFailed (env.ExtraEnv.env,cty,tval)) end | _ -> - pretype (mk_tycon (EConstr.of_constr tval)) env evdref lvar c, tval + pretype (mk_tycon tval) env evdref lvar c, tval in - let v = mkCast (cj.uj_val, k, tval) in - { uj_val = v; uj_type = tval } + let v = mkCast (EConstr.of_constr cj.uj_val, k, tval) in + { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr tval } in inh_conv_coerce_to_tycon loc env evdref cj tycon and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = let f decl (subst,update) = let id = NamedDecl.get_id decl in - let t = replace_vars subst (NamedDecl.get_type decl) in + let t = replace_vars subst (EConstr.of_constr (NamedDecl.get_type decl)) in let c, update = try let c = List.assoc id update in - let c = pretype k0 resolve_tc (mk_tycon (EConstr.of_constr t)) env evdref lvar c in - c.uj_val, List.remove_assoc id update + let c = pretype k0 resolve_tc (mk_tycon t) env evdref lvar c in + EConstr.of_constr c.uj_val, List.remove_assoc id update with Not_found -> try let (n,_,t') = lookup_rel_id id (rel_context env) in - if is_conv env.ExtraEnv.env !evdref (EConstr.of_constr t) (EConstr.of_constr t') then mkRel n, update else raise Not_found + let t' = EConstr.of_constr t' in + if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found with Not_found -> try let t' = env |> lookup_named id |> NamedDecl.get_type in - if is_conv env.ExtraEnv.env !evdref (EConstr.of_constr t) (EConstr.of_constr t') then mkVar id, update else raise Not_found + let t' = EConstr.of_constr t' in + if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> user_err ~loc (str "Cannot interpret " ++ pr_existential_key !evdref evk ++ @@ -1063,18 +1093,23 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | GHole (loc, knd, naming, None) -> + let rec is_Type c = match EConstr.kind !evdref c with + | Sort (Type _) -> true + | Cast (c, _, _) -> is_Type c + | _ -> false + in (match valcon with | Some v -> let s = let sigma = !evdref in - let t = Retyping.get_type_of env.ExtraEnv.env sigma (EConstr.of_constr v) in + let t = Retyping.get_type_of env.ExtraEnv.env sigma v in match EConstr.kind sigma (EConstr.of_constr (whd_all env.ExtraEnv.env sigma (EConstr.of_constr t))) with | Sort s -> s - | Evar ev when is_Type (existential_type sigma (fst ev, Array.map EConstr.Unsafe.to_constr (snd ev))) -> + | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type") in - { utj_val = v; + { utj_val = EConstr.Unsafe.to_constr v; utj_type = s } | None -> let env = ltac_interp_name_env k0 lvar env in @@ -1088,10 +1123,10 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function match valcon with | None -> tj | Some v -> - if e_cumul env.ExtraEnv.env evdref (EConstr.of_constr v) (EConstr.of_constr tj.utj_val) then tj + if e_cumul env.ExtraEnv.env evdref v (EConstr.of_constr tj.utj_val) then tj else error_unexpected_type - ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v + ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val (EConstr.Unsafe.to_constr v) let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env in @@ -1101,11 +1136,11 @@ let ise_pretype_gen flags env sigma lvar kind c = | WithoutTypeConstraint -> (pretype k0 flags.use_typeclasses empty_tycon env evdref lvar c).uj_val | OfType exptyp -> - (pretype k0 flags.use_typeclasses (mk_tycon (EConstr.of_constr exptyp)) env evdref lvar c).uj_val + (pretype k0 flags.use_typeclasses (mk_tycon exptyp) env evdref lvar c).uj_val | IsType -> (pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val in - process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c') + process_inference_flags flags env.ExtraEnv.env sigma (!evdref,EConstr.of_constr c') let default_inference_flags fail = { use_typeclasses = true; @@ -1131,17 +1166,17 @@ let empty_lvar : ltac_var_map = { ltac_genargs = Id.Map.empty; } -let on_judgment f j = - let c = mkCast(j.uj_val,DEFAULTcast, j.uj_type) in - let (c,_,t) = destCast (f c) in - {uj_val = c; uj_type = t} +let on_judgment sigma f j = + let c = mkCast(EConstr.of_constr j.uj_val,DEFAULTcast, EConstr.of_constr j.uj_type) in + let (c,_,t) = destCast sigma (f c) in + {uj_val = EConstr.Unsafe.to_constr c; uj_type = EConstr.Unsafe.to_constr t} let understand_judgment env sigma c = let env = make_env env in let evdref = ref sigma in let k0 = Context.Rel.length (rel_context env) in let j = pretype k0 true empty_tycon env evdref empty_lvar c in - let j = on_judgment (fun c -> + let j = on_judgment sigma (fun c -> let evd, c = process_inference_flags all_and_fail_flags env.ExtraEnv.env sigma (!evdref,c) in evdref := evd; c) j in j, Evd.evar_universe_context !evdref @@ -1150,14 +1185,14 @@ let understand_judgment_tcc env evdref c = let env = make_env env in let k0 = Context.Rel.length (rel_context env) in let j = pretype k0 true empty_tycon env evdref empty_lvar c in - on_judgment (fun c -> + on_judgment !evdref (fun c -> let (evd,c) = process_inference_flags all_no_fail_flags env.ExtraEnv.env Evd.empty (!evdref,c) in evdref := evd; c) j let ise_pretype_gen_ctx flags env sigma lvar kind c = let evd, c = ise_pretype_gen flags env sigma lvar kind c in let evd, f = Evarutil.nf_evars_and_universes evd in - f c, Evd.evar_universe_context evd + f (EConstr.Unsafe.to_constr c), Evd.evar_universe_context evd (** Entry points of the high-level type synthesis algorithm *) @@ -1168,15 +1203,17 @@ let understand ise_pretype_gen_ctx flags env sigma empty_lvar expected_type c let understand_tcc ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutTypeConstraint) c = - ise_pretype_gen flags env sigma empty_lvar expected_type c + let (sigma, c) = ise_pretype_gen flags env sigma empty_lvar expected_type c in + (sigma, EConstr.Unsafe.to_constr c) let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=WithoutTypeConstraint) c = let sigma, c = ise_pretype_gen flags env !evdref empty_lvar expected_type c in evdref := sigma; - c + EConstr.Unsafe.to_constr c let understand_ltac flags env sigma lvar kind c = - ise_pretype_gen flags env sigma lvar kind c + let (sigma, c) = ise_pretype_gen flags env sigma lvar kind c in + (sigma, EConstr.Unsafe.to_constr c) let constr_flags = { use_typeclasses = true; diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index e09648ec3b..603b9f9ea8 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -25,7 +25,7 @@ open Misctypes val search_guard : Loc.t -> env -> int list list -> rec_declaration -> int array -type typing_constraint = OfType of types | IsType | WithoutTypeConstraint +type typing_constraint = OfType of EConstr.types | IsType | WithoutTypeConstraint type var_map = Pattern.constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t @@ -47,7 +47,7 @@ val empty_lvar : ltac_var_map type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr -type inference_hook = env -> evar_map -> evar -> evar_map * constr +type inference_hook = env -> evar_map -> evar -> evar_map * EConstr.constr type inference_flags = { use_typeclasses : bool; @@ -139,7 +139,7 @@ val check_evars_are_solved : (** [check_evars env initial_sigma extended_sigma c] fails if some new unresolved evar remains in [c] *) -val check_evars : env -> evar_map -> evar_map -> constr -> unit +val check_evars : env -> evar_map -> evar_map -> EConstr.constr -> unit (**/**) (** Internal of Pretyping... *) @@ -153,7 +153,7 @@ val pretype_type : val ise_pretype_gen : inference_flags -> env -> evar_map -> - ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr + ltac_var_map -> typing_constraint -> glob_constr -> evar_map * EConstr.constr (**/**) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 69d47e8e69..0b97cd253b 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1317,6 +1317,8 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let x = EConstr.Unsafe.to_constr x in + let y = EConstr.Unsafe.to_constr y in try let fold cstr sigma = try Some (Evd.add_universe_constraints sigma cstr) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 911dab0b67..5e6a40786c 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -264,12 +264,12 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> ECo otherwise returns false in that case. *) val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> - env -> evar_map -> constr -> constr -> evar_map * bool + env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map * bool (** Conversion with inference of universe constraints *) -val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> constr -> constr -> +val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map * bool) -> unit -val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> +val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map * bool @@ -278,7 +278,7 @@ conversion function. Used to pretype vm and native casts. *) val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> (constr, evar_map) Reduction.generic_conversion_function) -> ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> - evar_map -> constr -> constr -> evar_map * bool + evar_map -> EConstr.constr -> EConstr.constr -> evar_map * bool (** {6 Special-Purpose Reduction Functions } *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index b729f3b9bc..5b8eaa50b1 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -413,7 +413,7 @@ let substl_with_function subst sigma constr = match v.(i-k-1) with | (fx, Some (min, ref)) -> let sigma = Sigma.Unsafe.of_evar_map !evd in - let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in + let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma (EConstr.of_constr dummy) in let sigma = Sigma.to_evar_map sigma in evd := sigma; minargs := Evar.Map.add evk min !minargs; diff --git a/pretyping/unification.ml b/pretyping/unification.ml index b568dd044e..70aa0be6bd 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -167,6 +167,7 @@ let pose_all_metas_as_evars env evd t = let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in let src = Evd.evar_source_of_meta mv !evdref in + let ty = EConstr.of_constr ty in let ev = Evarutil.e_new_evar env evdref ~src ty in evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref; ev) @@ -608,7 +609,7 @@ let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN = | None -> sigma | Some n -> if is_ground_term sigma (EConstr.of_constr m) && is_ground_term sigma (EConstr.of_constr n) then - let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n in + let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma (EConstr.of_constr m) (EConstr.of_constr n) in if b then sigma else error_cannot_unify env sigma (m,n) else sigma @@ -961,10 +962,11 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb (* Renounce, maybe metas/evars prevents typing *) sigma else sigma in + let m1 = EConstr.of_constr m1 and n1 = EConstr.of_constr n1 in let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in if b then Some (sigma, metasubst, evarsubst) else - if is_ground_term sigma (EConstr.of_constr m1) && is_ground_term sigma (EConstr.of_constr n1) then + if is_ground_term sigma m1 && is_ground_term sigma n1 then error_cannot_unify curenv sigma (cM,cN) else None in @@ -1071,7 +1073,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb None else let sigma, b = match flags.modulo_conv_on_closed_terms with - | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma (EConstr.of_constr m) (EConstr.of_constr n) | _ -> constr_cmp cv_pb sigma flags m n in if b then Some sigma else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with @@ -1210,7 +1212,7 @@ let applyHead env (type r) (evd : r Sigma.t) n c = else match kind_of_term (whd_all env (Sigma.to_evar_map evd) (EConstr.of_constr cty)) with | Prod (_,c1,c2) -> - let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in + let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) (EConstr.of_constr c1) in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' | _ -> error "Apply_Head_Then" in @@ -1570,7 +1572,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = let merge_fun c1 c2 = match c1, c2 with | Some (evd,c1,x), Some (_,c2,_) -> - let (evd,b) = infer_conv ~pb:CONV env evd (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) in + let (evd,b) = infer_conv ~pb:CONV env evd c1 c2 in if b then Some (evd, c1, x) else raise (NotUnifiable None) | Some _, None -> c1 | None, Some _ -> c2 @@ -1883,7 +1885,7 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in - let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in + let evd', b = infer_conv ~pb:CUMUL env evd' (EConstr.of_constr predtyp) (EConstr.of_constr typp) in if not b then error_wrong_abstraction_type env evd' (Evd.meta_name evd p) pred typp predtyp; @@ -1900,7 +1902,7 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let evd, pred = abstract_list_all_with_dependencies env evd typp typ (List.map EConstr.of_constr oplist) in + let evd, pred = abstract_list_all_with_dependencies env evd (EConstr.of_constr typp) typ (List.map EConstr.of_constr oplist) in w_merge env false flags.merge_unify_flags (evd,[p,pred,(Conv,TypeProcessed)],[]) -- cgit v1.2.3 From c2855a3387be134d1220f301574b743572a94239 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Nov 2016 11:39:27 +0100 Subject: Unification API using EConstr. --- pretyping/evarconv.ml | 10 +- pretyping/evarsolve.ml | 8 +- pretyping/evarsolve.mli | 2 +- pretyping/find_subterm.ml | 2 +- pretyping/find_subterm.mli | 2 +- pretyping/inductiveops.ml | 2 +- pretyping/pretype_errors.ml | 16 +- pretyping/pretype_errors.mli | 30 +-- pretyping/reductionops.ml | 2 +- pretyping/reductionops.mli | 2 +- pretyping/unification.ml | 504 ++++++++++++++++++++++++------------------- pretyping/unification.mli | 32 +-- 12 files changed, 343 insertions(+), 269 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 683b33b89f..3b420347b9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -390,7 +390,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let t2 = EConstr.of_constr (nf_evar evd (EConstr.Unsafe.to_constr tM)) (** FIXME *) in let t2 = solve_pattern_eqn env evd l1' t2 in solve_simple_eqn (evar_conv_x ts) env evd - (position_problem on_left pbty,ev,EConstr.of_constr t2) + (position_problem on_left pbty,ev,t2) in let consume_stack on_left (termF,skF) (termO,skO) evd = let switch f a b = if on_left then f a b else f b a in @@ -1216,7 +1216,7 @@ let error_cannot_unify env evd pb ?reason t1 t2 = let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with - | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb t1 t2 + | (pbty,env,t1,t2) as pb::_ -> error_cannot_unify env evd pb (EConstr.of_constr t1) (EConstr.of_constr t2) | _ -> () let max_undefined_with_candidates evd = @@ -1276,7 +1276,9 @@ let consider_remaining_unif_problems env let rec aux evd pbs progress stuck = match pbs with | (pbty,env,t1,t2 as pb) :: pbs -> - (match apply_conversion_problem_heuristic ts env evd pbty (EConstr.of_constr t1) (EConstr.of_constr t2) with + let t1 = EConstr.of_constr t1 in + let t2 = EConstr.of_constr t2 in + (match apply_conversion_problem_heuristic ts env evd pbty t1 t2 with | Success evd' -> let (evd', rest) = extract_all_conv_pbs evd' in begin match rest with @@ -1292,6 +1294,8 @@ let consider_remaining_unif_problems env match stuck with | [] -> (* We're finished *) evd | (pbty,env,t1,t2 as pb) :: _ -> + let t1 = EConstr.of_constr t1 in + let t2 = EConstr.of_constr t2 in (* There remains stuck problems *) error_cannot_unify env evd pb t1 t2 in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 3bcea4cee5..b1fc7cbe9a 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -147,17 +147,17 @@ let recheck_applications conv_algo env evdref t = | App (f, args) -> let () = aux env f in let fty = Retyping.get_type_of env !evdref f in - let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in + let argsty = Array.map (fun x -> aux env x; EConstr.of_constr (Retyping.get_type_of env !evdref x)) args in let rec aux i ty = if i < Array.length argsty then match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref ty)) with | Prod (na, dom, codom) -> - (match conv_algo env !evdref Reduction.CUMUL (EConstr.of_constr argsty.(i)) dom with + (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; aux (succ i) (Vars.subst1 args.(i) codom) | UnifFailure (evd, reason) -> - Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), EConstr.Unsafe.to_constr dom)) - | _ -> raise (IllTypedInstance (env, ty, EConstr.of_constr argsty.(i))) + Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) + | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) else () in aux 0 (EConstr.of_constr fty) | _ -> diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 23cb245e00..b83147514b 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -63,7 +63,7 @@ val is_unification_pattern_evar : env -> evar_map -> existential -> constr list val is_unification_pattern : env * int -> evar_map -> constr -> constr list -> constr -> constr list option -val solve_pattern_eqn : env -> evar_map -> constr list -> constr -> Constr.t +val solve_pattern_eqn : env -> evar_map -> constr list -> constr -> constr val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 2b243d5b9b..15409f2b86 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -85,7 +85,7 @@ let map_named_declaration_with_hyploc f hyploc acc decl = exception SubtermUnificationError of subterm_unification_error -exception NotUnifiable of (Constr.t * Constr.t * unification_error) option +exception NotUnifiable of (EConstr.t * EConstr.t * unification_error) option type 'a testing_function = { match_fun : 'a -> EConstr.constr -> 'a; diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index e7f0da93fb..c7db84e3c7 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -15,7 +15,7 @@ open Environ (** Finding subterms, possibly up to some unification function, possibly at some given occurrences *) -exception NotUnifiable of (constr * constr * unification_error) option +exception NotUnifiable of (EConstr.constr * EConstr.constr * unification_error) option exception SubtermUnificationError of subterm_unification_error diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index a93f2846b5..e30ba21fd1 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -504,7 +504,7 @@ let is_predicate_explicitly_dep env sigma pred arsign = let pv' = EConstr.of_constr (whd_all env sigma pval) in match EConstr.kind sigma pv', arsign with | Lambda (na,t,b), (LocalAssum _)::arsign -> - srec (push_rel_assum (na, EConstr.Unsafe.to_constr t) env) b arsign + srec (push_rel_assum (na, t) env) b arsign | Lambda (na,_,t), _ -> (* The following code has an impact on the introduction names diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index c14d815054..14b25ab368 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -29,7 +29,7 @@ type position = (Id.t * Locus.hyp_location_flag) option type position_reporting = (position * int) * EConstr.t -type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option +type subterm_unification_error = bool * position_reporting * position_reporting * (EConstr.constr * EConstr.constr * unification_error) option type pretype_error = (* Old Case *) @@ -37,17 +37,17 @@ type pretype_error = (* Type inference unification *) | ActualTypeNotCoercible of unsafe_judgment * types * unification_error (* Tactic unification *) - | UnifOccurCheck of existential_key * constr + | UnifOccurCheck of existential_key * EConstr.constr | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option - | CannotUnify of constr * constr * unification_error option - | CannotUnifyLocal of constr * constr * constr + | CannotUnify of EConstr.constr * EConstr.constr * unification_error option + | CannotUnifyLocal of EConstr.constr * EConstr.constr * EConstr.constr | CannotUnifyBindingType of constr * constr | CannotGeneralize of constr - | NoOccurrenceFound of constr * Id.t option - | CannotFindWellTypedAbstraction of constr * EConstr.constr list * (env * type_error) option - | WrongAbstractionType of Name.t * constr * types * types + | NoOccurrenceFound of EConstr.constr * Id.t option + | CannotFindWellTypedAbstraction of EConstr.constr * EConstr.constr list * (env * type_error) option + | WrongAbstractionType of Name.t * EConstr.constr * EConstr.types * EConstr.types | AbstractionOverMeta of Name.t * Name.t - | NonLinearUnification of Name.t * constr + | NonLinearUnification of Name.t * EConstr.constr (* Pretyping *) | VarNotFound of Id.t | UnexpectedType of constr * constr diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 217deda4d8..2e707a0ffc 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -30,7 +30,7 @@ type position = (Id.t * Locus.hyp_location_flag) option type position_reporting = (position * int) * EConstr.t -type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option +type subterm_unification_error = bool * position_reporting * position_reporting * (EConstr.constr * EConstr.constr * unification_error) option type pretype_error = (** Old Case *) @@ -38,17 +38,17 @@ type pretype_error = (** Type inference unification *) | ActualTypeNotCoercible of unsafe_judgment * types * unification_error (** Tactic Unification *) - | UnifOccurCheck of existential_key * constr + | UnifOccurCheck of existential_key * EConstr.constr | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option - | CannotUnify of constr * constr * unification_error option - | CannotUnifyLocal of constr * constr * constr + | CannotUnify of EConstr.constr * EConstr.constr * unification_error option + | CannotUnifyLocal of EConstr.constr * EConstr.constr * EConstr.constr | CannotUnifyBindingType of constr * constr | CannotGeneralize of constr - | NoOccurrenceFound of constr * Id.t option - | CannotFindWellTypedAbstraction of constr * EConstr.constr list * (env * type_error) option - | WrongAbstractionType of Name.t * constr * types * types + | NoOccurrenceFound of EConstr.constr * Id.t option + | CannotFindWellTypedAbstraction of EConstr.constr * EConstr.constr list * (env * type_error) option + | WrongAbstractionType of Name.t * EConstr.constr * EConstr.types * EConstr.types | AbstractionOverMeta of Name.t * Name.t - | NonLinearUnification of Name.t * constr + | NonLinearUnification of Name.t * EConstr.constr (** Pretyping *) | VarNotFound of Id.t | UnexpectedType of constr * constr @@ -94,32 +94,32 @@ val error_ill_typed_rec_body : val error_not_a_type : ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b -val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b +val error_cannot_coerce : env -> Evd.evar_map -> EConstr.constr * EConstr.constr -> 'b (** {6 Implicit arguments synthesis errors } *) -val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b +val error_occur_check : env -> Evd.evar_map -> existential_key -> EConstr.constr -> 'b val error_unsolvable_implicit : ?loc:Loc.t -> env -> Evd.evar_map -> existential_key -> Evd.unsolvability_explanation option -> 'b val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> - ?reason:unification_error -> constr * constr -> 'b + ?reason:unification_error -> EConstr.constr * EConstr.constr -> 'b -val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b +val error_cannot_unify_local : env -> Evd.evar_map -> EConstr.constr * EConstr.constr * EConstr.constr -> 'b val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> - constr -> EConstr.constr list -> (env * type_error) option -> 'b + EConstr.constr -> EConstr.constr list -> (env * type_error) option -> 'b val error_wrong_abstraction_type : env -> Evd.evar_map -> - Name.t -> constr -> types -> types -> 'b + Name.t -> EConstr.constr -> EConstr.types -> EConstr.types -> 'b val error_abstraction_over_meta : env -> Evd.evar_map -> metavariable -> metavariable -> 'b val error_non_linear_unification : env -> Evd.evar_map -> - metavariable -> constr -> 'b + metavariable -> EConstr.constr -> 'b (** {6 Ml Case errors } *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0b97cd253b..510417879e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1203,7 +1203,7 @@ let whd_allnolet env = (* 4. Ad-hoc eta reduction, does not subsitute evars *) -let shrink_eta c = EConstr.Unsafe.to_constr (Stack.zip Evd.empty (local_whd_state_gen eta Evd.empty (c,Stack.empty))) +let shrink_eta c = Stack.zip Evd.empty (local_whd_state_gen eta Evd.empty (c,Stack.empty)) (* 5. Zeta Reduction Functions *) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5e6a40786c..c3b82729d5 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -198,7 +198,7 @@ val whd_zeta_stack : local_stack_reduction_function val whd_zeta_state : local_state_reduction_function val whd_zeta : local_reduction_function -val shrink_eta : EConstr.t -> constr +val shrink_eta : EConstr.constr -> EConstr.constr (** Various reduction functions *) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 70aa0be6bd..c5c19b49ba 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -6,13 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open CErrors open Pp open Util open Names open Term -open Vars open Termops +open EConstr +open Vars open Namegen open Environ open Evd @@ -30,6 +33,13 @@ open Locusops open Find_subterm open Sigma.Notations +type metabinding = (metavariable * EConstr.constr * (instance_constraint * instance_typing_status)) + +type subst0 = + (evar_map * + metabinding list * + (Environ.env * EConstr.existential * EConstr.t) list) + module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration @@ -55,41 +65,44 @@ let _ = Goptions.declare_bool_option { } let occur_meta_or_undefined_evar evd c = - let rec occrec c = match kind_of_term c with + let rec occrec c = match EConstr.kind evd c with | Meta _ -> raise Occur - | Evar (ev,args) -> - (match evar_body (Evd.find evd ev) with - | Evar_defined c -> - occrec c; Array.iter occrec args - | Evar_empty -> raise Occur) - | _ -> Constr.iter occrec c + | Evar _ -> raise Occur + | _ -> EConstr.iter evd occrec c in try occrec c; false with Occur | Not_found -> true let occur_meta_evd sigma mv c = let rec occrec c = (* Note: evars are not instantiated by terms with metas *) - let c = whd_evar sigma (whd_meta sigma (EConstr.of_constr c)) in - match kind_of_term c with + let c = whd_meta sigma c in + let c = EConstr.of_constr c in + match EConstr.kind sigma c with | Meta mv' when Int.equal mv mv' -> raise Occur - | _ -> Constr.iter occrec c + | _ -> EConstr.iter sigma occrec c in try occrec c; false with Occur -> true (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) let abstract_scheme env evd c l lname_typ = + let open EConstr in + let mkLambda_name env (n,a,b) = + mkLambda (named_hd env (EConstr.Unsafe.to_constr a) n, a, b) + in List.fold_left2 (fun (t,evd) (locc,a) decl -> let na = RelDecl.get_name decl in let ta = RelDecl.get_type decl in - let na = match kind_of_term a with Var id -> Name id | _ -> na in + let ta = EConstr.of_constr ta in + let na = match EConstr.kind evd a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" else *) - if occur_meta evd (EConstr.of_constr a) then mkLambda_name env (na,ta,t), evd + if occur_meta evd a then mkLambda_name env (na,ta,t), evd else - let t', evd' = Find_subterm.subst_closed_term_occ env evd locc (EConstr.of_constr a) (EConstr.of_constr t) in + let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in + let t' = EConstr.of_constr t' in mkLambda_name env (na,ta,t'), evd') (c,evd) (List.rev l) @@ -98,16 +111,17 @@ let abstract_scheme env evd c l lname_typ = (* Precondition: resulting abstraction is expected to be of type [typ] *) let abstract_list_all env evd typ c l = - let ctxt,_ = splay_prod_n env evd (List.length l) (EConstr.of_constr typ) in + let ctxt,_ = splay_prod_n env evd (List.length l) typ in let l_with_all_occs = List.map (function a -> (LikeFirst,a)) l in let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in let evd,typp = - try Typing.type_of env evd (EConstr.of_constr p) + try Typing.type_of env evd p with | UserError _ -> - error_cannot_find_well_typed_abstraction env evd p (List.map EConstr.of_constr l) None + error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> - error_cannot_find_well_typed_abstraction env evd p (List.map EConstr.of_constr l) (Some (env',x)) in + error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in + let typp = EConstr.of_constr typp in evd,(p,typp) let set_occurrences_of_last_arg args = @@ -123,12 +137,12 @@ let abstract_list_all_with_dependencies env evd typ c l = let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = Evarconv.second_order_matching empty_transparent_state - env evd ev' argoccs (EConstr.of_constr c) in + env evd ev' argoccs c in if b then let p = nf_evar evd ev in evd, p else error_cannot_find_well_typed_abstraction env evd - (nf_evar evd c) l None + c l None (**) @@ -148,51 +162,53 @@ let extract_instance_status = function | CUMUL -> add_type_status (IsSubType, IsSuperType) | CONV -> add_type_status (Conv, Conv) -let rec subst_meta_instances bl c = - match kind_of_term c with +let rec subst_meta_instances sigma bl c = + match EConstr.kind sigma c with | Meta i -> let select (j,_,_) = Int.equal i j in (try pi2 (List.find select bl) with Not_found -> c) - | _ -> Constr.map (subst_meta_instances bl) c + | _ -> EConstr.map sigma (subst_meta_instances sigma bl) c (** [env] should be the context in which the metas live *) let pose_all_metas_as_evars env evd t = let evdref = ref evd in - let rec aux t = match kind_of_term t with + let rec aux t = match EConstr.kind !evdref t with | Meta mv -> (match Evd.meta_opt_fvalue !evdref mv with - | Some ({rebus=c},_) -> c + | Some ({rebus=c},_) -> EConstr.of_constr c | None -> let {rebus=ty;freemetas=mvs} = Evd.meta_ftype evd mv in + let ty = EConstr.of_constr ty in let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in let src = Evd.evar_source_of_meta mv !evdref in - let ty = EConstr.of_constr ty in let ev = Evarutil.e_new_evar env evdref ~src ty in evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref; - ev) + EConstr.of_constr ev) | _ -> - Constr.map aux t in + EConstr.map !evdref aux t in let c = aux t in (* side-effect *) (!evdref, c) -let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst) = - match kind_of_term f with +let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst : subst0) = + let open EConstr in + let open Vars in + match EConstr.kind sigma f with | Meta k -> (* We enforce that the Meta does not depend on the [nb] extra assumptions added by unification to the context *) let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in - let c = solve_pattern_eqn env sigma (List.map EConstr.of_constr l) (EConstr.of_constr c) in + let c = solve_pattern_eqn env sigma l c in let pb = (Conv,TypeNotProcessed) in - if noccur_between 1 nb c then + if noccur_between sigma 1 nb c then sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst else error_cannot_unify_local env sigma (applist (f, l),c,c) | Evar ev -> let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in - sigma,metasubst,(env,ev,solve_pattern_eqn env sigma (List.map EConstr.of_constr l) (EConstr.of_constr c))::evarsubst + sigma,metasubst,(env,ev,solve_pattern_eqn env sigma l c)::evarsubst | _ -> assert false let push d (env,n) = (push_rel_assum d env,n+1) @@ -456,15 +472,16 @@ let use_evars_pattern_unification flags = !global_pattern_unification_flag && flags.use_pattern_unification && Flags.version_strictly_greater Flags.V8_2 -let use_metas_pattern_unification flags nb l = +let use_metas_pattern_unification sigma flags nb l = + let open EConstr in !global_pattern_unification_flag && flags.use_pattern_unification || (Flags.version_less_or_equal Flags.V8_3 || flags.use_meta_bound_pattern_unification) && - Array.for_all (fun c -> isRel c && destRel c <= nb) l + Array.for_all (fun c -> isRel sigma c && destRel sigma c <= nb) l type key = | IsKey of CClosure.table_key - | IsProj of projection * constr + | IsProj of projection * EConstr.constr let expand_table_key env = function | ConstKey cst -> constant_opt_value_in env cst @@ -480,11 +497,11 @@ let unfold_projection env p stk = | None -> assert false) let expand_key ts env sigma = function - | Some (IsKey k) -> expand_table_key env k + | Some (IsKey k) -> Option.map EConstr.of_constr (expand_table_key env k) | Some (IsProj (p, c)) -> - let red = EConstr.Unsafe.to_constr (Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma - Cst_stack.empty (EConstr.of_constr c, unfold_projection env p [])))) - in if Term.eq_constr (mkProj (p, c)) red then None else Some red + let red = Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma + Cst_stack.empty (c, unfold_projection env p []))) + in if EConstr.eq_constr sigma (EConstr.mkProj (p, c)) red then None else Some red | None -> None @@ -497,9 +514,9 @@ type unirec_flags = { let subterm_restriction opt flags = not opt.at_top && flags.restrict_conv_on_strict_subterms -let key_of env b flags f = +let key_of env sigma b flags f = if subterm_restriction b flags then None else - match kind_of_term f with + match EConstr.kind sigma f with | Const (cst, u) when is_transparent env (ConstKey cst) && (Cpred.mem cst (snd flags.modulo_delta) || Environ.is_projection cst env) -> @@ -544,8 +561,8 @@ let oracle_order env cf1 cf2 = Some (Conv_oracle.oracle_order (fun x -> x) (Environ.oracle env) false (translate_key k1) (translate_key k2)) -let is_rigid_head flags t = - match kind_of_term t with +let is_rigid_head sigma flags t = + match EConstr.kind sigma t with | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta)) | Ind (i,u) -> true | Construct _ -> true @@ -561,15 +578,15 @@ let force_eqs c = let constr_cmp pb sigma flags t u = let cstrs = - if pb == Reduction.CONV then Universes.eq_constr_universes t u - else Universes.leq_constr_universes t u + if pb == Reduction.CONV then EConstr.eq_constr_universes sigma t u + else EConstr.leq_constr_universes sigma t u in match cstrs with | Some cstrs -> begin try Evd.add_universe_constraints sigma cstrs, true with Univ.UniverseInconsistency _ -> sigma, false | Evd.UniversesDiffer -> - if is_rigid_head flags t then + if is_rigid_head sigma flags t then try Evd.add_universe_constraints sigma (force_eqs cstrs), true with Univ.UniverseInconsistency _ -> sigma, false else sigma, false @@ -578,46 +595,47 @@ let constr_cmp pb sigma flags t u = sigma, false let do_reduce ts (env, nb) sigma c = - EConstr.Unsafe.to_constr (Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state - ts env sigma Cst_stack.empty (EConstr.of_constr c, Stack.empty)))) + Stack.zip sigma (fst (whd_betaiota_deltazeta_for_iota_state + ts env sigma Cst_stack.empty (c, Stack.empty))) let use_full_betaiota flags = flags.modulo_betaiota && Flags.version_strictly_greater Flags.V8_3 -let isAllowedEvar flags c = match kind_of_term c with +let isAllowedEvar sigma flags c = match EConstr.kind sigma c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) | _ -> false -let subst_defined_metas_evars (bl,el) c = - let rec substrec c = match kind_of_term c with +let subst_defined_metas_evars sigma (bl,el) c = + let rec substrec c = match EConstr.kind sigma c with | Meta i -> let select (j,_,_) = Int.equal i j in substrec (pi2 (List.find select bl)) | Evar (evk,args) -> - let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal Constr.equal args args' in + let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal (EConstr.eq_constr sigma) args args' in (try substrec (pi3 (List.find select el)) - with Not_found -> Constr.map substrec c) - | _ -> Constr.map substrec c + with Not_found -> EConstr.map sigma substrec c) + | _ -> EConstr.map sigma substrec c in try Some (substrec c) with Not_found -> None -let check_compatibility env pbty flags (sigma,metasubst,evarsubst) tyM tyN = - match subst_defined_metas_evars (metasubst,[]) tyM with +let check_compatibility env pbty flags (sigma,metasubst,evarsubst : subst0) tyM tyN = + match subst_defined_metas_evars sigma (metasubst,[]) (EConstr.of_constr tyM) with | None -> sigma | Some m -> - match subst_defined_metas_evars (metasubst,[]) tyN with + match subst_defined_metas_evars sigma (metasubst,[]) (EConstr.of_constr tyN) with | None -> sigma | Some n -> - if is_ground_term sigma (EConstr.of_constr m) && is_ground_term sigma (EConstr.of_constr n) then - let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma (EConstr.of_constr m) (EConstr.of_constr n) in + if is_ground_term sigma m && is_ground_term sigma n then + let sigma, b = infer_conv ~pb:pbty ~ts:flags.modulo_delta_types env sigma m n in if b then sigma else error_cannot_unify env sigma (m,n) else sigma -let rec is_neutral env ts t = - let (f, l) = decompose_appvect t in - match kind_of_term f with +let rec is_neutral env sigma ts t = + let open EConstr in + let (f, l) = decompose_app_vect sigma t in + match EConstr.kind sigma (EConstr.of_constr f) with | Const (c, u) -> not (Environ.evaluable_constant c env) || not (is_transparent env (ConstKey c)) || @@ -628,24 +646,25 @@ let rec is_neutral env ts t = not (Id.Pred.mem id (fst ts)) | Rel n -> true | Evar _ | Meta _ -> true - | Case (_, p, c, cl) -> is_neutral env ts c - | Proj (p, c) -> is_neutral env ts c + | Case (_, p, c, cl) -> is_neutral env sigma ts c + | Proj (p, c) -> is_neutral env sigma ts c | _ -> false -let is_eta_constructor_app env ts f l1 term = - match kind_of_term f with +let is_eta_constructor_app env sigma ts f l1 term = + match EConstr.kind sigma f with | Construct (((_, i as ind), j), u) when i == 0 && j == 1 -> let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with | Some (Some (_,exp,projs)) when mib.Declarations.mind_finite == Decl_kinds.BiFinite && Array.length projs == Array.length l1 - mib.Declarations.mind_nparams -> (** Check that the other term is neutral *) - is_neutral env ts term + is_neutral env sigma ts term | _ -> false) | _ -> false -let eta_constructor_app env f l1 term = - match kind_of_term f with +let eta_constructor_app env sigma f l1 term = + let open EConstr in + match EConstr.kind sigma f with | Construct (((_, i as ind), j), u) -> let mib = lookup_mind (fst ind) env in (match mib.Declarations.mind_record with @@ -658,15 +677,20 @@ let eta_constructor_app env f l1 term = | _ -> assert false) | _ -> assert false -let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flags m n = - let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn) curm curn = - let cM = EConstr.Unsafe.to_constr (Evarutil.whd_head_evar sigma (EConstr.of_constr curm)) - and cN = EConstr.Unsafe.to_constr (Evarutil.whd_head_evar sigma (EConstr.of_constr curn)) in +let print_constr_env env c = + print_constr_env env (EConstr.Unsafe.to_constr c) + +let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = + let open EConstr in + let open Vars in + let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = + let cM = Evarutil.whd_head_evar sigma curm + and cN = Evarutil.whd_head_evar sigma curn in let () = if !debug_unification then - Feedback.msg_debug (Termops.print_constr_env curenv cM ++ str" ~= " ++ Termops.print_constr_env curenv cN) + Feedback.msg_debug (print_constr_env curenv cM ++ str" ~= " ++ print_constr_env curenv cN) in - match (kind_of_term cM,kind_of_term cN) with + match (EConstr.kind sigma cM, EConstr.kind sigma cN) with | Meta k1, Meta k2 -> if Int.equal k1 k2 then substn else let stM,stN = extract_instance_status pb in @@ -681,12 +705,12 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ - when not (dependent sigma (EConstr.of_constr cM) (EConstr.of_constr cN)) (* helps early trying alternatives *) -> + when not (dependent sigma cM cN) (* helps early trying alternatives *) -> let sigma = if opt.with_types && flags.check_applied_meta_types then (try let tyM = Typing.meta_type sigma k in - let tyN = get_type_of curenv ~lax:true sigma (EConstr.of_constr cN) in + let tyN = get_type_of curenv ~lax:true sigma cN in check_compatibility curenv CUMUL flags substn tyN tyM with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma) @@ -695,17 +719,17 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb (* Here we check that [cN] does not contain any local variables *) if Int.equal nb 0 then sigma,(k,cN,snd (extract_instance_status pb))::metasubst,evarsubst - else if noccur_between 1 nb cN then + else if noccur_between sigma 1 nb cN then (sigma, (k,lift (-nb) cN,snd (extract_instance_status pb))::metasubst, evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Meta k - when not (dependent sigma (EConstr.of_constr cN) (EConstr.of_constr cM)) (* helps early trying alternatives *) -> + when not (dependent sigma cN cM) (* helps early trying alternatives *) -> let sigma = if opt.with_types && flags.check_applied_meta_types then (try - let tyM = get_type_of curenv ~lax:true sigma (EConstr.of_constr cM) in + let tyM = get_type_of curenv ~lax:true sigma cM in let tyN = Typing.meta_type sigma k in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> @@ -715,7 +739,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb (* Here we check that [cM] does not contain any local variables *) if Int.equal nb 0 then (sigma,(k,cM,fst (extract_instance_status pb))::metasubst,evarsubst) - else if noccur_between 1 nb cM + else if noccur_between sigma 1 nb cM then (sigma,(k,lift (-nb) cM,fst (extract_instance_status pb))::metasubst, evarsubst) @@ -730,15 +754,15 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb sigma,metasubst,((curenv,ev,cN)::evarsubst) | Evar (evk,_ as ev), _ when not (Evar.Set.mem evk flags.frozen_evars) - && not (occur_evar sigma evk (EConstr.of_constr cN)) -> - let cmvars = free_rels sigma (EConstr.of_constr cM) and cnvars = free_rels sigma (EConstr.of_constr cN) in + && not (occur_evar sigma evk cN) -> + let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in if Int.Set.subset cnvars cmvars then sigma,metasubst,((curenv,ev,cN)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) | _, Evar (evk,_ as ev) when not (Evar.Set.mem evk flags.frozen_evars) - && not (occur_evar sigma evk (EConstr.of_constr cM)) -> - let cmvars = free_rels sigma (EConstr.of_constr cM) and cnvars = free_rels sigma (EConstr.of_constr cN) in + && not (occur_evar sigma evk cM) -> + let cmvars = free_rels sigma cM and cnvars = free_rels sigma cN in if Int.Set.subset cmvars cnvars then sigma,metasubst,((curenv,ev,cM)::evarsubst) else error_cannot_unify_local curenv sigma (m,n,cN) @@ -781,30 +805,30 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb | App (f1, l1), _ when flags.modulo_eta && (* This ensures cN is an evar, meta or irreducible constant/variable and not a constructor. *) - is_eta_constructor_app curenv flags.modulo_delta f1 l1 cN -> + is_eta_constructor_app curenv sigma flags.modulo_delta f1 l1 cN -> (try - let l1', l2' = eta_constructor_app curenv f1 l1 cN in + let l1', l2' = eta_constructor_app curenv sigma f1 l1 cN in let opt' = {opt with at_top = true; with_cs = false} in Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' with ex when precatchable_exception ex -> - match kind_of_term cN with + match EConstr.kind sigma cN with | App(f2,l2) when - (isMeta f2 && use_metas_pattern_unification flags nb l2 - || use_evars_pattern_unification flags && isAllowedEvar flags f2) -> + (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> unify_app_pattern false curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> raise ex) | _, App (f2, l2) when flags.modulo_eta && - is_eta_constructor_app curenv flags.modulo_delta f2 l2 cM -> + is_eta_constructor_app curenv sigma flags.modulo_delta f2 l2 cM -> (try - let l2', l1' = eta_constructor_app curenv f2 l2 cM in + let l2', l1' = eta_constructor_app curenv sigma f2 l2 cM in let opt' = {opt with at_top = true; with_cs = false} in Array.fold_left2 (unirec_rec curenvnb CONV opt') substn l1' l2' with ex when precatchable_exception ex -> - match kind_of_term cM with + match EConstr.kind sigma cM with | App(f1,l1) when - (isMeta f1 && use_metas_pattern_unification flags nb l1 - || use_evars_pattern_unification flags && isAllowedEvar flags f1) -> + (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> raise ex) @@ -819,13 +843,13 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb reduce curenvnb pb opt substn cM cN) | App (f1,l1), _ when - (isMeta f1 && use_metas_pattern_unification flags nb l1 - || use_evars_pattern_unification flags && isAllowedEvar flags f1) -> + (isMeta sigma f1 && use_metas_pattern_unification sigma flags nb l1 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f1) -> unify_app_pattern true curenvnb pb opt substn cM f1 l1 cN cN [||] | _, App (f2,l2) when - (isMeta f2 && use_metas_pattern_unification flags nb l2 - || use_evars_pattern_unification flags && isAllowedEvar flags f2) -> + (isMeta sigma f2 && use_metas_pattern_unification sigma flags nb l2 + || use_evars_pattern_unification flags && isAllowedEvar sigma flags f2) -> unify_app_pattern false curenvnb pb opt substn cM cM [||] cN f2 l2 | App (f1,l1), App (f2,l2) -> @@ -840,32 +864,32 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb | _ -> unify_not_same_head curenvnb pb opt substn cM cN - and unify_app_pattern dir curenvnb pb opt substn cM f1 l1 cN f2 l2 = + and unify_app_pattern dir curenvnb pb opt (sigma, _, _ as substn) cM f1 l1 cN f2 l2 = let f, l, t = if dir then f1, l1, cN else f2, l2, cM in - match is_unification_pattern curenvnb sigma (EConstr.of_constr f) (Array.map_to_list EConstr.of_constr l) (EConstr.of_constr t) with + match is_unification_pattern curenvnb sigma f (Array.to_list l) t with | None -> - (match kind_of_term t with + (match EConstr.kind sigma t with | App (f',l') -> if dir then unify_app curenvnb pb opt substn cM f1 l1 t f' l' else unify_app curenvnb pb opt substn t f' l' cN f2 l2 | Proj _ -> unify_app curenvnb pb opt substn cM f1 l1 cN f2 l2 | _ -> unify_not_same_head curenvnb pb opt substn cM cN) | Some l -> - solve_pattern_eqn_array curenvnb f (List.map EConstr.Unsafe.to_constr l) t substn + solve_pattern_eqn_array curenvnb f l t substn - and unify_app (curenv, nb as curenvnb) pb opt (sigma, metas, evars as substn) cM f1 l1 cN f2 l2 = + and unify_app (curenv, nb as curenvnb) pb opt (sigma, metas, evars as substn : subst0) cM f1 l1 cN f2 l2 = try let needs_expansion p c' = - match kind_of_term c' with + match EConstr.kind sigma c' with | Meta _ -> true | Evar _ -> true | Const (c, u) -> Constant.equal c (Projection.constant p) | _ -> false in let expand_proj c c' l = - match kind_of_term c with + match EConstr.kind sigma c with | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> - (try destApp (Retyping.expand_projection curenv sigma p (EConstr.of_constr t) (Array.map_to_list EConstr.of_constr l)) + (try destApp sigma (EConstr.of_constr (Retyping.expand_projection curenv sigma p t (Array.to_list l))) with RetypeError _ -> (** Unification can be called on ill-typed terms, due to FO and eta in particular, fail gracefully in that case *) (c, l)) @@ -890,8 +914,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb and unify_same_proj (curenv, nb as curenvnb) cv_pb opt substn c1 c2 = let substn = unirec_rec curenvnb CONV opt substn c1 c2 in try (* Force unification of the types to fill in parameters *) - let ty1 = get_type_of curenv ~lax:true sigma (EConstr.of_constr c1) in - let ty2 = get_type_of curenv ~lax:true sigma (EConstr.of_constr c2) in + let ty1 = get_type_of curenv ~lax:true sigma c1 in + let ty2 = get_type_of curenv ~lax:true sigma c2 in + let ty1 = EConstr.of_constr ty1 in + let ty2 = EConstr.of_constr ty2 in unify_0_with_initial_metas substn true curenv cv_pb { flags with modulo_conv_on_closed_terms = Some full_transparent_state; modulo_delta = full_transparent_state; @@ -900,7 +926,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb ty1 ty2 with RetypeError _ -> substn - and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn) cM cN = + and unify_not_same_head curenvnb pb opt (sigma, metas, evars as substn : subst0) cM cN = try canonical_projections curenvnb pb opt cM cN substn with ex when precatchable_exception ex -> let sigma', b = constr_cmp cv_pb sigma flags cM cN in @@ -909,24 +935,24 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb try reduce curenvnb pb opt substn cM cN with ex when precatchable_exception ex -> let (f1,l1) = - match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in + match EConstr.kind sigma cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in let (f2,l2) = - match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in + match EConstr.kind sigma cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in expand curenvnb pb opt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb opt (sigma, metas, evars as substn) cM cN = if use_full_betaiota flags && not (subterm_restriction opt flags) then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in - if not (Term.eq_constr cM cM') then + if not (EConstr.eq_constr sigma cM cM') then unirec_rec curenvnb pb opt substn cM' cN else let cN' = do_reduce flags.modulo_delta curenvnb sigma cN in - if not (Term.eq_constr cN cN') then + if not (EConstr.eq_constr sigma cN cN') then unirec_rec curenvnb pb opt substn cM cN' else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) - and expand (curenv,_ as curenvnb) pb opt (sigma,metasubst,evarsubst as substn) cM f1 l1 cN f2 l2 = + and expand (curenv,_ as curenvnb) pb opt (sigma,metasubst,evarsubst as substn : subst0) cM f1 l1 cN f2 l2 = let res = (* Try full conversion on meta-free terms. *) (* Back to 1995 (later on called trivial_unify in 2002), the @@ -945,24 +971,23 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb | None -> None | Some convflags -> let subst = ((if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms), (if flags.use_evars_eagerly_in_conv_on_closed_terms then evarsubst else es)) in - match subst_defined_metas_evars subst cM with + match subst_defined_metas_evars sigma subst cM with | None -> (* some undefined Metas in cM *) None | Some m1 -> - match subst_defined_metas_evars subst cN with + match subst_defined_metas_evars sigma subst cN with | None -> (* some undefined Metas in cN *) None | Some n1 -> (* No subterm restriction there, too much incompatibilities *) let sigma = if opt.with_types then try (* Ensure we call conversion on terms of the same type *) - let tyM = get_type_of curenv ~lax:true sigma (EConstr.of_constr m1) in - let tyN = get_type_of curenv ~lax:true sigma (EConstr.of_constr n1) in + let tyM = get_type_of curenv ~lax:true sigma m1 in + let tyN = get_type_of curenv ~lax:true sigma n1 in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma else sigma in - let m1 = EConstr.of_constr m1 and n1 = EConstr.of_constr n1 in let sigma, b = infer_conv ~pb ~ts:convflags curenv sigma m1 n1 in if b then Some (sigma, metasubst, evarsubst) else @@ -973,40 +998,40 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb match res with | Some substn -> substn | None -> - let cf1 = key_of curenv opt flags f1 and cf2 = key_of curenv opt flags f2 in + let cf1 = key_of curenv sigma opt flags f1 and cf2 = key_of curenv sigma opt flags f2 in match oracle_order curenv cf1 cf2 with | None -> error_cannot_unify curenv sigma (cM,cN) | Some true -> (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l1)))) cN + (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l1)))) cN | None -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l2)))) + (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l2)))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l2)))) + (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l2)))) | None -> (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (whd_betaiotazeta sigma (EConstr.of_constr (mkApp(c,l1)))) cN + (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l1)))) cN | None -> error_cannot_unify curenv sigma (cM,cN))) and canonical_projections (curenv, _ as curenvnb) pb opt cM cN (sigma,_,_ as substn) = let f1 () = - if isApp cM then - let f1l1 = whd_nored_state sigma (EConstr.of_constr cM,Stack.empty) in + if isApp sigma cM then + let f1l1 = whd_nored_state sigma (cM,Stack.empty) in if is_open_canonical_projection curenv sigma f1l1 then - let f2l2 = whd_nored_state sigma (EConstr.of_constr cN,Stack.empty) in + let f2l2 = whd_nored_state sigma (cN,Stack.empty) in solve_canonical_projection curenvnb pb opt cM f1l1 cN f2l2 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1019,10 +1044,10 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb error_cannot_unify (fst curenvnb) sigma (cM,cN) else try f1 () with e when precatchable_exception e -> - if isApp cN then - let f2l2 = whd_nored_state sigma (EConstr.of_constr cN, Stack.empty) in + if isApp sigma cN then + let f2l2 = whd_nored_state sigma (cN, Stack.empty) in if is_open_canonical_projection curenv sigma f2l2 then - let f1l1 = whd_nored_state sigma (EConstr.of_constr cM, Stack.empty) in + let f1l1 = whd_nored_state sigma (cM, Stack.empty) in solve_canonical_projection curenvnb pb opt cN f2l2 cM f1l1 substn else error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1038,26 +1063,25 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb List.fold_left (fun (evd,ks,m) b -> if match n with Some n -> Int.equal m n | None -> false then - (evd,EConstr.Unsafe.to_constr t2::ks, m-1) + (evd,t2::ks, m-1) else let mv = new_meta () in - let evd' = meta_declare mv (substl ks b) evd in + let evd' = meta_declare mv (EConstr.Unsafe.to_constr (substl ks b)) evd in (evd', mkMeta mv :: ks, m - 1)) - (sigma,[],List.length bs) (List.map EConstr.Unsafe.to_constr bs) + (sigma,[],List.length bs) bs in try let opt' = {opt with with_types = false} in - let inj = EConstr.Unsafe.to_constr in let (substn,_,_) = Reductionops.Stack.fold2 - (fun s u1 u -> unirec_rec curenvnb pb opt' s (inj u1) (substl ks (inj u))) + (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) (evd,ms,es) us2 us in let (substn,_,_) = Reductionops.Stack.fold2 - (fun s u1 u -> unirec_rec curenvnb pb opt' s (inj u1) (substl ks (inj u))) + (fun s u1 u -> unirec_rec curenvnb pb opt' s u1 (substl ks u)) substn params1 params in - let (substn,_,_) = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s (inj u1) (inj u2)) substn ts ts1 in - let app = mkApp (EConstr.Unsafe.to_constr c, Array.rev_of_list ks) in + let (substn,_,_) = Reductionops.Stack.fold2 (fun s u1 u2 -> unirec_rec curenvnb pb opt' s u1 u2) substn ts ts1 in + let app = mkApp (c, Array.rev_of_list ks) in (* let substn = unirec_rec curenvnb pb b false substn t cN in *) - unirec_rec curenvnb pb opt' substn (EConstr.Unsafe.to_constr c1) app + unirec_rec curenvnb pb opt' substn c1 app with Invalid_argument "Reductionops.Stack.fold2" -> error_cannot_unify (fst curenvnb) sigma (cM,cN) else error_cannot_unify (fst curenvnb) sigma (cM,cN) @@ -1073,7 +1097,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb None else let sigma, b = match flags.modulo_conv_on_closed_terms with - | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma (EConstr.of_constr m) (EConstr.of_constr n) + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n | _ -> constr_cmp cv_pb sigma flags m n in if b then Some sigma else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with @@ -1101,7 +1125,9 @@ let right = false let rec unify_with_eta keptside flags env sigma c1 c2 = (* Question: try whd_all on ci if not two lambdas? *) - match kind_of_term c1, kind_of_term c2 with + let open EConstr in + let open Vars in + match EConstr.kind sigma c1, EConstr.kind sigma c2 with | (Lambda (na,t1,c1'), Lambda (_,t2,c2')) -> let env' = push_rel_assum (na,t1) env in let sigma,metas,evars = unify_0 env sigma CONV flags t1 t2 in @@ -1205,32 +1231,39 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * since other metavars might also need to be resolved. *) let applyHead env (type r) (evd : r Sigma.t) n c = + let open EConstr in + let open Vars in let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma = fun n c cty p evd -> if Int.equal n 0 then Sigma (c, evd, p) else - match kind_of_term (whd_all env (Sigma.to_evar_map evd) (EConstr.of_constr cty)) with + let sigma = Sigma.to_evar_map evd in + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma cty)) with | Prod (_,c1,c2) -> - let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) (EConstr.of_constr c1) in + let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in + let evar = EConstr.of_constr evar in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' | _ -> error "Apply_Head_Then" in - apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) (EConstr.of_constr c)) Sigma.refl evd + apprec n c (EConstr.of_constr (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c)) Sigma.refl evd -let is_mimick_head ts f = - match kind_of_term f with +let is_mimick_head sigma ts f = + match EConstr.kind sigma f with | Const (c,u) -> not (CClosure.is_transparent_constant ts c) | Var id -> not (CClosure.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false +let make_judge c t = + make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr t) + let try_to_coerce env evd c cty tycon = let j = make_judge c cty in - let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j (EConstr.of_constr tycon) in + let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in let evd' = Evarconv.consider_remaining_unif_problems env evd' in let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in - (evd',j'.uj_val) + (evd',EConstr.of_constr j'.uj_val) let w_coerce_to_type env evd c cty mvty = let evd,tycon = pose_all_metas_as_evars env evd mvty in @@ -1239,19 +1272,19 @@ let w_coerce_to_type env evd c cty mvty = (* inh_conv_coerce_rigid_to should have reasoned modulo reduction but there are cases where it though it was not rigid (like in fst (nat,nat)) and stops while it could have seen that it is rigid *) - let cty = Tacred.hnf_constr env evd (EConstr.of_constr cty) in - try_to_coerce env evd c cty tycon + let cty = Tacred.hnf_constr env evd cty in + try_to_coerce env evd c (EConstr.of_constr cty) tycon let w_coerce env evd mv c = - let cty = get_type_of env evd (EConstr.of_constr c) in + let cty = get_type_of env evd c in let mvty = Typing.meta_type evd mv in - w_coerce_to_type env evd c cty mvty + w_coerce_to_type env evd c (EConstr.of_constr cty) (EConstr.of_constr mvty) let unify_to_type env sigma flags c status u = - let sigma, c = refresh_universes (Some false) env sigma (EConstr.of_constr c) in + let sigma, c = refresh_universes (Some false) env sigma c in let t = get_type_of env sigma (EConstr.of_constr (nf_meta sigma c)) in let t = nf_betaiota sigma (EConstr.of_constr (nf_meta sigma t)) in - unify_0 env sigma CUMUL flags t u + unify_0 env sigma CUMUL flags (EConstr.of_constr t) (EConstr.of_constr u) let unify_type env sigma flags mv status c = let mvty = Typing.meta_type sigma mv in @@ -1274,9 +1307,10 @@ let order_metas metas = (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) let solve_simple_evar_eqn ts env evd ev rhs = - match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,EConstr.of_constr rhs) with + let open EConstr in + match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with | UnifFailure (evd,reason) -> - error_cannot_unify env evd ~reason (EConstr.Unsafe.to_constr (EConstr.mkEvar ev),rhs); + error_cannot_unify env evd ~reason (mkEvar ev,rhs); | Success evd -> Evarconv.consider_remaining_unif_problems env evd @@ -1284,25 +1318,27 @@ let solve_simple_evar_eqn ts env evd ev rhs = or in evars, possibly generating new unification problems; if [b] is true, unification of types of metas is required *) -let w_merge env with_types flags (evd,metas,evars) = +let w_merge env with_types flags (evd,metas,evars : subst0) = + let open EConstr in + let open Vars in let rec w_merge_rec evd metas evars eqns = (* Process evars *) match evars with | (curenv,(evk,_ as ev),rhs)::evars' -> if Evd.is_defined evd evk then - let v = Evd.existential_value evd ev in + let v = mkEvar ev in let (evd,metas',evars'') = unify_0 curenv evd CONV flags rhs v in w_merge_rec evd (metas'@metas) (evars''@evars') eqns else begin (* This can make rhs' ill-typed if metas are *) - let rhs' = subst_meta_instances metas rhs in - match kind_of_term rhs with - | App (f,cl) when occur_meta evd (EConstr.of_constr rhs') -> - if occur_evar evd evk (EConstr.of_constr rhs') then + let rhs' = subst_meta_instances evd metas rhs in + match EConstr.kind evd rhs with + | App (f,cl) when occur_meta evd rhs' -> + if occur_evar evd evk rhs' then error_occur_check curenv evd evk rhs'; - if is_mimick_head flags.modulo_delta f then + if is_mimick_head evd flags.modulo_delta f then let evd' = mimick_undefined_evar evd flags f (Array.length cl) evk in (* let evd' = Evarconv.consider_remaining_unif_problems env evd' in *) @@ -1310,14 +1346,14 @@ let w_merge env with_types flags (evd,metas,evars) = else let evd' = let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' (fst ev, Array.map EConstr.of_constr (snd ev)) rhs'' + try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev,rhs'') in w_merge_rec evd' metas evars' eqns | _ -> let evd', rhs'' = pose_all_metas_as_evars curenv evd rhs' in let evd' = - try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' (fst ev, Array.map EConstr.of_constr (snd ev)) rhs'' + try solve_simple_evar_eqn flags.modulo_delta_types curenv evd' ev rhs'' with Retyping.RetypeError _ -> error_cannot_unify curenv evd' (mkEvar ev, rhs'') in w_merge_rec evd' metas evars' eqns @@ -1343,20 +1379,20 @@ let w_merge env with_types flags (evd,metas,evars) = if meta_defined evd mv then let {rebus=c'},(status',_) = meta_fvalue evd mv in let (take_left,st,(evd,metas',evars')) = - merge_instances env evd flags status' status c' c + merge_instances env evd flags status' status (EConstr.of_constr c') c in let evd' = if take_left then evd - else meta_reassign mv (c,(st,TypeProcessed)) evd + else meta_reassign mv (EConstr.Unsafe.to_constr c,(st,TypeProcessed)) evd in w_merge_rec evd' (metas'@metas@metas'') (evars'@evars'') eqns else let evd' = if occur_meta_evd evd mv c then - if isMetaOf mv (whd_all env evd (EConstr.of_constr c)) then evd + if isMetaOf mv (whd_all env evd c) then evd else error_cannot_unify env evd (mkMeta mv,c) else - meta_assign mv (c,(status,TypeProcessed)) evd in + meta_assign mv (EConstr.Unsafe.to_constr c,(status,TypeProcessed)) evd in w_merge_rec evd' (metas''@metas) evars'' eqns | [] -> (* Process type eqns *) @@ -1382,17 +1418,17 @@ let w_merge env with_types flags (evd,metas,evars) = let evd' = Sigma.to_evar_map evd' in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags - (get_type_of sp_env evd' (EConstr.of_constr c)) ev.evar_concl in + (EConstr.of_constr (get_type_of sp_env evd' c)) (EConstr.of_constr ev.evar_concl) in let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' - then Evd.define sp c evd''' - else Evd.define sp (Evarutil.nf_evar evd''' c) evd''' in + then Evd.define sp (EConstr.Unsafe.to_constr c) evd''' + else Evd.define sp (Evarutil.nf_evar evd''' (EConstr.Unsafe.to_constr c)) evd''' in let check_types evd = let metas = Evd.meta_list evd in let eqns = List.fold_left (fun acc (mv, b) -> match b with - | Clval (n, (t, (c, TypeNotProcessed)), v) -> (mv, c, t.rebus) :: acc + | Clval (n, (t, (c, TypeNotProcessed)), v) -> (mv, c, EConstr.of_constr t.rebus) :: acc | _ -> acc) [] metas in w_merge_rec evd [] [] eqns in @@ -1404,6 +1440,11 @@ let w_merge env with_types flags (evd,metas,evars) = if with_types then check_types res else res +let retract_coercible_metas evd = + let (metas, evd) = retract_coercible_metas evd in + let map (mv, c, st) = (mv, EConstr.of_constr c, st) in + (List.map map metas, evd) + let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = let metas,evd = retract_coercible_metas evd in w_merge env true flags.merge_unify_flags (evd,metas,[]) @@ -1419,19 +1460,23 @@ let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = types of metavars are unifiable with the types of their instances *) let head_app sigma m = - EConstr.Unsafe.to_constr (fst (whd_nored_state sigma (EConstr.of_constr m, Stack.empty))) + fst (whd_nored_state sigma (m, Stack.empty)) + +let isEvar_or_Meta sigma c = match EConstr.kind sigma c with +| Evar _ | Meta _ -> true +| _ -> false let check_types env flags (sigma,_,_ as subst) m n = - if isEvar_or_Meta (head_app sigma m) then + if isEvar_or_Meta sigma (head_app sigma m) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma (EConstr.of_constr n)) - (get_type_of env sigma (EConstr.of_constr m)) - else if isEvar_or_Meta (head_app sigma n) then + (EConstr.of_constr (get_type_of env sigma n)) + (EConstr.of_constr (get_type_of env sigma m)) + else if isEvar_or_Meta sigma (head_app sigma n) then unify_0_with_initial_metas subst true env CUMUL flags - (get_type_of env sigma (EConstr.of_constr m)) - (get_type_of env sigma (EConstr.of_constr n)) + (EConstr.of_constr (get_type_of env sigma m)) + (EConstr.of_constr (get_type_of env sigma n)) else subst let try_resolve_typeclasses env evd flag m n = @@ -1453,6 +1498,11 @@ let w_unify_core_0 env evd with_types cv_pb flags m n = let w_typed_unify env evd = w_unify_core_0 env evd true let w_typed_unify_array env evd flags f1 l1 f2 l2 = + let open EConstr in + let f1 = EConstr.of_constr f1 in + let f2 = EConstr.of_constr f2 in + let l1 = Array.map EConstr.of_constr l1 in + let l2 = Array.map EConstr.of_constr l2 in let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in let (mc1,evd') = retract_coercible_metas evd in let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags m n in @@ -1479,7 +1529,8 @@ let iter_fail f a = contexts, with evars, and possibly with occurrences *) let indirectly_dependent sigma c d decls = - not (isVar c) && + let open EConstr in + not (isVar sigma c) && (* This test is not needed if the original term is a variable, but it is needed otherwise, as e.g. when abstracting over "2" in "forall H:0=2, H=H:>(0=1+1) -> 0=2." where there is now obvious @@ -1493,7 +1544,8 @@ let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sig let current_sigma = Sigma.to_evar_map current_sigma in let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in let sigma, subst = nf_univ_variables sigma in - Sigma.Unsafe.of_pair (subst_univs_constr subst (nf_evar sigma c), sigma) + let c = EConstr.Unsafe.to_constr c in + Sigma.Unsafe.of_pair (EConstr.of_constr (CVars.subst_univs_constr subst (nf_evar sigma c)), sigma) let default_matching_core_flags sigma = let ts = Names.full_transparent_state in { @@ -1538,6 +1590,7 @@ let default_matching_flags (sigma,_) = exception PatternNotFound let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = + let open EConstr in let flags = if from_prefix_of_ind then let flags = default_matching_flags pending in @@ -1545,7 +1598,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = modulo_conv_on_closed_terms = Some Names.full_transparent_state; restrict_conv_on_strict_subterms = true } } else default_matching_flags pending in - let n = List.length (snd (decompose_app c)) in + let n = Array.length (snd (decompose_app_vect sigma c)) in let matching_fun _ t = let open EConstr in try @@ -1560,8 +1613,9 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = else applist (t,l1), l2 else t, [] in - let sigma = w_typed_unify env sigma Reduction.CONV flags c (EConstr.Unsafe.to_constr t') in + let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in let ty = Retyping.get_type_of env sigma t in + let ty = EConstr.of_constr ty in if not (is_correct_type ty) then raise (NotUnifiable None); Some(sigma, t, l2) with @@ -1582,19 +1636,20 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = (fun test -> match test.testing_state with | None -> None | Some (sigma,_,l) -> - let c = applist (nf_evar sigma (local_strong whd_meta sigma (EConstr.of_constr c)), List.map (EConstr.to_constr sigma) l) in + let c = applist (EConstr.of_constr (nf_evar sigma (local_strong whd_meta sigma c)), l) in let univs, subst = nf_univ_variables sigma in - Some (sigma,subst_univs_constr subst c)) + Some (sigma,EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr c)))) let make_eq_test env evd c = let out cstr = - match cstr.last_found with None -> None | _ -> Some (cstr.testing_state, EConstr.Unsafe.to_constr c) + match cstr.last_found with None -> None | _ -> Some (cstr.testing_state, c) in (make_eq_univs_test env evd c, out) let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let id = - let t = match ty with Some t -> t | None -> get_type_of env sigma (EConstr.of_constr c) in + let ty = Option.map EConstr.Unsafe.to_constr ty in + let t = match ty with Some t -> t | None -> get_type_of env sigma c in let x = id_of_name_using_hdchar (Global.env()) t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else @@ -1634,7 +1689,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - replace_term_occ_modulo sigma occ test mkvarid (EConstr.of_constr concl) + EConstr.of_constr (replace_term_occ_modulo sigma occ test mkvarid concl) in let lastlhyp = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in @@ -1660,6 +1715,8 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = type prefix_of_inductive_support_flag = bool +type pending_constr = Evd.pending * constr + type abstraction_request = | AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Name.t * pending_constr * clause * bool | AbstractExact of Name.t * constr * types option * clause * bool @@ -1678,7 +1735,7 @@ let make_abstraction env evd ccl abs = env evd (snd c) None occs check_occs ccl | AbstractExact (name,c,ty,occs,check_occs) -> make_abstraction_core name - (make_eq_test env evd (EConstr.of_constr c)) + (make_eq_test env evd c) env evd c ty occs check_occs ccl let keyed_unify env evd kop = @@ -1688,7 +1745,7 @@ let keyed_unify env evd kop = | None -> fun _ -> true | Some kop -> fun cl -> - let kc = Keys.constr_key cl in + let kc = Keys.constr_key (EConstr.to_constr evd cl) in match kc with | None -> false | Some kc -> Keys.equiv_keys kop kc @@ -1697,23 +1754,25 @@ let keyed_unify env evd kop = Unifies [cl] to every subterm of [op] until it finds a match. Fails if no match is found *) let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = + let open EConstr in + let open Vars in let bestexn = ref None in - let kop = Keys.constr_key op in + let kop = Keys.constr_key (EConstr.to_constr evd op) in let rec matchrec cl = - let cl = strip_outer_cast evd (EConstr.of_constr cl) in + let cl = EConstr.of_constr (strip_outer_cast evd cl) in (try - if closed0 cl && not (isEvar cl) && keyed_unify env evd kop cl then + if closed0 evd cl && not (isEvar evd cl) && keyed_unify env evd kop cl then (try if !keyed_unification then - let f1, l1 = decompose_app_vect evd (EConstr.of_constr op) in - let f2, l2 = decompose_app_vect evd (EConstr.of_constr cl) in + let f1, l1 = decompose_app_vect evd op in + let f2, l2 = decompose_app_vect evd cl in w_typed_unify_array env evd flags f1 l1 f2 l2,cl else w_typed_unify env evd CONV flags op cl,cl with ex when Pretype_errors.unsatisfiable_exception ex -> bestexn := Some ex; error "Unsat") else error "Bound 1" with ex when precatchable_exception ex -> - (match kind_of_term cl with + (match EConstr.kind evd cl with | App (f,args) -> let n = Array.length args in assert (n>0); @@ -1772,9 +1831,11 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = Unifies [cl] to every subterm of [op] and return all the matches. Fails if no match is found *) let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = + let open EConstr in + let open Vars in let return a b = let (evd,c as a) = a () in - if List.exists (fun (evd',c') -> Term.eq_constr c c') b then b else a :: b + if List.exists (fun (evd',c') -> EConstr.eq_constr evd' c c') b then b else a :: b in let fail str _ = error str in let bind f g a = @@ -1793,12 +1854,13 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = in ffail 0 in let rec matchrec cl = - let cl = strip_outer_cast evd (EConstr.of_constr cl) in + let cl = strip_outer_cast evd cl in + let cl = EConstr.of_constr cl in (bind - (if closed0 cl + (if closed0 evd cl then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) else fail "Bound 1") - (match kind_of_term cl with + (match EConstr.kind evd cl with | App (f,args) -> let n = Array.length args in assert (n>0); @@ -1835,16 +1897,18 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | _ -> res let w_unify_to_subterm_list env evd flags hdmeta oplist t = + let open EConstr in List.fold_right (fun op (evd,l) -> - let op = whd_meta evd (EConstr.of_constr op) in - if isMeta op then + let op = whd_meta evd op in + let op = EConstr.of_constr op in + if isMeta evd op then if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l) - else error_abstraction_over_meta env evd hdmeta (destMeta op) + else error_abstraction_over_meta env evd hdmeta (destMeta evd op) else let allow_K = flags.allow_K_in_toplevel_higher_order_unification in let flags = - if occur_meta_or_existential evd (EConstr.of_constr op) || !keyed_unification then + if occur_meta_or_existential evd op || !keyed_unification then (* This is up to delta for subterms w/o metas ... *) flags else @@ -1853,7 +1917,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = unify pre-existing non frozen evars of the goal or of the pattern *) set_no_delta_flags flags in - let t' = (strip_outer_cast evd (EConstr.of_constr op),t) in + let t' = (EConstr.of_constr (strip_outer_cast evd op),t) in let (evd',cl) = try if is_keyed_unification () then @@ -1869,11 +1933,11 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = (* w_unify_to_subterm does not go through evars, so the next step, which was already in <= 8.4, is needed at least for compatibility of rewrite *) - dependent evd (EConstr.of_constr op) (EConstr.of_constr t) -> (evd,op) + dependent evd op t -> (evd,op) in if not allow_K && (* ensure we found a different instance *) - List.exists (fun op -> Term.eq_constr op cl) l + List.exists (fun op -> EConstr.eq_constr evd' op cl) l then error_non_linear_unification env evd hdmeta cl else (evd',cl::l)) oplist @@ -1884,8 +1948,9 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let flags = { flags with core_unify_flags = flags.subterm_unify_flags } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in + let typp = EConstr.of_constr typp in let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in - let evd', b = infer_conv ~pb:CUMUL env evd' (EConstr.of_constr predtyp) (EConstr.of_constr typp) in + let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in if not b then error_wrong_abstraction_type env evd' (Evd.meta_name evd p) pred typp predtyp; @@ -1902,7 +1967,8 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let evd, pred = abstract_list_all_with_dependencies env evd (EConstr.of_constr typp) typ (List.map EConstr.of_constr oplist) in + let evd, pred = abstract_list_all_with_dependencies env evd (EConstr.of_constr typp) typ oplist in + let pred = EConstr.of_constr pred in w_merge env false flags.merge_unify_flags (evd,[p,pred,(Conv,TypeProcessed)],[]) @@ -1910,16 +1976,15 @@ let secondOrderAbstractionAlgo dep = if dep then secondOrderDependentAbstraction else secondOrderAbstraction let w_unify2 env evd flags dep cv_pb ty1 ty2 = - let inj = EConstr.Unsafe.to_constr in - let c1, oplist1 = whd_nored_stack evd (EConstr.of_constr ty1) in - let c2, oplist2 = whd_nored_stack evd (EConstr.of_constr ty2) in + let c1, oplist1 = whd_nored_stack evd ty1 in + let c2, oplist2 = whd_nored_stack evd ty2 in match EConstr.kind evd c1, EConstr.kind evd c2 with | Meta p1, _ -> (* Find the predicate *) - secondOrderAbstractionAlgo dep env evd flags ty2 (p1, List.map inj oplist1) + secondOrderAbstractionAlgo dep env evd flags ty2 (p1, oplist1) | _, Meta p2 -> (* Find the predicate *) - secondOrderAbstractionAlgo dep env evd flags ty1 (p2, List.map inj oplist2) + secondOrderAbstractionAlgo dep env evd flags ty1 (p2, oplist2) | _ -> error "w_unify2" (* The unique unification algorithm works like this: If the pattern is @@ -1943,8 +2008,9 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = - let hd1,l1 = decompose_appvect (whd_nored evd (EConstr.of_constr ty1)) in - let hd2,l2 = decompose_appvect (whd_nored evd (EConstr.of_constr ty2)) in + let open EConstr in + let hd1,l1 = decompose_app_vect evd (EConstr.of_constr (whd_nored evd ty1)) in + let hd2,l2 = decompose_app_vect evd (EConstr.of_constr (whd_nored evd ty2)) in let is_empty1 = Array.is_empty l1 in let is_empty2 = Array.is_empty l2 in match kind_of_term hd1, not is_empty1, kind_of_term hd2, not is_empty2 with diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 0ad882a9ff..41dcb8ed30 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -7,6 +7,7 @@ (************************************************************************) open Term +open EConstr open Environ open Evd @@ -70,6 +71,8 @@ exception PatternNotFound type prefix_of_inductive_support_flag = bool +type pending_constr = Evd.pending * constr + type abstraction_request = | AbstractPattern of prefix_of_inductive_support_flag * (types -> bool) * Names.Name.t * pending_constr * Locus.clause * bool | AbstractExact of Names.Name.t * constr * types option * Locus.clause * bool @@ -97,28 +100,29 @@ val abstract_list_all : (* For tracing *) -val w_merge : env -> bool -> core_unify_flags -> evar_map * - (metavariable * constr * (instance_constraint * instance_typing_status)) list * - (env * types pexistential * types) list -> evar_map +type metabinding = (metavariable * constr * (instance_constraint * instance_typing_status)) + +type subst0 = + (evar_map * + metabinding list * + (Environ.env * existential * t) list) + +val w_merge : env -> bool -> core_unify_flags -> subst0 -> evar_map val unify_0 : Environ.env -> Evd.evar_map -> Evd.conv_pb -> core_unify_flags -> - Term.types -> - Term.types -> - Evd.evar_map * Evd.metabinding list * - (Environ.env * Term.types Term.pexistential * Term.constr) list + types -> + types -> + subst0 val unify_0_with_initial_metas : - Evd.evar_map * Evd.metabinding list * - (Environ.env * Term.types Term.pexistential * Term.constr) list -> + subst0 -> bool -> Environ.env -> Evd.conv_pb -> core_unify_flags -> - Term.types -> - Term.types -> - Evd.evar_map * Evd.metabinding list * - (Environ.env * Term.types Term.pexistential * Term.constr) list - + types -> + types -> + subst0 -- cgit v1.2.3 From ca993b9e7765ac58f70740818758457c9367b0da Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 00:29:02 +0100 Subject: Making judgment type generic over the type of inner constrs. This allows to factorize code and prevents the unnecessary use of back and forth conversions between the various types of terms. Note that functions from typing may now raise errors as PretypeError rather than TypeError, because they call the proper wrapper. I think that they were wrongly calling the kernel because of an overlook of open modules. --- pretyping/cases.ml | 57 ++++++------- pretyping/cases.mli | 6 +- pretyping/classops.ml | 2 +- pretyping/classops.mli | 2 +- pretyping/coercion.ml | 60 ++++++++------ pretyping/coercion.mli | 9 +- pretyping/evarconv.ml | 4 +- pretyping/pretype_errors.ml | 24 ++++-- pretyping/pretype_errors.mli | 41 ++++++---- pretyping/pretyping.ml | 157 ++++++++++++++++++----------------- pretyping/pretyping.mli | 12 +-- pretyping/retyping.ml | 2 +- pretyping/retyping.mli | 2 +- pretyping/typing.ml | 191 +++++++++++++++++++++++++++++-------------- pretyping/typing.mli | 10 ++- pretyping/unification.ml | 8 +- 16 files changed, 348 insertions(+), 239 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 92bd1e3895..b43e2193af 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -89,9 +89,6 @@ let list_try_compile f l = let force_name = let nx = Name default_dependent_ident in function Anonymous -> nx | na -> na -let make_judge c ty = - make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr ty) - (************************************************************************) (* Pattern-matching compilation (Cases) *) (************************************************************************) @@ -265,7 +262,7 @@ type 'a pattern_matching_problem = mat : 'a matrix; caseloc : Loc.t; casestyle : case_style; - typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } + typing_function: type_constraint -> env -> evar_map ref -> 'a option -> EConstr.unsafe_judgment } (*--------------------------------------------------------------------------* * A few functions to infer the inductive type from the patterns instead of * @@ -366,12 +363,12 @@ let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = let j = typing_fun tycon env evdref tomatch in let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !evdref j in evdref := evd; - let typ = EConstr.of_constr (nf_evar !evdref j.uj_type) in + let typ = EConstr.of_constr (nf_evar !evdref (EConstr.Unsafe.to_constr j.uj_type)) in let t = try try_find_ind env !evdref typ realnames with Not_found -> unify_tomatch_with_patterns evdref env loc typ pats realnames in - (EConstr.of_constr j.uj_val,t) + (j.uj_val,t) let coerce_to_indtype typing_fun evdref env matx tomatchl = let pats = List.map (fun r -> r.patterns) matx in @@ -415,7 +412,7 @@ let adjust_tomatch_to_pattern pb ((current,typ),deps,dep) = let _ = e_cumul pb.env pb.evdref indt typ in current else - EConstr.of_constr (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env) + (evd_comb2 (Coercion.inh_conv_coerce_to true Loc.ghost pb.env) pb.evdref (make_judge current typ) indt).uj_val in let sigma = !(pb.evdref) in (current,try_find_ind pb.env sigma indt names)) @@ -1002,7 +999,7 @@ let adjust_impossible_cases pb pred tomatch submat = | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> if not (Evd.is_defined !(pb.evdref) evk) then begin let evd, default = use_unit_judge !(pb.evdref) in - pb.evdref := Evd.define evk default.uj_type evd + pb.evdref := Evd.define evk (EConstr.Unsafe.to_constr default.uj_type) evd end; add_assert_false_case pb tomatch | _ -> @@ -1411,8 +1408,8 @@ and match_current pb (initial,tomatch) = make_case_or_project pb.env !(pb.evdref) indf ci pred current brvals in Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; - { uj_val = EConstr.Unsafe.to_constr (applist (case, inst)); - uj_type = EConstr.Unsafe.to_constr (prod_applist !(pb.evdref) typ inst) } + { uj_val = applist (case, inst); + uj_type = prod_applist !(pb.evdref) typ inst } (* Building the sub-problem when all patterns are variables. Case @@ -1429,8 +1426,8 @@ and shift_problem ((current,t),_,na) pb = history = pop_history pb.history; mat = List.map (push_current_pattern (current,ty)) pb.mat } in let j = compile pb in - { uj_val = EConstr.Unsafe.to_constr (subst1 current (EConstr.of_constr j.uj_val)); - uj_type = EConstr.Unsafe.to_constr (subst1 current (EConstr.of_constr j.uj_type)) } + { uj_val = subst1 current j.uj_val; + uj_type = subst1 current j.uj_type } (* Building the sub-problem when all patterns are variables, non-initial case. Variables which appear as subterms of constructor @@ -1453,7 +1450,7 @@ and compile_all_variables initial cur pb = (* Building the sub-problem when all patterns are variables *) and compile_branch initial current realargs names deps pb arsign eqns cstr = let sign, pb = build_branch initial current realargs deps names pb arsign eqns cstr in - sign, EConstr.of_constr (compile pb).uj_val + sign, (compile pb).uj_val (* Abstract over a declaration before continuing splitting *) and compile_generalization pb i d rest = @@ -1463,8 +1460,8 @@ and compile_generalization pb i d rest = tomatch = rest; mat = List.map (push_generalized_decl_eqn pb.env i d) pb.mat } in let j = compile pb in - { uj_val = Term.mkLambda_or_LetIn d j.uj_val; - uj_type = Term.mkProd_wo_LetIn d j.uj_type } + { uj_val = mkLambda_or_LetIn d j.uj_val; + uj_type = mkProd_wo_LetIn d j.uj_type } (* spiwack: the [initial] argument keeps track whether the alias has been introduced by a toplevel branch ([true]) or a deep one @@ -1482,11 +1479,11 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = let j = compile pb in let sigma = !(pb.evdref) in { uj_val = - if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) (EConstr.of_constr j.uj_val) <= 1 then - EConstr.Unsafe.to_constr (subst1 c (EConstr.of_constr j.uj_val)) + if isRel sigma c || isVar sigma c || count_occurrences sigma (mkRel 1) j.uj_val <= 1 then + subst1 c j.uj_val else - EConstr.Unsafe.to_constr (mkLetIn (na,c,t,EConstr.of_constr j.uj_val)); - uj_type = EConstr.Unsafe.to_constr (subst1 c (EConstr.of_constr j.uj_type)) } in + mkLetIn (na,c,t,j.uj_val); + uj_type = subst1 c j.uj_type } in (* spiwack: when an alias appears on a deep branch, its non-expanded form is automatically a variable of the same name. We avoid introducing such superfluous aliases so that refines are elegant. *) @@ -1726,7 +1723,7 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = (t,tt) in let b = e_cumul env evdref tt (mkSort s) (* side effect *) in if not b then anomaly (Pp.str "Build_tycon: should be a type"); - { uj_val = EConstr.Unsafe.to_constr t; uj_type = EConstr.Unsafe.to_constr tt } + { uj_val = t; uj_type = tt } (* For a multiple pattern-matching problem Xi on t1..tn with return * type T, [build_inversion_problem Gamma Sigma (t1..tn) T] builds a return @@ -1851,7 +1848,7 @@ let build_inversion_problem loc env sigma tms t = caseloc = loc; casestyle = RegularStyle; typing_function = build_tycon loc env pb_env s subst} in - let pred = EConstr.of_constr (compile pb).uj_val in + let pred = (compile pb).uj_val in (!evdref,pred) (* Here, [pred] is assumed to be in the context built from all *) @@ -1905,7 +1902,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let inh_conv_coerce_to_tycon loc env evdref j tycon = match tycon with | Some p -> - let (evd',j) = Coercion.inh_conv_coerce_to true loc env !evdref j (EConstr.of_constr p) in + let (evd',j) = Coercion.inh_conv_coerce_to true loc env !evdref j p in evdref := evd'; j | None -> j @@ -2029,7 +2026,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let evdref = ref sigma in let predcclj = typing_fun (mk_tycon (EConstr.mkSort newt)) envar evdref rtntyp in let sigma = !evdref in - let predccl = EConstr.of_constr (j_nf_evar sigma predcclj).uj_val in + let predccl = EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr predcclj.uj_val)) in [sigma, predccl] in List.map @@ -2095,7 +2092,7 @@ let constr_of_pat env evdref arsign pat avoid = let IndType (indf, _) = try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env !evdref - {uj_val = EConstr.Unsafe.to_constr ty; uj_type = Typing.unsafe_type_of env !evdref ty} + {uj_val = ty; uj_type = EConstr.of_constr (Typing.unsafe_type_of env !evdref ty)} in let (ind,u), params = dest_ind_family indf in let params = List.map EConstr.of_constr params in @@ -2297,8 +2294,8 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = in let rhs_env = push_rel_context rhs_rels' env in let j = typing_fun (mk_tycon tycon) rhs_env eqn.rhs.it in - let bbody = it_mkLambda_or_LetIn (EConstr.of_constr j.uj_val) rhs_rels' - and btype = it_mkProd_or_LetIn (EConstr.of_constr j.uj_type) rhs_rels' in + let bbody = it_mkLambda_or_LetIn j.uj_val rhs_rels' + and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let _btype = evd_comb1 (Typing.type_of env) evdref bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in let branch_decl = local_def (Name branch_name, lift !i bbody, lift !i btype) in @@ -2554,10 +2551,10 @@ let compile_program_cases loc style (typing_function, evdref) tycon env let j = compile pb in (* We check for unused patterns *) List.iter (check_unused_pattern env) matx; - let body = it_mkLambda_or_LetIn (applist (EConstr.of_constr j.uj_val, args)) lets in + let body = it_mkLambda_or_LetIn (applist (j.uj_val, args)) lets in let j = - { uj_val = EConstr.Unsafe.to_constr (it_mkLambda_or_LetIn body tomatchs_lets); - uj_type = EConstr.to_constr !evdref tycon; } + { uj_val = it_mkLambda_or_LetIn body tomatchs_lets; + uj_type = EConstr.of_constr (EConstr.to_constr !evdref tycon); } in j (**************************************************************************) @@ -2632,7 +2629,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e let j = compile pb in (* We coerce to the tycon (if an elim predicate was provided) *) - let j = inh_conv_coerce_to_tycon loc env myevdref j (Option.map EConstr.Unsafe.to_constr tycon) in + let j = inh_conv_coerce_to_tycon loc env myevdref j tycon in evdref := !myevdref; j in diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 9016ca5f3f..9f26ae9ce2 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -8,9 +8,9 @@ open Names open Term -open EConstr open Evd open Environ +open EConstr open Inductiveops open Glob_term open Evarutil @@ -111,11 +111,11 @@ type 'a pattern_matching_problem = typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } -val compile : 'a pattern_matching_problem -> Environ.unsafe_judgment +val compile : 'a pattern_matching_problem -> unsafe_judgment val prepare_predicate : Loc.t -> (Evarutil.type_constraint -> - Environ.env -> Evd.evar_map ref -> 'a -> Environ.unsafe_judgment) -> + Environ.env -> Evd.evar_map ref -> 'a -> unsafe_judgment) -> Environ.env -> Evd.evar_map -> (types * tomatch_type) list -> diff --git a/pretyping/classops.ml b/pretyping/classops.ml index ad43bf3229..9011186a3d 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -319,7 +319,7 @@ let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; let subst, ctx = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c and t' = Vars.subst_univs_level_constr subst t in - (make_judge c' t', b, b'), ctx + (make_judge (EConstr.of_constr c') (EConstr.of_constr t'), b, b'), ctx (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 9fb70534fd..a1d030f125 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -8,9 +8,9 @@ open Names open Term +open Environ open EConstr open Evd -open Environ open Mod_subst (** {6 This is the type of class kinds } *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index b9f14aa43c..2d4296fe4f 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -53,16 +53,16 @@ let apply_coercion_args env evd check isproj argl funj = let rec apply_rec acc typ = function | [] -> if isproj then - let cst = fst (destConst !evdref (EConstr.of_constr (j_val funj))) in + let cst = fst (destConst !evdref (j_val funj)) in let p = Projection.make cst false in let pb = lookup_projection p env in let args = List.skipn pb.Declarations.proj_npars argl in let hd, tl = match args with hd :: tl -> hd, tl | [] -> assert false in - { uj_val = EConstr.Unsafe.to_constr (applist (mkProj (p, hd), tl)); - uj_type = EConstr.Unsafe.to_constr typ } + { uj_val = applist (mkProj (p, hd), tl); + uj_type = typ } else - { uj_val = EConstr.Unsafe.to_constr (applist (EConstr.of_constr (j_val funj),argl)); - uj_type = EConstr.Unsafe.to_constr typ } + { uj_val = applist (j_val funj,argl); + uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref typ)) with | Prod (_,c1,c2) -> @@ -71,7 +71,7 @@ let apply_coercion_args env evd check isproj argl funj = apply_rec (h::acc) (Vars.subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") in - let res = apply_rec [] (EConstr.of_constr funj.uj_type) argl in + let res = apply_rec [] funj.uj_type argl in !evdref, res (* appliquer le chemin de coercions de patterns p *) @@ -367,7 +367,7 @@ let apply_coercion env sigma p hj typ_cl = (fun (ja,typ_cl,sigma) i -> let ((fv,isid,isproj),ctx) = coercion_value i in let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - let argl = (class_args_of env sigma typ_cl)@[EConstr.of_constr ja.uj_val] in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in let sigma, jres = apply_coercion_args env sigma true isproj argl fv in @@ -375,7 +375,7 @@ let apply_coercion env sigma p hj typ_cl = { uj_val = ja.uj_val; uj_type = jres.uj_type } else jres), - EConstr.of_constr jres.uj_type,sigma) + jres.uj_type,sigma) (hj,typ_cl,sigma) p in evd, j with NoCoercion as e -> raise e @@ -383,23 +383,23 @@ let apply_coercion env sigma p hj typ_cl = (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core env evd j = - let t = whd_all env evd (EConstr.of_constr j.uj_type) in + let t = whd_all env evd j.uj_type in let t = EConstr.of_constr t in match EConstr.kind evd t with | Prod (_,_,_) -> (evd,j) | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product evd ev in - (evd',{ uj_val = j.uj_val; uj_type = EConstr.Unsafe.to_constr t }) + (evd',{ uj_val = j.uj_val; uj_type = t }) | _ -> try let t,p = - lookup_path_to_fun_from env evd (EConstr.of_constr j.uj_type) in + lookup_path_to_fun_from env evd j.uj_type in apply_coercion env evd p j t with Not_found | NoCoercion -> if Flags.is_program_mode () then try let evdref = ref evd in let coercef, t = mu env evdref t in - let res = { uj_val = EConstr.Unsafe.to_constr (app_opt env evdref coercef (EConstr.of_constr j.uj_val)); uj_type = EConstr.Unsafe.to_constr t } in + let res = { uj_val = app_opt env evdref coercef j.uj_val; uj_type = t } in (!evdref, res) with NoSubtacCoercion | NoCoercion -> (evd,j) @@ -415,17 +415,23 @@ let inh_app_fun resolve_tc env evd j = try inh_app_fun_core env (saturate_evd env evd) j with NoCoercion -> (evd, j) +let type_judgment env sigma j = + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma j.uj_type)) with + | Sort s -> {utj_val = j.uj_val; utj_type = s } + | _ -> error_not_a_type env sigma j + let inh_tosort_force loc env evd j = try - let t,p = lookup_path_to_sort_from env evd (EConstr.of_constr j.uj_type) in + let t,p = lookup_path_to_sort_from env evd j.uj_type in let evd,j1 = apply_coercion env evd p j t in + let whd_evar evd c = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr c)) in let j2 = on_judgment_type (whd_evar evd) j1 in - (evd,type_judgment env j2) + (evd,type_judgment env evd j2) with Not_found | NoCoercion -> error_not_a_type ~loc env evd j let inh_coerce_to_sort loc env evd j = - let typ = whd_all env evd (EConstr.of_constr j.uj_type) in + let typ = whd_all env evd j.uj_type in match EConstr.kind evd (EConstr.of_constr typ) with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) | Evar ev -> @@ -437,10 +443,10 @@ let inh_coerce_to_sort loc env evd j = let inh_coerce_to_base loc env evd j = if Flags.is_program_mode () then let evdref = ref evd in - let ct, typ' = mu env evdref (EConstr.of_constr j.uj_type) in + let ct, typ' = mu env evdref j.uj_type in let res = - { uj_val = EConstr.Unsafe.to_constr (app_coercion env evdref ct (EConstr.of_constr j.uj_val)); - uj_type = EConstr.Unsafe.to_constr typ' } + { uj_val = (app_coercion env evdref ct j.uj_val); + uj_type = typ' } in !evdref, res else (evd, j) @@ -463,8 +469,8 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = | Some v -> let evd,j = apply_coercion env evd p - {uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr t} t2 in - evd, Some (EConstr.of_constr j.uj_val), (EConstr.of_constr j.uj_type) + {uj_val = v; uj_type = t} t2 in + evd, Some j.uj_val, j.uj_type | None -> evd, None, t with Not_found -> raise NoCoercion in @@ -510,27 +516,27 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = let (evd', val') = try - inh_conv_coerce_to_fail loc env evd rigidonly (Some (EConstr.of_constr cj.uj_val)) (EConstr.of_constr cj.uj_type) t + inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> try if Flags.is_program_mode () then - coerce_itf loc env evd (Some (EConstr.of_constr cj.uj_val)) (EConstr.of_constr cj.uj_type) t + coerce_itf loc env evd (Some cj.uj_val) cj.uj_type t else raise NoSubtacCoercion with | NoSubtacCoercion when not resolve_tc || not !use_typeclasses_for_conversion -> - error_actual_type ~loc env best_failed_evd cj (EConstr.Unsafe.to_constr t) e + error_actual_type ~loc env best_failed_evd cj t e | NoSubtacCoercion -> let evd' = saturate_evd env evd in try if evd' == evd then - error_actual_type ~loc env best_failed_evd cj (EConstr.Unsafe.to_constr t) e + error_actual_type ~loc env best_failed_evd cj t e else - inh_conv_coerce_to_fail loc env evd' rigidonly (Some (EConstr.of_constr cj.uj_val)) (EConstr.of_constr cj.uj_type) t + inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (_evd,_error) -> - error_actual_type ~loc env best_failed_evd cj (EConstr.Unsafe.to_constr t) e + error_actual_type ~loc env best_failed_evd cj t e in let val' = match val' with Some v -> v | None -> assert(false) in - (evd',{ uj_val = EConstr.Unsafe.to_constr val'; uj_type = EConstr.Unsafe.to_constr t }) + (evd',{ uj_val = val'; uj_type = t }) let inh_conv_coerce_to resolve_tc = inh_conv_coerce_to_gen resolve_tc false let inh_conv_coerce_rigid_to resolve_tc = inh_conv_coerce_to_gen resolve_tc true diff --git a/pretyping/coercion.mli b/pretyping/coercion.mli index 62d4fb004d..bc63d092d9 100644 --- a/pretyping/coercion.mli +++ b/pretyping/coercion.mli @@ -10,6 +10,7 @@ open Evd open Names open Term open Environ +open EConstr open Glob_term (** {6 Coercions. } *) @@ -36,7 +37,7 @@ val inh_coerce_to_base : Loc.t -> (** [inh_coerce_to_prod env isevars t] coerces [t] to a product type *) val inh_coerce_to_prod : Loc.t -> - env -> evar_map -> EConstr.types -> evar_map * EConstr.types + env -> evar_map -> types -> evar_map * types (** [inh_conv_coerce_to resolve_tc Loc.t env isevars j t] coerces [j] to an object of type [t]; i.e. it inserts a coercion into [j], if needed, in such @@ -44,16 +45,16 @@ val inh_coerce_to_prod : Loc.t -> applicable. resolve_tc=false disables resolving type classes (as the last resort before failing) *) val inh_conv_coerce_to : bool -> Loc.t -> - env -> evar_map -> unsafe_judgment -> EConstr.types -> evar_map * unsafe_judgment + env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment val inh_conv_coerce_rigid_to : bool -> Loc.t -> - env -> evar_map -> unsafe_judgment -> EConstr.types -> evar_map * unsafe_judgment + env -> evar_map -> unsafe_judgment -> types -> evar_map * unsafe_judgment (** [inh_conv_coerces_to loc env isevars t t'] checks if an object of type [t] is coercible to an object of type [t'] adding evar constraints if needed; it fails if no coercion exists *) val inh_conv_coerces_to : Loc.t -> - env -> evar_map -> EConstr.types -> EConstr.types -> evar_map + env -> evar_map -> types -> types -> evar_map (** [inh_pattern_coerce_to loc env isevars pat ind1 ind2] coerces the Cases pattern [pat] typed in [ind1] into a pattern typed in [ind2]; diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3b420347b9..639d6260ea 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -1266,8 +1266,8 @@ let solve_unconstrained_impossible_cases env evd = let evd' = Evd.merge_context_set Evd.univ_flexible_alg ~loc evd' ctx in let ty = j_type j in let conv_algo = evar_conv_x full_transparent_state in - let evd' = check_evar_instance evd' evk (EConstr.of_constr ty) conv_algo in - Evd.define evk ty evd' + let evd' = check_evar_instance evd' evk ty conv_algo in + Evd.define evk (EConstr.Unsafe.to_constr ty) evd' | _ -> evd') evd evd let consider_remaining_unif_problems env diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 14b25ab368..6735540059 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -31,11 +31,13 @@ type position_reporting = (position * int) * EConstr.t type subterm_unification_error = bool * position_reporting * position_reporting * (EConstr.constr * EConstr.constr * unification_error) option +type type_error = (EConstr.constr, EConstr.types) ptype_error + type pretype_error = (* Old Case *) - | CantFindCaseType of constr + | CantFindCaseType of EConstr.constr (* Type inference unification *) - | ActualTypeNotCoercible of unsafe_judgment * types * unification_error + | ActualTypeNotCoercible of EConstr.unsafe_judgment * EConstr.types * unification_error (* Tactic unification *) | UnifOccurCheck of existential_key * EConstr.constr | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option @@ -50,7 +52,7 @@ type pretype_error = | NonLinearUnification of Name.t * EConstr.constr (* Pretyping *) | VarNotFound of Id.t - | UnexpectedType of constr * constr + | UnexpectedType of EConstr.constr * EConstr.constr | NotProduct of EConstr.constr | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error @@ -75,14 +77,19 @@ let error_actual_type ?loc env sigma {uj_val=c;uj_type=actty} expty reason = raise_pretype_error ?loc (env, sigma, ActualTypeNotCoercible (j, expty, reason)) +let error_actual_type_core ?loc env sigma {uj_val=c;uj_type=actty} expty = + let j = {uj_val=c;uj_type=actty} in + raise_type_error ?loc + (env, sigma, ActualType (j, expty)) + let error_cant_apply_not_functional ?loc env sigma rator randl = raise_type_error ?loc - (env, sigma, CantApplyNonFunctional (rator, Array.of_list randl)) + (env, sigma, CantApplyNonFunctional (rator, randl)) let error_cant_apply_bad_type ?loc env sigma (n,c,t) rator randl = raise_type_error ?loc (env, sigma, - CantApplyBadType ((n,c,t), rator, Array.of_list randl)) + CantApplyBadType ((n,c,t), rator, randl)) let error_ill_formed_branch ?loc env sigma c i actty expty = raise_type_error @@ -98,9 +105,16 @@ let error_ill_typed_rec_body ?loc env sigma i na jl tys = raise_type_error ?loc (env, sigma, IllTypedRecBody (i, na, jl, tys)) +let error_elim_arity ?loc env sigma pi s c j a = + raise_type_error ?loc + (env, sigma, ElimArity (pi, s, c, j, a)) + let error_not_a_type ?loc env sigma j = raise_type_error ?loc (env, sigma, NotAType j) +let error_assumption ?loc env sigma j = + raise_type_error ?loc (env, sigma, BadAssumption j) + (*s Implicit arguments synthesis errors. It is hard to find a precise location. *) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 2e707a0ffc..0ebe4817ca 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -32,11 +32,13 @@ type position_reporting = (position * int) * EConstr.t type subterm_unification_error = bool * position_reporting * position_reporting * (EConstr.constr * EConstr.constr * unification_error) option +type type_error = (EConstr.constr, EConstr.types) ptype_error + type pretype_error = (** Old Case *) - | CantFindCaseType of constr + | CantFindCaseType of EConstr.constr (** Type inference unification *) - | ActualTypeNotCoercible of unsafe_judgment * types * unification_error + | ActualTypeNotCoercible of EConstr.unsafe_judgment * EConstr.types * unification_error (** Tactic Unification *) | UnifOccurCheck of existential_key * EConstr.constr | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option @@ -51,7 +53,7 @@ type pretype_error = | NonLinearUnification of Name.t * EConstr.constr (** Pretyping *) | VarNotFound of Id.t - | UnexpectedType of constr * constr + | UnexpectedType of EConstr.constr * EConstr.constr | NotProduct of EConstr.constr | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error @@ -65,34 +67,45 @@ val precatchable_exception : exn -> bool (** Raising errors *) val error_actual_type : - ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> EConstr.constr -> unification_error -> 'b +val error_actual_type_core : + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> EConstr.constr -> 'b + val error_cant_apply_not_functional : ?loc:Loc.t -> env -> Evd.evar_map -> - unsafe_judgment -> unsafe_judgment list -> 'b + EConstr.unsafe_judgment -> EConstr.unsafe_judgment array -> 'b val error_cant_apply_bad_type : - ?loc:Loc.t -> env -> Evd.evar_map -> int * constr * constr -> - unsafe_judgment -> unsafe_judgment list -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> int * EConstr.constr * EConstr.constr -> + EConstr.unsafe_judgment -> EConstr.unsafe_judgment array -> 'b val error_case_not_inductive : - ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> 'b val error_ill_formed_branch : ?loc:Loc.t -> env -> Evd.evar_map -> - constr -> pconstructor -> constr -> constr -> 'b + EConstr.constr -> pconstructor -> EConstr.constr -> EConstr.constr -> 'b val error_number_branches : ?loc:Loc.t -> env -> Evd.evar_map -> - unsafe_judgment -> int -> 'b + EConstr.unsafe_judgment -> int -> 'b val error_ill_typed_rec_body : ?loc:Loc.t -> env -> Evd.evar_map -> - int -> Name.t array -> unsafe_judgment array -> types array -> 'b + int -> Name.t array -> EConstr.unsafe_judgment array -> EConstr.types array -> 'b + +val error_elim_arity : + ?loc:Loc.t -> env -> Evd.evar_map -> + pinductive -> sorts_family list -> EConstr.constr -> + EConstr.unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'b val error_not_a_type : - ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> 'b + +val error_assumption : + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> 'b val error_cannot_coerce : env -> Evd.evar_map -> EConstr.constr * EConstr.constr -> 'b @@ -124,12 +137,12 @@ val error_non_linear_unification : env -> Evd.evar_map -> (** {6 Ml Case errors } *) val error_cant_find_case_type : - ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.constr -> 'b (** {6 Pretyping errors } *) val error_unexpected_type : - ?loc:Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> 'b val error_not_product : ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.constr -> 'b diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index cac31a1c57..49a0bccee9 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -34,6 +34,7 @@ open Reductionops open Environ open Type_errors open Typeops +open Typing open Globnames open Nameops open Evarutil @@ -124,7 +125,7 @@ let e_new_evar env evdref ?src ?naming typ = let sigma = Sigma.Unsafe.of_evar_map !evdref in let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in evdref := Sigma.to_evar_map sigma; - e + EConstr.of_constr e let push_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> local_assum (na, lift i t)) lna typarray in @@ -425,21 +426,19 @@ let invert_ltac_bound_name lvar env id0 id = str " which is not bound in current context.") let protected_get_type_of env sigma c = - try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c + try EConstr.of_constr (Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c) with Retyping.RetypeError _ -> user_err (str "Cannot reinterpret " ++ quote (print_constr (EConstr.Unsafe.to_constr c)) ++ str " in the current environment.") -let j_val j = EConstr.of_constr (j_val j) - let pretype_id pretype k0 loc env evdref lvar id = let sigma = !evdref in (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in let typ = EConstr.of_constr typ in - { uj_val = EConstr.Unsafe.to_constr (mkRel n); uj_type = EConstr.Unsafe.to_constr (lift n typ) } + { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> let env = ltac_interp_name_env k0 lvar env in (* Check if [id] is an ltac variable *) @@ -447,7 +446,7 @@ let pretype_id pretype k0 loc env evdref lvar id = let (ids,c) = Id.Map.find id lvar.ltac_constrs in let subst = List.map (invert_ltac_bound_name lvar env id) ids in let c = substl subst (EConstr.of_constr c) in - { uj_val = EConstr.Unsafe.to_constr c; uj_type = protected_get_type_of env sigma c } + { uj_val = c; uj_type = protected_get_type_of env sigma c } with Not_found -> try let {closure;term} = Id.Map.find id lvar.ltac_uconstrs in let lvar = { @@ -472,7 +471,7 @@ let pretype_id pretype k0 loc env evdref lvar id = end; (* Check if [id] is a section or goal variable *) try - { uj_val = Constr.mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } + { uj_val = mkVar id; uj_type = EConstr.of_constr (NamedDecl.get_type (lookup_named id env)) } with Not_found -> (* [id] not found, standard error message *) error_var_not_found ~loc id @@ -511,9 +510,6 @@ let pretype_global loc rigid env evd gr us = let (sigma, c) = Evd.fresh_global ~loc ~rigid ?names:instance env.ExtraEnv.env evd gr in (sigma, EConstr.of_constr c) -let make_judge c t = - make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr t) - let pretype_ref loc evdref env ref us = match ref with | VarRef id -> @@ -527,14 +523,14 @@ let pretype_ref loc evdref env ref us = | ref -> let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in - let ty = Typing.unsafe_type_of env.ExtraEnv.env evd c in + let ty = unsafe_type_of env.ExtraEnv.env evd c in let ty = EConstr.of_constr ty in make_judge c ty let judge_of_Type loc evd s = let evd, s = interp_universe ~loc evd s in let judge = - { uj_val = Constr.mkSort (Type s); uj_type = Constr.mkSort (Type (Univ.super s)) } + { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } in evd, judge @@ -550,7 +546,7 @@ let new_type_evar env evdref loc = univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) in evdref := Sigma.to_evar_map sigma; - e + EConstr.of_constr e let (f_genarg_interp, genarg_interp_hook) = Hook.make () @@ -591,25 +587,25 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with - | Some ty -> EConstr.Unsafe.to_constr ty + | Some ty -> ty | None -> new_type_evar env evdref loc in let k = Evar_kinds.MatchingVar (someta,n) in - { uj_val = e_new_evar env evdref ~src:(loc,k) (EConstr.of_constr ty); uj_type = ty } + { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } | GHole (loc, k, naming, None) -> let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with - | Some ty -> EConstr.Unsafe.to_constr ty + | Some ty -> ty | None -> new_type_evar env evdref loc in - { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming (EConstr.of_constr ty); uj_type = ty } + { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty } | GHole (loc, k, _naming, Some arg) -> let env = ltac_interp_name_env k0 lvar env in let ty = match tycon with - | Some ty -> EConstr.Unsafe.to_constr ty + | Some ty -> ty | None -> new_type_evar env evdref loc in let ist = lvar.ltac_genargs in @@ -622,14 +618,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre [] -> ctxt | (na,bk,None,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = LocalAssum (na, ty'.utj_val) in - let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in + let dcl = local_assum (na, ty'.utj_val) in + let dcl' = local_assum (ltac_interp_name lvar na,ty'.utj_val) in type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in - let bd' = pretype (mk_tycon (EConstr.of_constr ty'.utj_val)) env evdref lvar bd in - let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in - let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in + let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in + let dcl = local_def (na, bd'.uj_val, ty'.utj_val) in + let dcl' = local_def (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in let larj = @@ -637,8 +633,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (fun e ar -> pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) ctxtv lar in - let lara = Array.map (fun a -> EConstr.of_constr a.utj_val) larj in - let ftys = Array.map2 (fun e a -> EConstr.it_mkProd_or_LetIn a e) ctxtv lara in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in let nbfix = Array.length lar in let names = Array.map (fun id -> Name id) names in let _ = @@ -662,8 +658,8 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (lift nbfix ftys.(i)) in let nenv = push_rel_context ctxt newenv in let j = pretype (mk_tycon ty) nenv evdref lvar def in - { uj_val = Termops.it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = Termops.it_mkProd_or_LetIn j.uj_type ctxt }) + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) ctxtv vdef in Typing.check_type_fixpoint loc env.ExtraEnv.env evdref names ftys vdefj; let nf c = nf_evar !evdref c in @@ -714,11 +710,11 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct !evdref (EConstr.of_constr fj.uj_val) then + if Flags.is_program_mode () && length > 0 && isConstruct !evdref fj.uj_val then match tycon with | None -> [] | Some ty -> - let ((ind, i), u) = destConstruct !evdref (EConstr.of_constr fj.uj_val) in + let ((ind, i), u) = destConstruct !evdref fj.uj_val in let npars = inductive_nparams ind in if Int.equal npars 0 then [] else @@ -731,7 +727,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre else [] in let app_f = - match EConstr.kind !evdref (EConstr.of_constr fj.uj_val) with + match EConstr.kind !evdref fj.uj_val with | Const (p, u) when Environ.is_projection p env.ExtraEnv.env -> let p = Projection.make p false in let pb = Environ.lookup_projection p env.ExtraEnv.env in @@ -746,7 +742,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | c::rest -> let argloc = loc_of_glob_constr c in let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in - let resty = whd_all env.ExtraEnv.env !evdref (EConstr.of_constr resj.uj_type) in + let resty = whd_all env.ExtraEnv.env !evdref resj.uj_type in let resty = EConstr.of_constr resty in match EConstr.kind !evdref resty with | Prod (na,c1,c2) -> @@ -761,18 +757,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre else [], j_val hj in let value, typ = app_f n (j_val resj) ujval, subst1 ujval c2 in - let j = { uj_val = EConstr.Unsafe.to_constr value; uj_type = EConstr.Unsafe.to_constr typ } in + let j = { uj_val = value; uj_type = typ } in apply_rec env (n+1) j candargs rest | _ -> let hj = pretype empty_tycon env evdref lvar c in error_cant_apply_not_functional ~loc:(Loc.merge floc argloc) env.ExtraEnv.env !evdref - resj [hj] + resj [|hj|] in let resj = apply_rec env 1 fj candargs args in let resj = - match EConstr.kind !evdref (EConstr.of_constr resj.uj_val) with + match EConstr.kind !evdref resj.uj_val with | App (f,args) -> if is_template_polymorphic env.ExtraEnv.env !evdref f then (* Special case for inductive type applications that must be @@ -804,7 +800,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let var = LocalAssum (name, j.utj_val) in + let var = local_assum (name, j.utj_val) in let j' = pretype rng (push_rel var env) evdref lvar c2 in let name = ltac_interp_name lvar name in let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in @@ -818,9 +814,9 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let j' = match name with | Anonymous -> let j = pretype_type empty_valcon env evdref lvar c2 in - { j with utj_val = EConstr.Unsafe.to_constr (lift 1 (EConstr.of_constr j.utj_val)) } + { j with utj_val = lift 1 j.utj_val } | Name _ -> - let var = LocalAssum (name, j.utj_val) in + let var = local_assum (name, j.utj_val) in let env' = push_rel var env in pretype_type empty_valcon env' evdref lvar c2 in @@ -839,27 +835,27 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre match c1 with | GCast (loc, c, CastConv t) -> let tj = pretype_type empty_valcon env evdref lvar t in - pretype (mk_tycon (EConstr.of_constr tj.utj_val)) env evdref lvar c + pretype (mk_tycon tj.utj_val) env evdref lvar c | _ -> pretype empty_tycon env evdref lvar c1 in let t = evd_comb1 (Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) - evdref (EConstr.of_constr j.uj_type) in + evdref j.uj_type in + let t = EConstr.of_constr t in (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let var = LocalDef (name, j.uj_val, t) in - let t = EConstr.of_constr t in + let var = local_def (name, j.uj_val, t) in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in let name = ltac_interp_name lvar name in - { uj_val = EConstr.Unsafe.to_constr (mkLetIn (name, EConstr.of_constr j.uj_val, t, EConstr.of_constr j'.uj_val)) ; - uj_type = EConstr.Unsafe.to_constr (subst1 (EConstr.of_constr j.uj_val) (EConstr.of_constr j'.uj_type)) } + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (loc,nal,(na,po),c,d) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = - try find_rectype env.ExtraEnv.env !evdref (EConstr.of_constr cj.uj_type) + try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj @@ -883,7 +879,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | na :: names, (LocalAssum (_,t) :: l) -> let t = EConstr.of_constr t in let proj = Projection.make ps.(cs.cs_nargs - k) true in - local_def (na, lift (cs.cs_nargs - n) (mkProj (proj, EConstr.of_constr cj.uj_val)), t) + local_def (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) :: aux (n+1) (k + 1) names l | na :: names, (decl :: l) -> set_name na decl :: aux (n+1) k names l @@ -897,7 +893,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let fsign = List.map2 set_name nal fsign in let f = it_mkLambda_or_LetIn f fsign in let ci = make_case_info env.ExtraEnv.env (fst ind) LetStyle in - mkCase (ci, p, EConstr.of_constr cj.uj_val,[|f|]) + mkCase (ci, p, cj.uj_val,[|f|]) else it_mkLambda_or_LetIn f fsign in let env_f = push_rel_context fsign env in @@ -914,7 +910,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | Some p -> let env_p = push_rel_context psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref (EConstr.of_constr pj.utj_val) in + let ccl = nf_evar !evdref pj.utj_val in let psign = make_arity_signature env.ExtraEnv.env true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in let inst = @@ -922,18 +918,19 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist env.ExtraEnv.env !evdref lp inst in - let fj = pretype (mk_tycon (EConstr.of_constr fty)) env_f evdref lvar d in + let fty = EConstr.of_constr fty in + let fj = pretype (mk_tycon fty) env_f evdref lvar d in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) p; - obj ind p cj.uj_val (EConstr.of_constr fj.uj_val) + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; + obj ind p cj.uj_val fj.uj_val in - { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr (substl (realargs@[EConstr.of_constr cj.uj_val]) ccl) } + { uj_val = v; uj_type = (substl (realargs@[cj.uj_val]) ccl) } | None -> let tycon = lift_tycon cs.cs_nargs tycon in let fj = pretype tycon env_f evdref lvar d in - let ccl = nf_evar !evdref (EConstr.of_constr fj.uj_type) in + let ccl = nf_evar !evdref fj.uj_type in let ccl = if noccur_between !evdref 1 cs.cs_nargs ccl then lift (- cs.cs_nargs) ccl @@ -944,14 +941,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in let v = let ind,_ = dest_ind_family indf in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) p; - obj ind p cj.uj_val (EConstr.of_constr fj.uj_val) - in { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr ccl }) + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val p; + obj ind p cj.uj_val fj.uj_val + in { uj_val = v; uj_type = ccl }) | GIf (loc,c,(na,po),b1,b2) -> let cj = pretype empty_tycon env evdref lvar c in let (IndType (indf,realargs)) = - try find_rectype env.ExtraEnv.env !evdref (EConstr.of_constr cj.uj_type) + try find_rectype env.ExtraEnv.env !evdref cj.uj_type with Not_found -> let cloc = loc_of_glob_constr c in error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in @@ -973,16 +970,16 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | Some p -> let env_p = push_rel_context psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref (EConstr.of_constr pj.utj_val) in + let ccl = nf_evar !evdref pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (EConstr.of_constr (beta_applist !evdref (pred,[EConstr.of_constr cj.uj_val]))) in + let typ = lift (- nar) (EConstr.of_constr (beta_applist !evdref (pred,[cj.uj_val]))) in pred, typ | None -> let p = match tycon with | Some ty -> ty | None -> let env = ltac_interp_name_env k0 lvar env in - EConstr.of_constr (new_type_evar env evdref loc) + new_type_evar env evdref loc in it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in let pred = nf_evar !evdref pred in @@ -991,6 +988,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in + let pi = EConstr.of_constr pi in let csgn = if not !allow_anonymous_refs then List.map (set_name Anonymous) cs.cs_args @@ -1000,18 +998,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre cs.cs_args in let env_c = push_rel_context csgn env in - let bj = pretype (mk_tycon (EConstr.of_constr pi)) env_c evdref lvar b in - it_mkLambda_or_LetIn (EConstr.of_constr bj.uj_val) cs.cs_args in + let bj = pretype (mk_tycon pi) env_c evdref lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in let b1 = f cstrs.(0) b1 in let b2 = f cstrs.(1) b2 in let v = let ind,_ = dest_ind_family indf in let ci = make_case_info env.ExtraEnv.env (fst ind) IfStyle in let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env.ExtraEnv.env !evdref ind (EConstr.of_constr cj.uj_val) pred; - mkCase (ci, pred, EConstr.of_constr cj.uj_val, [|b1;b2|]) + Typing.check_allowed_sort env.ExtraEnv.env !evdref ind cj.uj_val pred; + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) in - let cj = { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr p } in + let cj = { uj_val = v; uj_type = p } in inh_conv_coerce_to_tycon loc env evdref cj tycon | GCases (loc,sty,po,tml,eqns) -> @@ -1030,36 +1028,36 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let tj = pretype_type empty_valcon env evdref lvar t in let tval = evd_comb1 (Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) - evdref (EConstr.of_constr tj.utj_val) in + evdref tj.utj_val in let tval = EConstr.of_constr tval in let tval = nf_evar !evdref tval in let cj, tval = match k with | VMcast -> let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref (EConstr.of_constr cj.uj_type) and tval = nf_evar !evdref tval in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in if not (occur_existential !evdref cty || occur_existential !evdref tval) then let (evd,b) = Reductionops.vm_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type ~loc env.ExtraEnv.env !evdref cj (EConstr.Unsafe.to_constr tval) + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) else user_err ~loc (str "Cannot check cast with vm: " ++ str "unresolved arguments remain.") | NATIVEcast -> let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref (EConstr.of_constr cj.uj_type) and tval = nf_evar !evdref tval in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tval in begin let (evd,b) = Nativenorm.native_infer_conv env.ExtraEnv.env !evdref cty tval in if b then (evdref := evd; cj, tval) else - error_actual_type ~loc env.ExtraEnv.env !evdref cj (EConstr.Unsafe.to_constr tval) + error_actual_type ~loc env.ExtraEnv.env !evdref cj tval (ConversionFailed (env.ExtraEnv.env,cty,tval)) end | _ -> pretype (mk_tycon tval) env evdref lvar c, tval in - let v = mkCast (EConstr.of_constr cj.uj_val, k, tval) in - { uj_val = EConstr.Unsafe.to_constr v; uj_type = EConstr.Unsafe.to_constr tval } + let v = mkCast (cj.uj_val, k, tval) in + { uj_val = v; uj_type = tval } in inh_conv_coerce_to_tycon loc env evdref cj tycon and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = @@ -1070,7 +1068,7 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = try let c = List.assoc id update in let c = pretype k0 resolve_tc (mk_tycon t) env evdref lvar c in - EConstr.of_constr c.uj_val, List.remove_assoc id update + c.uj_val, List.remove_assoc id update with Not_found -> try let (n,_,t') = lookup_rel_id id (rel_context env) in @@ -1103,13 +1101,14 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let s = let sigma = !evdref in let t = Retyping.get_type_of env.ExtraEnv.env sigma v in - match EConstr.kind sigma (EConstr.of_constr (whd_all env.ExtraEnv.env sigma (EConstr.of_constr t))) with + let t = EConstr.of_constr t in + match EConstr.kind sigma (EConstr.of_constr (whd_all env.ExtraEnv.env sigma t)) with | Sort s -> s | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type") in - { utj_val = EConstr.Unsafe.to_constr v; + { utj_val = v; utj_type = s } | None -> let env = ltac_interp_name_env k0 lvar env in @@ -1123,10 +1122,10 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function match valcon with | None -> tj | Some v -> - if e_cumul env.ExtraEnv.env evdref v (EConstr.of_constr tj.utj_val) then tj + if e_cumul env.ExtraEnv.env evdref v tj.utj_val then tj else error_unexpected_type - ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val (EConstr.Unsafe.to_constr v) + ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v let ise_pretype_gen flags env sigma lvar kind c = let env = make_env env in @@ -1140,7 +1139,7 @@ let ise_pretype_gen flags env sigma lvar kind c = | IsType -> (pretype_type k0 flags.use_typeclasses empty_valcon env evdref lvar c).utj_val in - process_inference_flags flags env.ExtraEnv.env sigma (!evdref,EConstr.of_constr c') + process_inference_flags flags env.ExtraEnv.env sigma (!evdref,c') let default_inference_flags fail = { use_typeclasses = true; @@ -1167,9 +1166,9 @@ let empty_lvar : ltac_var_map = { } let on_judgment sigma f j = - let c = mkCast(EConstr.of_constr j.uj_val,DEFAULTcast, EConstr.of_constr j.uj_type) in + let c = mkCast(j.uj_val,DEFAULTcast, j.uj_type) in let (c,_,t) = destCast sigma (f c) in - {uj_val = EConstr.Unsafe.to_constr c; uj_type = EConstr.Unsafe.to_constr t} + {uj_val = c; uj_type = t} let understand_judgment env sigma c = let env = make_env env in diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 603b9f9ea8..2f3ce3afac 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -110,11 +110,11 @@ val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> (** Idem but returns the judgment of the understood term *) val understand_judgment : env -> evar_map -> - glob_constr -> unsafe_judgment Evd.in_evar_universe_context + glob_constr -> EConstr.unsafe_judgment Evd.in_evar_universe_context (** Idem but do not fail on unresolved evars (type cl*) val understand_judgment_tcc : env -> evar_map ref -> - glob_constr -> unsafe_judgment + glob_constr -> EConstr.unsafe_judgment val type_uconstr : ?flags:inference_flags -> @@ -145,11 +145,11 @@ val check_evars : env -> evar_map -> evar_map -> EConstr.constr -> unit (** Internal of Pretyping... *) val pretype : int -> bool -> type_constraint -> env -> evar_map ref -> - ltac_var_map -> glob_constr -> unsafe_judgment + ltac_var_map -> glob_constr -> EConstr.unsafe_judgment val pretype_type : int -> bool -> val_constraint -> env -> evar_map ref -> - ltac_var_map -> glob_constr -> unsafe_type_judgment + ltac_var_map -> glob_constr -> EConstr.unsafe_type_judgment val ise_pretype_gen : inference_flags -> env -> evar_map -> @@ -163,5 +163,5 @@ val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : - (types -> env -> evar_map -> unbound_ltac_var_map -> - Genarg.glob_generic_argument -> constr * evar_map) Hook.t + (EConstr.types -> env -> evar_map -> unbound_ltac_var_map -> + Genarg.glob_generic_argument -> EConstr.constr * evar_map) Hook.t diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 2efb024176..a7ccf98a66 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -244,7 +244,7 @@ let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = if lax then EConstr.Unsafe.to_constr (f env c) else EConstr.Unsafe.to_constr (anomaly_on_error (f env) c) (* Makes an unsafe judgment from a constr *) -let get_judgment_of env evc c = { uj_val = EConstr.Unsafe.to_constr c; uj_type = get_type_of env evc c } +let get_judgment_of env evc c = { uj_val = c; uj_type = EConstr.of_constr (get_type_of env evc c) } (* Returns sorts of a context *) let sorts_of_context env evc ctxt = diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index 08f7502878..c844038904 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -35,7 +35,7 @@ val get_sort_family_of : ?polyprop:bool -> env -> evar_map -> EConstr.types -> sorts_family (** Makes an unsafe judgment from a constr *) -val get_judgment_of : env -> evar_map -> EConstr.constr -> unsafe_judgment +val get_judgment_of : env -> evar_map -> EConstr.constr -> EConstr.unsafe_judgment val type_of_global_reference_knowing_parameters : env -> evar_map -> EConstr.constr -> EConstr.constr array -> types diff --git a/pretyping/typing.ml b/pretyping/typing.ml index c948f9b9a7..17adea5f2c 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -6,20 +6,31 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open Pp open CErrors open Util open Term +open EConstr open Vars open Environ open Reductionops -open Type_errors open Inductive open Inductiveops open Typeops open Arguments_renaming +open Pretype_errors open Context.Rel.Declaration +let local_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + let push_rec_types pfix env = let (i, c, t) = pfix in let inj c = EConstr.Unsafe.to_constr c in @@ -31,57 +42,57 @@ let meta_type evd mv = with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv)) in meta_instance evd ty -let constant_type_knowing_parameters env cst jl = - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in +let constant_type_knowing_parameters env sigma cst jl = + let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr sigma j.uj_type)) jl in EConstr.of_constr (type_of_constant_knowing_parameters_in env cst paramstyp) -let inductive_type_knowing_parameters env (ind,u) jl = +let inductive_type_knowing_parameters env sigma (ind,u) jl = let mspec = lookup_mind_specif env ind in - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in + let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr sigma j.uj_type)) jl in EConstr.of_constr (Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp) let e_type_judgment env evdref j = - match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref (EConstr.of_constr j.uj_type))) with + match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref j.uj_type)) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | Evar ev -> let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in evdref := evd; { utj_val = j.uj_val; utj_type = s } - | _ -> error_not_type env j + | _ -> error_not_a_type env !evdref j let e_assumption_of_judgment env evdref j = - try EConstr.of_constr (e_type_judgment env evdref j).utj_val - with TypeError _ -> - error_assumption env j + try (e_type_judgment env evdref j).utj_val + with Type_errors.TypeError _ | PretypeError _ -> + error_assumption env !evdref j let e_judge_of_apply env evdref funj argjv = let open EConstr in let rec apply_rec n typ = function | [] -> - { uj_val = Constr.mkApp (j_val funj, Array.map j_val argjv); - uj_type = EConstr.Unsafe.to_constr typ } + { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = typ } | hj::restjl -> match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref typ)) with | Prod (_,c1,c2) -> - if Evarconv.e_cumul env evdref (EConstr.of_constr hj.uj_type) c1 then - apply_rec (n+1) (Vars.subst1 (EConstr.of_constr hj.uj_val) c2) restjl + if Evarconv.e_cumul env evdref hj.uj_type c1 then + apply_rec (n+1) (subst1 hj.uj_val c2) restjl else - error_cant_apply_bad_type env (n, EConstr.Unsafe.to_constr c1, hj.uj_type) funj argjv + error_cant_apply_bad_type env !evdref (n, c1, hj.uj_type) funj argjv | Evar ev -> let (evd',t) = Evardefine.define_evar_as_product !evdref ev in evdref := evd'; let (_,_,c2) = destProd evd' t in - apply_rec (n+1) (Vars.subst1 (EConstr.of_constr hj.uj_val) c2) restjl + apply_rec (n+1) (subst1 hj.uj_val c2) restjl | _ -> - error_cant_apply_not_functional env funj argjv + error_cant_apply_not_functional env !evdref funj argjv in - apply_rec 1 (EConstr.of_constr funj.uj_type) (Array.to_list argjv) + apply_rec 1 funj.uj_type (Array.to_list argjv) let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then - error_number_branches env cj (Array.length explft); + error_number_branches env !evdref cj (Array.length explft); for i = 0 to Array.length explft - 1 do - if not (Evarconv.e_cumul env evdref (EConstr.of_constr lfj.(i).uj_type) (EConstr.of_constr explft.(i))) then - error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) + if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then + error_ill_formed_branch env !evdref cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) done let max_sort l = @@ -92,13 +103,13 @@ let e_is_correct_arity env evdref c pj ind specif params = let open EConstr in let arsign = make_arity_signature env true (make_ind_family (ind,params)) in let allowed_sorts = elim_sorts specif in - let error () = error_elim_arity env ind allowed_sorts c pj None in + let error () = Pretype_errors.error_elim_arity env !evdref ind allowed_sorts c pj None in let rec srec env pt ar = let pt' = EConstr.of_constr (whd_all env !evdref pt) in match EConstr.kind !evdref pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> if not (Evarconv.e_cumul env evdref a1 (EConstr.of_constr a1')) then error (); - srec (push_rel (LocalAssum (na1,EConstr.Unsafe.to_constr a1)) env) t ar' + srec (push_rel (local_assum (na1,a1)) env) t ar' | Sort s, [] -> if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () @@ -106,27 +117,43 @@ let e_is_correct_arity env evdref c pj ind specif params = let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in evdref := Evd.define ev (Constr.mkSort s) evd | _, (LocalDef _ as d)::ar' -> - srec (push_rel d env) (Vars.lift 1 pt') ar' + srec (push_rel d env) (lift 1 pt') ar' | _ -> error () in - srec env (EConstr.of_constr pj.uj_type) (List.rev arsign) + srec env pj.uj_type (List.rev arsign) + +let lambda_applist_assum sigma n c l = + let open EConstr in + let rec app n subst t l = + if Int.equal n 0 then + if l == [] then substl subst t + else anomaly (Pp.str "Not enough arguments") + else match EConstr.kind sigma t, l with + | Lambda(_,_,c), arg::l -> app (n-1) (arg::subst) c l + | LetIn(_,b,_,c), _ -> app (n-1) (substl subst b::subst) c l + | _ -> anomaly (Pp.str "Not enough lambda/let's") in + app n [] c l let e_type_case_branches env evdref (ind,largs) pj c = let specif = lookup_mind_specif env (fst ind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in + let realargs = List.map EConstr.of_constr realargs in let () = e_is_correct_arity env evdref c pj ind specif params in - let lc = build_branches_type ind specif params p in + let lc = build_branches_type ind specif params (EConstr.to_constr !evdref p) in + let lc = Array.map EConstr.of_constr lc in let n = (snd specif).Declarations.mind_nrealdecls in - let ty = whd_betaiota !evdref (EConstr.of_constr (lambda_applist_assum (n+1) p (realargs@[c]))) in + let ty = whd_betaiota !evdref (lambda_applist_assum !evdref (n+1) p (realargs@[c])) in + let ty = EConstr.of_constr ty in (lc, ty) let e_judge_of_case env evdref ci pj cj lfj = + let open EConstr in let indspec = - try find_mrectype env !evdref (EConstr.of_constr cj.uj_type) - with Not_found -> error_case_not_inductive env cj in + try find_mrectype env !evdref cj.uj_type + with Not_found -> error_case_not_inductive env !evdref cj in let _ = check_case_info env (fst indspec) ci in let (bty,rslty) = e_type_case_branches env evdref indspec pj cj.uj_val in e_check_branch_types env evdref (fst indspec) cj (lfj,bty); @@ -138,27 +165,28 @@ let check_type_fixpoint loc env evdref lna lar vdefj = let lt = Array.length vdefj in if Int.equal (Array.length lar) lt then for i = 0 to lt-1 do - if not (Evarconv.e_cumul env evdref (EConstr.of_constr (vdefj.(i)).uj_type) - (Vars.lift lt lar.(i))) then - Pretype_errors.error_ill_typed_rec_body ~loc env !evdref - i lna vdefj (Array.map EConstr.Unsafe.to_constr lar) + if not (Evarconv.e_cumul env evdref (vdefj.(i)).uj_type + (lift lt lar.(i))) then + error_ill_typed_rec_body ~loc env !evdref + i lna vdefj lar done (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in - let ksort = family_of_sort (sort_of_arity env sigma (EConstr.of_constr pj.uj_type)) in + let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in - error_elim_arity env ind sorts (EConstr.Unsafe.to_constr c) pj - (Some(ksort,s,error_elim_explain ksort s)) + error_elim_arity env sigma ind sorts c pj + (Some(ksort,s,Type_errors.error_elim_explain ksort s)) let e_judge_of_cast env evdref cj k tj = + let open EConstr in let expected_type = tj.utj_val in - if not (Evarconv.e_cumul env evdref (EConstr.of_constr cj.uj_type) (EConstr.of_constr expected_type)) then - error_actual_type env cj expected_type; + if not (Evarconv.e_cumul env evdref cj.uj_type expected_type) then + error_actual_type_core env !evdref cj expected_type; { uj_val = mkCast (cj.uj_val, k, expected_type); uj_type = expected_type } @@ -178,11 +206,56 @@ let check_cofix env sigma pcofix = let (idx, (ids, cs, ts)) = pcofix in check_cofix env (idx, (ids, Array.map inj cs, Array.map inj ts)) -let make_judge c ty = - make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr ty) - (* The typing machine with universes and existential variables. *) +let judge_of_prop = + { uj_val = EConstr.mkProp; + uj_type = EConstr.mkSort type1_sort } + +let judge_of_set = + { uj_val = EConstr.mkSet; + uj_type = EConstr.mkSort type1_sort } + +let judge_of_prop_contents = function + | Null -> judge_of_prop + | Pos -> judge_of_set + +let judge_of_type u = + let uu = Univ.Universe.super u in + { uj_val = EConstr.mkType u; + uj_type = EConstr.mkType uu } + +let judge_of_relative env v = + Termops.on_judgment EConstr.of_constr (judge_of_relative env v) + +let judge_of_variable env id = + Termops.on_judgment EConstr.of_constr (judge_of_variable env id) + +let judge_of_projection env sigma p cj = + let pb = lookup_projection p env in + let (ind,u), args = + try find_mrectype env sigma cj.uj_type + with Not_found -> error_case_not_inductive env sigma cj + in + let args = List.map EConstr.of_constr args in + let ty = EConstr.of_constr (CVars.subst_instance_constr u pb.Declarations.proj_type) in + let ty = substl (cj.uj_val :: List.rev args) ty in + {uj_val = EConstr.mkProj (p,cj.uj_val); + uj_type = ty} + +let judge_of_abstraction env name var j = + { uj_val = mkLambda (name, var.utj_val, j.uj_val); + uj_type = mkProd (name, var.utj_val, j.uj_type) } + +let judge_of_product env name t1 t2 = + let s = sort_of_product env t1.utj_type t2.utj_type in + { uj_val = mkProd (name, t1.utj_val, t2.utj_val); + uj_type = mkSort s } + +let judge_of_letin env name defj typj j = + { uj_val = mkLetIn (name, defj.uj_val, typj.utj_val, j.uj_val) ; + uj_type = subst1 defj.uj_val j.uj_type } + (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env evdref cstr = @@ -190,13 +263,13 @@ let rec execute env evdref cstr = let cstr = EConstr.of_constr (whd_evar !evdref (EConstr.Unsafe.to_constr cstr)) in match EConstr.kind !evdref cstr with | Meta n -> - { uj_val = EConstr.Unsafe.to_constr cstr; uj_type = meta_type !evdref n } + { uj_val = cstr; uj_type = EConstr.of_constr (meta_type !evdref n) } | Evar ev -> let ty = EConstr.existential_type !evdref ev in let jty = execute env evdref ty in let jty = e_assumption_of_judgment env evdref jty in - { uj_val = EConstr.Unsafe.to_constr cstr; uj_type = EConstr.Unsafe.to_constr jty } + { uj_val = cstr; uj_type = jty } | Rel n -> judge_of_relative env n @@ -239,7 +312,7 @@ let rec execute env evdref cstr = | Proj (p, c) -> let cj = execute env evdref c in - judge_of_projection env p (Evarutil.j_nf_evar !evdref cj) + judge_of_projection env !evdref p cj | App (f,args) -> let jl = execute_array env evdref args in @@ -248,13 +321,11 @@ let rec execute env evdref cstr = | Ind ind when Environ.template_polymorphic_pind ind env -> (* Sort-polymorphism of inductive types *) make_judge f - (inductive_type_knowing_parameters env ind - (Evarutil.jv_nf_evar !evdref jl)) + (inductive_type_knowing_parameters env !evdref ind jl) | Const cst when Environ.template_polymorphic_pconstant cst env -> (* Sort-polymorphism of inductive types *) make_judge f - (constant_type_knowing_parameters env cst - (Evarutil.jv_nf_evar !evdref jl)) + (constant_type_knowing_parameters env !evdref cst jl) | _ -> execute env evdref f in @@ -263,14 +334,14 @@ let rec execute env evdref cstr = | Lambda (name,c1,c2) -> let j = execute env evdref c1 in let var = e_type_judgment env evdref j in - let env1 = push_rel (LocalAssum (name, var.utj_val)) env in + let env1 = push_rel (local_assum (name, var.utj_val)) env in let j' = execute env1 evdref c2 in judge_of_abstraction env1 name var j' | Prod (name,c1,c2) -> let j = execute env evdref c1 in let varj = e_type_judgment env evdref j in - let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in + let env1 = push_rel (local_assum (name, varj.utj_val)) env in let j' = execute env1 evdref c2 in let varj' = e_type_judgment env1 evdref j' in judge_of_product env name varj varj' @@ -280,7 +351,7 @@ let rec execute env evdref cstr = let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in - let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in + let env1 = push_rel (local_def (name, j1.uj_val, j2.utj_val)) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 @@ -295,7 +366,7 @@ and execute_recdef env evdref (names,lar,vdef) = let lara = Array.map (e_assumption_of_judgment env evdref) larj in let env1 = push_rec_types (names,lara,vdef) env in let vdefj = execute_array env1 evdref vdef in - let vdefv = Array.map (j_val %> EConstr.of_constr) vdefj in + let vdefv = Array.map j_val vdefj in let _ = check_type_fixpoint Loc.ghost env1 evdref names lara vdefj in (names,lara,vdefv) @@ -304,8 +375,8 @@ and execute_array env evdref = Array.map (execute env evdref) let e_check env evdref c t = let env = enrich_env env evdref in let j = execute env evdref c in - if not (Evarconv.e_cumul env evdref (EConstr.of_constr j.uj_type) t) then - error_actual_type env j (EConstr.to_constr !evdref t) + if not (Evarconv.e_cumul env evdref j.uj_type t) then + error_actual_type_core env !evdref j t (* Type of a constr *) @@ -313,7 +384,7 @@ let unsafe_type_of env evd c = let evdref = ref evd in let env = enrich_env env evdref in let j = execute env evdref c in - j.uj_type + EConstr.Unsafe.to_constr j.uj_type (* Sort of a type *) @@ -331,23 +402,23 @@ let type_of ?(refresh=false) env evd c = let j = execute env evdref c in (* side-effect on evdref *) if refresh then - Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref (EConstr.of_constr j.uj_type) - else !evdref, j.uj_type + Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type + else !evdref, EConstr.Unsafe.to_constr j.uj_type let e_type_of ?(refresh=false) env evdref c = let env = enrich_env env evdref in let j = execute env evdref c in (* side-effect on evdref *) if refresh then - let evd, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref (EConstr.of_constr j.uj_type) in + let evd, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type in let () = evdref := evd in c - else j.uj_type + else EConstr.Unsafe.to_constr j.uj_type let e_solve_evars env evdref c = let env = enrich_env env evdref in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) - nf_evar !evdref c + nf_evar !evdref (EConstr.Unsafe.to_constr c) let _ = Evarconv.set_solve_evars (fun env evdref c -> EConstr.of_constr (e_solve_evars env evdref c)) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 3c1c4324dd..1fb414906b 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -6,6 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Names open Term open Environ open Evd @@ -43,4 +44,11 @@ val check_allowed_sort : env -> evar_map -> pinductive -> EConstr.constr -> ECon (** Raise an error message if bodies have types not unifiable with the expected ones *) val check_type_fixpoint : Loc.t -> env -> evar_map ref -> - Names.Name.t array -> EConstr.types array -> unsafe_judgment array -> unit + Names.Name.t array -> EConstr.types array -> EConstr.unsafe_judgment array -> unit + +val judge_of_prop : EConstr.unsafe_judgment +val judge_of_set : EConstr.unsafe_judgment +val judge_of_abstraction : Environ.env -> Name.t -> + EConstr.unsafe_type_judgment -> EConstr.unsafe_judgment -> EConstr.unsafe_judgment +val judge_of_product : Environ.env -> Name.t -> + EConstr.unsafe_type_judgment -> EConstr.unsafe_type_judgment -> EConstr.unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index c5c19b49ba..1b209fa772 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -120,6 +120,9 @@ let abstract_list_all env evd typ c l = | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> + (** FIXME: plug back the typing information *) + error_cannot_find_well_typed_abstraction env evd p l None + | Pretype_errors.PretypeError (env',evd,TypingError x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in let typp = EConstr.of_constr typp in evd,(p,typp) @@ -1255,15 +1258,12 @@ let is_mimick_head sigma ts f = | (Rel _|Construct _|Ind _) -> true | _ -> false -let make_judge c t = - make_judge (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr t) - let try_to_coerce env evd c cty tycon = let j = make_judge c cty in let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in let evd' = Evarconv.consider_remaining_unif_problems env evd' in let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in - (evd',EConstr.of_constr j'.uj_val) + (evd',j'.uj_val) let w_coerce_to_type env evd c cty mvty = let evd,tycon = pose_all_metas_as_evars env evd mvty in -- cgit v1.2.3 From 536026f3e20f761e8ef366ed732da7d3b626ac5e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 15:39:01 +0100 Subject: Cleaning up opening of the EConstr module in pretyping folder. --- pretyping/cases.ml | 1 - pretyping/coercion.ml | 11 ++--- pretyping/constr_matching.ml | 8 ++-- pretyping/detyping.ml | 1 + pretyping/evarconv.ml | 49 +++++++++------------ pretyping/evardefine.ml | 27 ++++++------ pretyping/evarsolve.ml | 79 ++++++++++++---------------------- pretyping/patternops.ml | 2 +- pretyping/reductionops.ml | 100 +++++++++++++++++++------------------------ pretyping/retyping.ml | 19 ++++---- pretyping/retyping.mli | 2 +- pretyping/tacred.ml | 47 ++++---------------- pretyping/typing.ml | 7 --- pretyping/unification.ml | 28 +----------- 14 files changed, 133 insertions(+), 248 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index b43e2193af..57d12a19f6 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -111,7 +111,6 @@ let make_anonymous_patvars n = let relocate_rel n1 n2 k j = if Int.equal j (n1 + k) then n2+k else j let rec relocate_index sigma n1 n2 k t = - let open EConstr in match EConstr.kind sigma t with | Rel j when Int.equal j (n1 + k) -> mkRel (n2+k) | Rel j when j < n1+k -> t diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 2d4296fe4f..e7279df7a5 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -18,6 +18,7 @@ open CErrors open Util open Names open Term +open EConstr open Vars open Reductionops open Environ @@ -48,7 +49,6 @@ exception NoCoercionNoUnifier of evar_map * unification_error (* Here, funj is a coercion therefore already typed in global context *) let apply_coercion_args env evd check isproj argl funj = - let open EConstr in let evdref = ref evd in let rec apply_rec acc typ = function | [] -> @@ -68,7 +68,7 @@ let apply_coercion_args env evd check isproj argl funj = | Prod (_,c1,c2) -> if check && not (e_cumul env evdref (EConstr.of_constr (Retyping.get_type_of env !evdref h)) c1) then raise NoCoercion; - apply_rec (h::acc) (Vars.subst1 h c2) restl + apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") in let res = apply_rec [] funj.uj_type argl in @@ -121,9 +121,8 @@ let hnf env evd c = whd_all env evd c let hnf_nodelta env evd c = whd_betaiota evd c let lift_args n sign = - let open EConstr in let rec liftrec k = function - | t::sign -> Vars.liftn n k t :: (liftrec (k-1) sign) + | t::sign -> liftn n k t :: (liftrec (k-1) sign) | [] -> [] in liftrec (List.length sign) sign @@ -150,8 +149,6 @@ let mu env evdref t = and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) : (EConstr.constr -> EConstr.constr) option = - let open EConstr in - let open Vars in let open Context.Rel.Declaration in let rec coerce_unify env x y = let x = hnf env !evdref x and y = hnf env !evdref y in @@ -478,8 +475,6 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = with UnableToUnify _ -> raise NoCoercion let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = - let open EConstr in - let open Vars in try (the_conv_x_leq env t c1 evd, v) with UnableToUnify (best_failed_evd,e) -> try inh_coerce_to_fail env evd rigidonly v t c1 diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index ecf6b11219..4d2500ccd6 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -238,7 +238,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels match EConstr.kind sigma c2 with | Proj (pr, c) when not (Projection.unfolded pr) -> (try let term = Retyping.expand_projection env sigma pr c (Array.to_list args2) in - sorec ctx env subst p (EConstr.of_constr term) + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _ -> raise PatternMatchingFailure) @@ -254,7 +254,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels else raise PatternMatchingFailure | _, Proj (pr,c) when not (Projection.unfolded pr) -> (try let term = Retyping.expand_projection env sigma pr c (Array.to_list arg2) in - sorec ctx env subst p (EConstr.of_constr term) + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | _, _ -> try Array.fold_left2 (sorec ctx env) (sorec ctx env subst c1 c2) arg1 arg2 @@ -266,7 +266,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | PApp (c, args), Proj (pr, c2) -> (try let term = Retyping.expand_projection env sigma pr c2 [] in - sorec ctx env subst p (EConstr.of_constr term) + sorec ctx env subst p term with Retyping.RetypeError _ -> raise PatternMatchingFailure) | PProj (p1,c1), Proj (p2,c2) when Projection.equal p1 p2 -> @@ -460,7 +460,7 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = if partial_app then try let term = Retyping.expand_projection env sigma p c' [] in - aux env (EConstr.of_constr term) mk_ctx next + aux env term mk_ctx next with Retyping.RetypeError _ -> next () else try_aux [env, c'] next_mk_ctx next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index e5e778f23a..4756ec30e7 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -513,6 +513,7 @@ let rec detype flags avoid env sigma t = if print_primproj_params () then try let c = Retyping.expand_projection (snd env) sigma p (EConstr.of_constr c) [] in + let c = EConstr.Unsafe.to_constr c in detype flags avoid env sigma c with Retyping.RetypeError _ -> noparams () else noparams () diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 639d6260ea..77e91095fc 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -6,15 +6,18 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open CErrors open Util open Names open Term +open Termops +open EConstr open Vars open CClosure open Reduction open Reductionops -open Termops open Environ open Recordops open Evarutil @@ -43,14 +46,12 @@ let _ = Goptions.declare_bool_option { } let unfold_projection env evd ts p c = - let open EConstr in let cst = Projection.constant p in if is_transparent_constant ts cst then Some (mkProj (Projection.make cst true, c)) else None let eval_flexible_term ts env evd c = - let open EConstr in match EConstr.kind evd c with | Const (c,u as cu) -> if is_transparent_constant ts c @@ -59,7 +60,7 @@ let eval_flexible_term ts env evd c = | Rel n -> (try match lookup_rel n env with | RelDecl.LocalAssum _ -> None - | RelDecl.LocalDef (_,v,_) -> Some (Vars.lift n (EConstr.of_constr v)) + | RelDecl.LocalDef (_,v,_) -> Some (lift n (EConstr.of_constr v)) with Not_found -> None) | Var id -> (try @@ -67,7 +68,7 @@ let eval_flexible_term ts env evd c = Option.map EConstr.of_constr (env |> lookup_named id |> NamedDecl.get_value) else None with Not_found -> None) - | LetIn (_,b,_,c) -> Some (Vars.subst1 b c) + | LetIn (_,b,_,c) -> Some (subst1 b c) | Lambda _ -> Some c | Proj (p, c) -> if Projection.unfolded p then assert false @@ -105,7 +106,6 @@ let position_problem l2r = function | CUMUL -> Some l2r let occur_rigidly (evk,_ as ev) evd t = - let open EConstr in let rec aux t = match EConstr.kind evd t with | App (f, c) -> if aux f then Array.exists aux c else false @@ -141,14 +141,13 @@ let occur_rigidly (evk,_ as ev) evd t = projection would have been reduced) *) let check_conv_record env sigma (t1,sk1) (t2,sk2) = - let open EConstr in let (proji, u), arg = Termops.global_app_of_constr sigma t1 in let canon_s,sk2_effective = try match EConstr.kind sigma t2 with Prod (_,a,b) -> (* assert (l2=[]); *) let _, a, b = destProd sigma t2 in - if Vars.noccurn sigma 1 b then + if noccurn sigma 1 b then lookup_canonical_conversion (proji, Prod_cs), (Stack.append_app [|a;EConstr.of_constr (pop b)|] Stack.empty) else raise Not_found @@ -185,9 +184,9 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = | None -> raise Not_found | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in - let c' = EConstr.of_constr (subst_univs_level_constr subst c) in - let t' = subst_univs_level_constr subst t' in - let bs' = List.map (subst_univs_level_constr subst %> EConstr.of_constr) bs in + let c' = EConstr.of_constr (CVars.subst_univs_level_constr subst c) in + let t' = CVars.subst_univs_level_constr subst t' in + let bs' = List.map (CVars.subst_univs_level_constr subst %> EConstr.of_constr) bs in let h, _ = decompose_app_vect sigma (EConstr.of_constr t') in ctx',(EConstr.of_constr h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, @@ -379,7 +378,6 @@ let rec evar_conv_x ts env evd pbty term1 term2 = and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ((term1,sk1 as appr1),csts1) ((term2,sk2 as appr2),csts2) = - let open EConstr in let quick_fail i = (* not costly, loses info *) UnifFailure (i, NotSameHead) in @@ -466,7 +464,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let termM' = Retyping.expand_projection env evd p c [] in let apprM', cstsM' = whd_betaiota_deltazeta_for_iota_state - (fst ts) env evd cstsM (EConstr.of_constr termM',skM) + (fst ts) env evd cstsM (termM',skM) in let delta' i = switch (evar_eqappr_x ts env i pbty) (apprF,cstsF) (apprM',cstsM') @@ -642,7 +640,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Catch the p.c ~= p c' cases *) | Proj (p,c), Const (p',u) when eq_constant (Projection.constant p) p' -> let res = - try Some (destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p c []))) + try Some (destApp evd (Retyping.expand_projection env evd p c [])) with Retyping.RetypeError _ -> None in (match res with @@ -653,7 +651,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Const (p,u), Proj (p',c') when eq_constant p (Projection.constant p') -> let res = - try Some (destApp evd (EConstr.of_constr (Retyping.expand_projection env evd p' c' []))) + try Some (destApp evd (Retyping.expand_projection env evd p' c' [])) with Retyping.RetypeError _ -> None in (match res with @@ -699,7 +697,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed (fst (whd_betaiota_deltazeta_for_iota_state - (fst ts) env i Cst_stack.empty (EConstr.Vars.subst1 b c, args))) + (fst ts) env i Cst_stack.empty (subst1 b c, args))) | Fix _ -> true (* Partially applied fix can be the result of a whd call *) | Proj (p, _) -> Projection.unfolded p || Stack.not_purely_applicative args | Case _ | App _| Cast _ -> assert false in @@ -878,7 +876,6 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) had to be initially resolved *) - let open EConstr in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape sk1 sk2 then let (evd',ks,_,test) = @@ -886,12 +883,12 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (fun (i,ks,m,test) b -> if match n with Some n -> Int.equal m n | None -> false then let ty = EConstr.of_constr (Retyping.get_type_of env i t2) in - let test i = evar_conv_x trs env i CUMUL ty (Vars.substl ks b) in + let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in (i,t2::ks, m-1, test) else let dloc = (Loc.ghost,Evar_kinds.InternalHole) in let i = Sigma.Unsafe.of_evar_map i in - let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (Vars.substl ks b) in + let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in let i' = Sigma.to_evar_map i' in (i', EConstr.of_constr ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs @@ -900,17 +897,17 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) ise_and evd' [(fun i -> exact_ise_stack2 env i - (fun env' i' cpb x1 x -> evar_conv_x trs env' i' cpb x1 (Vars.substl ks x)) + (fun env' i' cpb x1 x -> evar_conv_x trs env' i' cpb x1 (substl ks x)) params1 params); (fun i -> exact_ise_stack2 env i - (fun env' i' cpb u1 u -> evar_conv_x trs env' i' cpb u1 (Vars.substl ks u)) + (fun env' i' cpb u1 u -> evar_conv_x trs env' i' cpb u1 (substl ks u)) us2 us); (fun i -> evar_conv_x trs env i CONV c1 app); (fun i -> exact_ise_stack2 env i (evar_conv_x trs) sk1 sk2); test; (fun i -> evar_conv_x trs env i CONV h2 - (EConstr.of_constr (fst (decompose_app_vect i (Vars.substl ks h)))))] + (EConstr.of_constr (fst (decompose_app_vect i (substl ks h)))))] else UnifFailure(evd,(*dummy*)NotSameHead) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = @@ -951,7 +948,6 @@ let set_evar_conv f = Hook.set evar_conv_hook_set f (* We assume here |l1| <= |l2| *) let first_order_unification ts env evd (ev1,l1) (term2,l2) = - let open EConstr in let (deb2,rest2) = Array.chop (Array.length l2-Array.length l1) l2 in ise_and evd (* First compare extra args for better failure message *) @@ -973,7 +969,6 @@ let choose_less_dependent_instance evk evd term args = | (id, _) :: _ -> Some (Evd.define evk (Constr.mkVar id) evd) let apply_on_subterm env evdref f c t = - let open EConstr in let rec applyrec (env,(k,c) as acc) t = (* By using eq_constr, we make an approximation, for instance, we *) (* could also be interested in finding a term u convertible to t *) @@ -987,7 +982,7 @@ let apply_on_subterm env evdref f c t = mkEvar (evk, Array.of_list (List.map2 g ctx (Array.to_list args))) | _ -> map_constr_with_binders_left_to_right !evdref - (fun d (env,(k,c)) -> (push_rel d env, (k+1,Vars.lift 1 c))) + (fun d (env,(k,c)) -> (push_rel d env, (k+1,lift 1 c))) applyrec acc t in applyrec (env,(0,c)) t @@ -996,7 +991,6 @@ let filter_possible_projections evd c ty ctxt args = (* Since args in the types will be replaced by holes, we count the fv of args to have a well-typed filter; don't know how necessary it is however to have a well-typed filter here *) - let open EConstr in let fv1 = free_rels evd (mkApp (c,args)) (* Hack: locally untyped *) in let fv2 = collect_vars evd (mkApp (c,args)) in let len = Array.length args in @@ -1039,7 +1033,6 @@ let set_solve_evars f = solve_evars := f exception TypingFailed of evar_map let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = - let open EConstr in try let evi = Evd.find_undefined evd evk in let env_evar = evar_filtered_env evi in @@ -1137,7 +1130,6 @@ let to_pb (pb, env, t1, t2) = (pb, env, EConstr.Unsafe.to_constr t1, EConstr.Unsafe.to_constr t2) let second_order_matching_with_args ts env evd pbty ev l t = - let open EConstr in (* let evd,ev = evar_absorb_arguments env evd ev l in let argoccs = Array.map_to_list (fun _ -> None) (snd ev) in @@ -1150,7 +1142,6 @@ let second_order_matching_with_args ts env evd pbty ev l t = UnifFailure (evd, CannotSolveConstraint (pb,ProblemBeyondCapabilities)) let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = - let open EConstr in let t1 = apprec_nohdbeta ts env evd (whd_head_evar evd t1) in let t2 = apprec_nohdbeta ts env evd (whd_head_evar evd t2) in let (term1,l1 as appr1) = try destApp evd t1 with DestKO -> (t1, [||]) in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index ff40a69381..fa3b9ca0b7 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -10,8 +10,9 @@ open Util open Pp open Names open Term -open Vars open Termops +open EConstr +open Vars open Namegen open Environ open Evd @@ -75,7 +76,6 @@ let idx = Namegen.default_dependent_ident let define_pure_evar_as_product evd evk = let open Context.Named.Declaration in - let open EConstr in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in @@ -105,19 +105,19 @@ let define_pure_evar_as_product evd evk = let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in evd3, rng in - let prod = mkProd (Name id, EConstr.of_constr dom, EConstr.of_constr (subst_var id rng)) in + let rng = EConstr.of_constr rng in + let prod = mkProd (Name id, EConstr.of_constr dom, subst_var id rng) in let evd3 = Evd.define evk (EConstr.Unsafe.to_constr prod) evd2 in evd3,prod (* Refine an applied evar to a product and returns its instantiation *) let define_evar_as_product evd (evk,args) = - let open EConstr in let evd,prod = define_pure_evar_as_product evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,rng = destProd evd prod in let evdom = mkEvar (fst (destEvar evd dom), args) in - let evrngargs = Array.cons (mkRel 1) (Array.map (Vars.lift 1) args) in + let evrngargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in let evrng = mkEvar (fst (destEvar evd rng), evrngargs) in evd, mkProd (na, evdom, evrng) @@ -132,7 +132,6 @@ let define_evar_as_product evd (evk,args) = let define_pure_evar_as_lambda env evd evk = let open Context.Named.Declaration in - let open EConstr in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let typ = EConstr.of_constr (Reductionops.whd_all evenv evd (EConstr.of_constr (evar_concl evi))) in @@ -147,23 +146,21 @@ let define_pure_evar_as_lambda env evd evk = let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in - let evd2,body = new_evar_unsafe newenv evd1 ~src (Vars.subst1 (mkVar id) rng) ~filter in - let lam = mkLambda (Name id, EConstr.of_constr dom, Vars.subst_var id (EConstr.of_constr body)) in + let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in + let lam = mkLambda (Name id, EConstr.of_constr dom, subst_var id (EConstr.of_constr body)) in Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam let define_evar_as_lambda env evd (evk,args) = - let open EConstr in let evd,lam = define_pure_evar_as_lambda env evd evk in (* Quick way to compute the instantiation of evk with args *) let na,dom,body = destLambda evd lam in - let evbodyargs = Array.cons (mkRel 1) (Array.map (Vars.lift 1) args) in + let evbodyargs = Array.cons (mkRel 1) (Array.map (lift 1) args) in let evbody = mkEvar (fst (destEvar evd body), evbodyargs) in evd, mkLambda (na, dom, evbody) let rec evar_absorb_arguments env evd (evk,args as ev) = function | [] -> evd,ev | a::l -> - let open EConstr in (* TODO: optimize and avoid introducing intermediate evars *) let evd,lam = define_pure_evar_as_lambda env evd evk in let _,_,body = destLambda evd lam in @@ -177,8 +174,9 @@ let define_evar_as_sort env evd (ev,args) = let evi = Evd.find_undefined evd ev in let s = Type u in let concl = Reductionops.whd_all (evar_env evi) evd (EConstr.of_constr evi.evar_concl) in - let sort = destSort concl in - let evd' = Evd.define ev (mkSort s) evd in + let concl = EConstr.of_constr concl in + let sort = destSort evd concl in + let evd' = Evd.define ev (Constr.mkSort s) evd in Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s (* Propagation of constraints through application and abstraction: @@ -187,7 +185,6 @@ let define_evar_as_sort env evd (ev,args) = an evar instantiate it with the product of 2 new evars. *) let split_tycon loc env evd tycon = - let open EConstr in let rec real_split evd c = let t = Reductionops.whd_all env evd c in match EConstr.kind evd (EConstr.of_constr t) with @@ -208,7 +205,7 @@ let split_tycon loc env evd tycon = evd', (n, mk_tycon dom, mk_tycon rng) let valcon_of_tycon x = x -let lift_tycon n = Option.map (EConstr.Vars.lift n) +let lift_tycon n = Option.map (lift n) let pr_tycon env = function None -> str "None" diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index b1fc7cbe9a..b7db51d5c5 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -6,14 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars open Util open CErrors open Names open Term -open Vars open Environ open Termops open Evd +open EConstr +open Vars open Namegen open Retyping open Reductionops @@ -22,7 +24,6 @@ open Pretype_errors open Sigma.Notations let normalize_evar evd ev = - let open EConstr in match EConstr.kind evd (mkEvar ev) with | Evar (evk,args) -> (evk,args) | _ -> assert false @@ -50,7 +51,6 @@ let refresh_level evd s = let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) pbty env evd t = - let open EConstr in let evdref = ref evd in let modified = ref false in let rec refresh status dir t = @@ -141,7 +141,6 @@ let add_conv_oriented_pb ?(tail=true) (pbty,env,t1,t2) evd = exception IllTypedInstance of env * EConstr.types * EConstr.types let recheck_applications conv_algo env evdref t = - let open EConstr in let rec aux env t = match EConstr.kind !evdref t with | App (f, args) -> @@ -154,7 +153,7 @@ let recheck_applications conv_algo env evdref t = | Prod (na, dom, codom) -> (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; - aux (succ i) (Vars.subst1 args.(i) codom) + aux (succ i) (subst1 args.(i) codom) | UnifFailure (evd, reason) -> Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) @@ -221,7 +220,6 @@ let restrict_instance evd evk filter argsv = open Context.Rel.Declaration let noccur_evar env evd evk c = - let open EConstr in let cache = ref Int.Set.empty (* cache for let-ins *) in let rec occur_rec check_types (k, env as acc) c = match EConstr.kind evd c with @@ -234,10 +232,10 @@ let noccur_evar env evd evk c = if not (Int.Set.mem (i-k) !cache) then let decl = Environ.lookup_rel i env in if check_types then - (cache := Int.Set.add (i-k) !cache; occur_rec false acc (Vars.lift i (EConstr.of_constr (get_type decl)))); + (cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (EConstr.of_constr (get_type decl)))); (match decl with | LocalAssum _ -> () - | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (Vars.lift i (EConstr.of_constr b))) + | LocalDef (_,b,_) -> cache := Int.Set.add (i-k) !cache; occur_rec false acc (lift i (EConstr.of_constr b))) | Proj (p,c) -> occur_rec true acc c | _ -> iter_with_full_binders evd (fun rd (k,env) -> (succ k, push_rel rd env)) (occur_rec check_types) acc c @@ -270,7 +268,6 @@ let compute_var_aliases sign sigma = sign Id.Map.empty let compute_rel_aliases var_aliases rels sigma = - let open EConstr in snd (List.fold_right (fun decl (n,aliases) -> (n-1, @@ -288,7 +285,7 @@ let compute_rel_aliases var_aliases rels sigma = try Int.Map.find (p+n) aliases with Not_found -> [] in Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases | _ -> - Int.Map.add n [Vars.lift n (mkCast(t,DEFAULTcast,u))] aliases) + Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) | LocalAssum _ -> aliases) ) rels @@ -301,10 +298,9 @@ let make_alias_map env sigma = (var_aliases,rel_aliases) let lift_aliases n (var_aliases,rel_aliases as aliases) = - let open EConstr in if Int.equal n 0 then aliases else (var_aliases, - Int.Map.fold (fun p l -> Int.Map.add (p+n) (List.map (Vars.lift n) l)) + Int.Map.fold (fun p l -> Int.Map.add (p+n) (List.map (lift n) l)) rel_aliases Int.Map.empty) let get_alias_chain_of sigma aliases x = match EConstr.kind sigma x with @@ -313,7 +309,6 @@ let get_alias_chain_of sigma aliases x = match EConstr.kind sigma x with | _ -> [] let normalize_alias_opt sigma aliases x = - let open EConstr in match get_alias_chain_of sigma aliases x with | [] -> None | a::_ when isRel sigma a || isVar sigma a -> Some a @@ -326,13 +321,11 @@ let normalize_alias sigma aliases x = | None -> x let normalize_alias_var sigma var_aliases id = - let open EConstr in destVar sigma (normalize_alias sigma (var_aliases,Int.Map.empty) (mkVar id)) let extend_alias sigma decl (var_aliases,rel_aliases) = - let open EConstr in let rel_aliases = - Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (Vars.lift 1) l)) + Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l)) rel_aliases Int.Map.empty in let rel_aliases = match decl with @@ -348,7 +341,7 @@ let extend_alias sigma decl (var_aliases,rel_aliases) = try Int.Map.find (p+1) rel_aliases with Not_found -> [] in Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases | _ -> - Int.Map.add 1 [Vars.lift 1 t] rel_aliases) + Int.Map.add 1 [lift 1 t] rel_aliases) | LocalAssum _ -> rel_aliases in (var_aliases, rel_aliases) @@ -358,7 +351,6 @@ let expand_alias_once sigma aliases x = | l -> Some (List.last l) let expansions_of_var sigma aliases x = - let open EConstr in match get_alias_chain_of sigma aliases x with | [] -> [x] | a::_ as l when isRel sigma a || isVar sigma a -> x :: List.rev l @@ -379,7 +371,6 @@ let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t w let expand_vars_in_term env sigma = expand_vars_in_term_using sigma (make_alias_map env sigma) let free_vars_and_rels_up_alias_expansion sigma aliases c = - let open EConstr in let acc1 = ref Int.Set.empty and acc2 = ref Id.Set.empty in let acc3 = ref Int.Set.empty and acc4 = ref Id.Set.empty in let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in @@ -430,7 +421,7 @@ let rec expand_and_check_vars sigma aliases = function raise Exit module Constrhash = Hashtbl.Make - (struct type t = constr + (struct type t = Constr.constr let equal = Term.eq_constr let hash = hash_constr end) @@ -476,7 +467,6 @@ let remove_instance_local_defs evd evk args = (* Check if an applied evar "?X[args] l" is a Miller's pattern *) let find_unification_pattern_args env evd l t = - let open EConstr in if List.for_all (fun x -> isRel evd x || isVar evd x) l (* common failure case *) then let aliases = make_alias_map env evd in match (try Some (expand_and_check_vars evd aliases l) with Exit -> None) with @@ -488,7 +478,6 @@ let find_unification_pattern_args env evd l t = let is_unification_pattern_meta env evd nb m l t = (* Variables from context and rels > nb are implicitly all there *) (* so we need to be a rel <= nb *) - let open EConstr in if List.for_all (fun x -> isRel evd x && destRel evd x <= nb) l then match find_unification_pattern_args env evd l t with | Some _ as x when not (dependent evd (EConstr.mkMeta m) t) -> x @@ -497,7 +486,6 @@ let is_unification_pattern_meta env evd nb m l t = None let is_unification_pattern_evar env evd (evk,args) l t = - let open EConstr in if List.for_all (fun x -> isRel evd x || isVar evd x) l && noccur_evar env evd evk t then @@ -528,14 +516,13 @@ let is_unification_pattern (env,nb) evd f l t = dependency: ?X x = ?1 (?1 is a meta) will return \_.?1 while it should return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) let solve_pattern_eqn env sigma l c = - let open EConstr in let c' = List.fold_right (fun a c -> - let c' = subst_term sigma (Vars.lift 1 a) (Vars.lift 1 c) in + let c' = subst_term sigma (lift 1 a) (lift 1 c) in match EConstr.kind sigma a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> let open Context.Rel.Declaration in - let d = map_constr (lift n) (lookup_rel n env) in + let d = map_constr (CVars.lift n) (lookup_rel n env) in let c' = EConstr.of_constr c' in mkLambda_or_LetIn d c' | Var id -> @@ -604,7 +591,6 @@ let make_projectable_subst aliases sigma evi args = *) let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = - let open EConstr in let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd (EConstr.of_constr ty_t_in_sign) ~filter ~src (List.map EConstr.Unsafe.to_constr inst_in_env) in let evd = Sigma.to_evar_map evd in @@ -637,7 +623,6 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si exception MorePreciseOccurCheckNeeeded let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = - let open EConstr in if Evd.is_defined evd evk1 then (* Some circularity somewhere (see e.g. #3209) *) raise MorePreciseOccurCheckNeeeded; @@ -669,8 +654,8 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = t_in_sign sign filter inst_in_env in evd, Context.Named.Declaration.LocalDef (id,b,t_in_sign) in (push_named_context_val d' sign, Filter.extend 1 filter, - (mkRel 1)::(List.map (Vars.lift 1) inst_in_env), - (mkRel 1)::(List.map (Vars.lift 1) inst_in_sign), + (mkRel 1)::(List.map (lift 1) inst_in_env), + (mkRel 1)::(List.map (lift 1) inst_in_sign), push_rel d env,evd,id::avoid)) rel_sign (sign1,filter1,Array.to_list args1,inst_in_sign,env1,evd,ids1) @@ -707,7 +692,7 @@ let find_projectable_constructor env evd cstr k args cstr_subst = List.filter (fun (args',id) -> (* is_conv is maybe too strong (and source of useless computation) *) (* (at least expansion of aliases is needed) *) - Array.for_all2 (fun c1 c2 -> is_conv env evd (EConstr.of_constr c1) (EConstr.of_constr c2)) args args') l in + Array.for_all2 (fun c1 c2 -> is_conv env evd c1 (EConstr.of_constr c2)) args args') l in List.map snd l with Not_found -> [] @@ -765,7 +750,6 @@ let rec assoc_up_to_alias sigma aliases y yc = function | _ -> if EConstr.eq_constr sigma yc c then id else raise Not_found let rec find_projectable_vars with_evars aliases sigma y subst = - let open EConstr in let yc = normalize_alias sigma aliases y in let is_projectable idc idcl subst' = (* First test if some [id] aliased to [idc] is bound to [y] in [subst] *) @@ -829,7 +813,6 @@ let rec find_solution_type evarenv = function let rec do_projection_effects define_fun env ty evd = function | ProjectVar -> evd | ProjectEvar ((evk,argsv),evi,id,p) -> - let open EConstr in let evd = Evd.define evk (Constr.mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects define_fun env ty evd p in @@ -840,7 +823,7 @@ let rec do_projection_effects define_fun env ty evd = function one (however, regarding coercions, because t is obtained by unif, we know that no coercion can be inserted) *) let subst = make_pure_subst evi argsv in - let ty' = Vars.replace_vars subst (EConstr.of_constr evi.evar_concl) in + let ty' = replace_vars subst (EConstr.of_constr evi.evar_concl) in if isEvar evd ty' then define_fun env evd (Some false) (destEvar evd ty') ty else evd else evd @@ -875,14 +858,13 @@ type projectibility_status = let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_in_env_extended_with_k_binders = let effects = ref [] in - let open EConstr in let rec aux k t = match EConstr.kind evd t with | Rel i when i>k0+k -> aux' k (mkRel (i-k)) | Var id -> aux' k t | _ -> map_with_binders evd succ aux k t and aux' k t = - try EConstr.of_constr (project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders) + try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders with Not_found -> match expand_alias_once evd aliases t with | None -> raise Not_found @@ -983,7 +965,8 @@ let closure_of_filter evd evk = function | LocalAssum _ -> false | LocalDef (_,c,_) -> - not (isRel c || isVar c) + let c = EConstr.of_constr c in + not (isRel evd c || isVar evd c) in let newfilter = Filter.map_along test filter (evar_context evi) in (* Now ensure that restriction is at least what is was originally *) @@ -1009,7 +992,6 @@ let restrict_hyps evd evk filter candidates = exception EvarSolvedWhileRestricting of evar_map * EConstr.constr let do_restrict_hyps evd (evk,args as ev) filter candidates = - let open EConstr in let filter,candidates = match filter with | None -> None,candidates | Some filter -> restrict_hyps evd evk filter candidates in @@ -1025,7 +1007,6 @@ let do_restrict_hyps evd (evk,args as ev) filter candidates = (* ?e is assumed to have no candidates *) let postpone_non_unique_projection env evd pbty (evk,argsv as ev) sols rhs = - let open EConstr in let rhs = expand_vars_in_term env evd rhs in let filter = restrict_upon_filter evd evk @@ -1162,7 +1143,6 @@ exception EvarSolvedOnTheFly of evar_map * EConstr.constr (* Try to project evk1[argsv1] on evk2[argsv2], if [ev1] is a pattern on the common domain of definition *) let project_evar_on_evar force g env evd aliases k2 pbty (evk1,argsv1 as ev1) (evk2,argsv2 as ev2) = - let open EConstr in (* Apply filtering on ev1 so that fvs(ev1) are in fvs(ev2). *) let fvs2 = free_vars_and_rels_up_alias_expansion evd aliases (mkEvar ev2) in let filter1 = restrict_upon_filter evd evk1 @@ -1210,7 +1190,6 @@ let update_evar_source ev1 ev2 evd = let solve_evar_evar_l2r force f g env evd aliases pbty ev1 (evk2,_ as ev2) = try - let open EConstr in let evd,body = project_evar_on_evar force g env evd aliases 0 pbty ev1 ev2 in let evd' = Evd.define evk2 (EConstr.Unsafe.to_constr body) evd in let evd' = update_evar_source (fst (destEvar evd body)) evk2 evd' in @@ -1230,7 +1209,6 @@ let preferred_orientation evd evk1 evk2 = | _ -> true let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = - let open EConstr in let aliases = make_alias_map env evd in if preferred_orientation evd evk1 evk2 then try solve_evar_evar_l2r force f g env evd aliases (opp_problem pbty) ev2 ev1 @@ -1248,6 +1226,7 @@ let solve_evar_evar_aux force f g env evd pbty (evk1,args1 as ev1) (evk2,args2 a let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = let pbty = if force then None else pbty in let evi = Evd.find evd evk1 in + let downcast evk t evd = downcast evk (EConstr.Unsafe.to_constr t) evd in let evd = try (* ?X : Π Δ. Type i = ?Y : Π Δ'. Type j. @@ -1289,7 +1268,6 @@ type conv_fun_bool = * depend on these args). *) let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = - let open EConstr in let evdref = ref evd in if Array.equal (fun c1 c2 -> e_eq_constr_univs evdref (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) ) argsv1 argsv2 then !evdref else (* Filter and restrict if needed *) @@ -1350,7 +1328,7 @@ let occur_evar_upto_types sigma n c = else ( seen := Evar.Set.add sp !seen; Option.iter occur_rec (existential_opt_value sigma e); - occur_rec (existential_type sigma e)) + occur_rec (Evd.existential_type sigma e)) | _ -> Constr.iter occur_rec c in try occur_rec c; false with Occur -> true @@ -1385,7 +1363,6 @@ exception OccurCheckIn of evar_map * EConstr.constr exception MetaOccurInBodyInternal let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = - let open EConstr in let aliases = make_alias_map env evd in let evdref = ref evd in let progress = ref false in @@ -1441,7 +1418,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | LocalAssum _ -> project_variable (mkRel (i-k)) | LocalDef (_,b,_) -> try project_variable (mkRel (i-k)) - with NotInvertibleUsingOurAlgorithm _ -> imitate envk (Vars.lift i (EConstr.of_constr b))) + with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i (EConstr.of_constr b))) | Var id -> (match Environ.lookup_named id env' with | LocalAssum _ -> project_variable t @@ -1449,13 +1426,13 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = try project_variable t with NotInvertibleUsingOurAlgorithm _ -> imitate envk (EConstr.of_constr b)) | LetIn (na,b,u,c) -> - imitate envk (Vars.subst1 b c) + imitate envk (subst1 b c) | Evar (evk',args' as ev') -> if Evar.equal evk evk' then raise (OccurCheckIn (evd,rhs)); (* Evar/Evar problem (but left evar is virtual) *) let aliases = lift_aliases k aliases in (try - let ev = (evk,Array.map (Vars.lift k) argsv) in + let ev = (evk,Array.map (lift k) argsv) in let evd,body = project_evar_on_evar false conv_algo env' !evdref aliases k None ev' ev in evdref := evd; body @@ -1487,8 +1464,9 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = progress := true; match let c,args = decompose_app_vect !evdref t in + let args = Array.map EConstr.of_constr args in match EConstr.kind !evdref (EConstr.of_constr c) with - | Construct (cstr,u) when Vars.noccur_between !evdref 1 k t -> + | Construct (cstr,u) when noccur_between !evdref 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) (* possible inversions; we do not treat overlap with a possible *) @@ -1533,7 +1511,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | _ -> false in is_id_subst filter_ctxt (Array.to_list argsv) && - Vars.closed0 evd rhs && + closed0 evd rhs && Idset.subset (collect_vars evd rhs) !names in let body = @@ -1659,7 +1637,6 @@ let reconsider_conv_pbs conv_algo evd = (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = - let open EConstr in try let t2 = EConstr.of_constr (whd_betaiota evd t2) in (* includes whd_evar *) let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index d473f41bdf..ffd6e73faa 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -163,7 +163,7 @@ let pattern_of_constr env sigma t = | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) | Proj (p, c) -> - pattern_of_constr env (EConstr.of_constr (Retyping.expand_projection env sigma p c [])) + pattern_of_constr env (Retyping.expand_projection env sigma p c []) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 510417879e..0e0b807441 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -10,10 +10,11 @@ open CErrors open Util open Names open Term -open Vars open Termops open Univ open Evd +open EConstr +open Vars open Environ open Context.Rel.Declaration @@ -574,7 +575,7 @@ struct zip (best_state sigma (constr_of_cst_member cst (params @ (append_app [|f|] s))) cst_l) | f, (Cst (cst,_,_,params,_)::s) -> zip (constr_of_cst_member cst (params @ (append_app [|f|] s))) - | f, (Shift n::s) -> zip (Vars.lift n f, s) + | f, (Shift n::s) -> zip (lift n f, s) | f, (Proj (n,m,p,cst_l)::s) when refold -> zip (best_state sigma (mkProj (p,f),s) cst_l) | f, (Proj (n,m,p,_)::s) -> zip (mkProj (p,f),s) @@ -585,18 +586,18 @@ struct end (** The type of (machine) states (= lambda-bar-calculus' cuts) *) -type state = EConstr.t * EConstr.t Stack.t +type state = constr * constr Stack.t -type contextual_reduction_function = env -> evar_map -> EConstr.t -> constr +type contextual_reduction_function = env -> evar_map -> constr -> Constr.constr type reduction_function = contextual_reduction_function -type local_reduction_function = evar_map -> EConstr.t -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> EConstr.t -> (constr, 'r) Sigma.sigma } +type local_reduction_function = evar_map -> constr -> Constr.constr +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (Constr.constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = - env -> evar_map -> EConstr.t -> EConstr.t * EConstr.t list + env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = - evar_map -> EConstr.t -> EConstr.t * EConstr.t list + evar_map -> constr -> constr * constr list type contextual_state_reduction_function = env -> evar_map -> state -> state @@ -639,7 +640,7 @@ let local_strong whdfun sigma = let rec strong_prodspine redfun sigma c = let x = EConstr.of_constr (redfun sigma c) in match EConstr.kind sigma x with - | Prod (na,a,b) -> mkProd (na, EConstr.Unsafe.to_constr a,strong_prodspine redfun sigma b) + | Prod (na,a,b) -> EConstr.Unsafe.to_constr (mkProd (na,a,EConstr.of_constr (strong_prodspine redfun sigma b))) | _ -> EConstr.Unsafe.to_constr x (*************************************) @@ -656,7 +657,7 @@ let apply_subst recfun env sigma refold cst_l t stack = | Some (h,stacktl), Lambda (_,_,c) -> let cst_l' = if refold then Cst_stack.add_param h cst_l else cst_l in aux (h::env) cst_l' c stacktl - | _ -> recfun sigma cst_l (EConstr.Vars.substl env t, stack) + | _ -> recfun sigma cst_l (substl env t, stack) in aux env cst_l t stack let stacklam recfun env sigma t stack = @@ -673,8 +674,8 @@ let beta_applist sigma (c,l) = (* Iota reduction tools *) type 'a miota_args = { - mP : EConstr.t; (* the result type *) - mconstr : EConstr.t; (* the constructor *) + mP : constr; (* the result type *) + mconstr : constr; (* the constructor *) mci : case_info; (* special info to re-build pattern *) mcargs : 'a list; (* the constructor's arguments *) mlf : 'a array } (* the branch code vector *) @@ -696,7 +697,6 @@ let reducible_mind_case sigma c = match EConstr.kind sigma c with let magicaly_constant_of_fixbody env sigma reference bd = function | Name.Anonymous -> bd | Name.Name id -> - let open EConstr in try let (cst_mod,cst_sect,_) = Constant.repr3 reference in let cst = Constant.make3 cst_mod cst_sect (Label.of_id id) in @@ -719,7 +719,6 @@ let magicaly_constant_of_fixbody env sigma reference bd = function | Not_found -> bd let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbodies)) = - let open EConstr in let nbodies = Array.length bodies in let make_Fi j = let ind = nbodies-j-1 in @@ -733,11 +732,10 @@ let contract_cofix ?env sigma ?reference (bodynum,(names,types,bodies as typedbo | None -> bd | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in let closure = List.init nbodies make_Fi in - Vars.substl closure bodies.(bodynum) + substl closure bodies.(bodynum) (** Similar to the "fix" case below *) let reduce_and_refold_cofix recfun env sigma refold cst_l cofix sk = - let open EConstr in let raw_answer = let env = if refold then Some env else None in contract_cofix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) cofix in @@ -749,7 +747,6 @@ let reduce_and_refold_cofix recfun env sigma refold cst_l cofix sk = [] sigma refold Cst_stack.empty raw_answer sk let reduce_mind_case sigma mia = - let open EConstr in match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> (* let ncargs = (fst mia.mci).(i-1) in*) @@ -764,7 +761,6 @@ let reduce_mind_case sigma mia = Bi[Fj --> FIX[nl;j](A1...Ak;[F1...Fk]{B1...Bk})] *) let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies as typedbodies)) = - let open EConstr in let nbodies = Array.length recindices in let make_Fi j = let ind = nbodies-j-1 in @@ -778,14 +774,13 @@ let contract_fix ?env sigma ?reference ((recindices,bodynum),(names,types,bodies | None -> bd | Some r -> magicaly_constant_of_fixbody e sigma r bd names.(ind) in let closure = List.init nbodies make_Fi in - Vars.substl closure bodies.(bodynum) + substl closure bodies.(bodynum) (** First we substitute the Rel bodynum by the fixpoint and then we try to replace the fixpoint by the best constant from [cst_l] Other rels are directly substituted by constants "magically found from the context" in contract_fix *) let reduce_and_refold_fix recfun env sigma refold cst_l fix sk = - let open EConstr in let raw_answer = let env = if refold then None else Some env in contract_fix ?env sigma ?reference:(Cst_stack.reference sigma cst_l) fix in @@ -830,7 +825,6 @@ let _ = Goptions.declare_bool_option { } let equal_stacks sigma (x, l) (y, l') = - let open EConstr in let f_equal (x,lft1) (y,lft2) = eq_constr sigma (Vars.lift lft1 x) (Vars.lift lft2 y) in let eq_fix (a,b) (c,d) = f_equal (mkFix a, b) (mkFix c, d) in match Stack.equal f_equal eq_fix l l' with @@ -838,7 +832,6 @@ let equal_stacks sigma (x, l) (y, l') = | Some (lft1,lft2) -> f_equal (x, lft1) (y, lft2) let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = - let open EConstr in let open Context.Named.Declaration in let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then @@ -859,7 +852,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = match c0 with | Rel n when CClosure.RedFlags.red_set flags CClosure.RedFlags.fDELTA -> (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec Cst_stack.empty (EConstr.of_constr (lift n body), stack) + | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n (EConstr.of_constr body), stack) | _ -> fold ()) | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) -> (match lookup_named id env with @@ -977,7 +970,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in let u = if Int.equal napp 1 then f else mkApp (f,lc) in - if Vars.noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty),Cst_stack.empty else fold () + if noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty),Cst_stack.empty else fold () | _ -> fold () else fold () | _ -> fold ()) @@ -1054,7 +1047,6 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (** reduction machine without global env and refold machinery *) let local_whd_state_gen flags sigma = - let open EConstr in let rec whrec (x, stack) = let c0 = EConstr.kind sigma x in let s = (EConstr.of_kind c0, stack) in @@ -1077,7 +1069,7 @@ let local_whd_state_gen flags sigma = | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in let u = if Int.equal napp 1 then f else mkApp (f,lc) in - if Vars.noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty) else s + if noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty) else s | _ -> s else s | _ -> s) @@ -1276,7 +1268,7 @@ let f_conv_leq ?l2r ?reds env ?evars x y = let inj = EConstr.Unsafe.to_constr in Reduction.conv_leq ?l2r ?reds env ?evars (inj x) (inj y) -let test_trans_conversion (f: EConstr.t Reduction.extended_conversion_function) reds env sigma x y = +let test_trans_conversion (f: constr Reduction.extended_conversion_function) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in let _ = f ~reds env ~evars:(evars, Evd.universes sigma) x y in @@ -1368,9 +1360,8 @@ let default_plain_instance_ident = Id.of_string "H" (* Try to replace all metas. Does not replace metas in the metas' values * Differs from (strong whd_meta). *) let plain_instance sigma s c = - let open EConstr in let rec irec n u = match EConstr.kind sigma u with - | Meta p -> (try Vars.lift n (Metamap.find p s) with Not_found -> u) + | Meta p -> (try lift n (Metamap.find p s) with Not_found -> u) | App (f,l) when isCast sigma f -> let (f,_,t) = destCast sigma f in let l' = CArray.Fun1.smartmap irec n l in @@ -1382,13 +1373,13 @@ let plain_instance sigma s c = (try let g = Metamap.find p s in match EConstr.kind sigma g with | App _ -> - let l' = CArray.Fun1.smartmap Vars.lift 1 l' in + let l' = CArray.Fun1.smartmap lift 1 l' in mkLetIn (Name default_plain_instance_ident,g,t,mkApp(mkRel 1, l')) | _ -> mkApp (g,l') with Not_found -> mkApp (f,l')) | _ -> mkApp (irec n f,l')) | Cast (m,_,_) when isMeta sigma m -> - (try Vars.lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) + (try lift n (Metamap.find (destMeta sigma m) s) with Not_found -> u) | _ -> map_with_binders sigma succ irec n u in @@ -1440,9 +1431,8 @@ let instance sigma s c = * error message. *) let hnf_prod_app env sigma t n = - let open EConstr in match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with - | Prod (_,_,b) -> EConstr.Unsafe.to_constr (Vars.subst1 n b) + | Prod (_,_,b) -> EConstr.Unsafe.to_constr (subst1 n b) | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") let hnf_prod_appvect env sigma t nl = @@ -1452,9 +1442,8 @@ let hnf_prod_applist env sigma t nl = List.fold_left (fun acc t -> hnf_prod_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl let hnf_lam_app env sigma t n = - let open EConstr in match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with - | Lambda (_,_,b) -> EConstr.Unsafe.to_constr (Vars.subst1 n b) + | Lambda (_,_,b) -> EConstr.Unsafe.to_constr (subst1 n b) | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction") let hnf_lam_appvect env sigma t nl = @@ -1544,7 +1533,6 @@ let is_sort env sigma t = of case/fix (heuristic used by evar_conv) *) let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = - let open EConstr in let refold = get_refolding_in_reduction () in let tactic_mode = false in let rec whrec csts s = @@ -1586,7 +1574,6 @@ let is_arity env sigma c = (* Metas *) let meta_value evd mv = - let open EConstr in let rec valrec mv = match meta_opt_fvalue evd mv with | Some (b,_) -> @@ -1617,54 +1604,58 @@ let meta_reducible_instance evd b = in let metas = Metaset.fold fold fm Metamap.empty in let rec irec u = - let u = whd_betaiota Evd.empty (EConstr.of_constr u) (** FIXME *) in - match kind_of_term u with - | Case (ci,p,c,bl) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd (EConstr.of_constr c))) -> - let m = destMeta (strip_outer_cast evd (EConstr.of_constr c)) in + let u = whd_betaiota Evd.empty u (** FIXME *) in + let u = EConstr.of_constr u in + match EConstr.kind evd u with + | Case (ci,p,c,bl) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd c)) -> + let m = destMeta evd (EConstr.of_constr (strip_outer_cast evd c)) in (match try let g, s = Metamap.find m metas in + let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct g || not is_coerce then Some g else None + if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None with | Some g -> irec (mkCase (ci,p,g,bl)) | None -> mkCase (ci,irec p,c,Array.map irec bl)) - | App (f,l) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd (EConstr.of_constr f))) -> - let m = destMeta (strip_outer_cast evd (EConstr.of_constr f)) in + | App (f,l) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd f)) -> + let m = destMeta evd (EConstr.of_constr (strip_outer_cast evd f)) in (match try let g, s = Metamap.find m metas in + let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in - if isLambda g || not is_coerce then Some g else None + if isLambda evd g || not is_coerce then Some g else None with Not_found -> None with | Some g -> irec (mkApp (g,l)) | None -> mkApp (f,Array.map irec l)) | Meta m -> (try let g, s = Metamap.find m metas in + let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u with Not_found -> u) - | Proj (p,c) when isMeta c || isCast c && isMeta (pi1 (destCast c)) -> - let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in + | Proj (p,c) when isMeta evd c || isCast evd c && isMeta evd (pi1 (destCast evd c)) -> + let m = try destMeta evd c with _ -> destMeta evd (pi1 (destCast evd c)) in (match try let g, s = Metamap.find m metas in + let g = EConstr.of_constr g in let is_coerce = match s with CoerceToType -> true | _ -> false in - if isConstruct g || not is_coerce then Some g else None + if isConstruct evd g || not is_coerce then Some g else None with Not_found -> None with | Some g -> irec (mkProj (p,g)) | None -> mkProj (p,c)) - | _ -> Constr.map irec u + | _ -> EConstr.map evd irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus - else irec b.rebus + else EConstr.Unsafe.to_constr (irec (EConstr.of_constr b.rebus)) let head_unfold_under_prod ts env sigma c = - let open EConstr in let unfold (cst,u as cstu) = if Cpred.mem cst (snd ts) then match constant_opt_value_in env cstu with @@ -1682,12 +1673,11 @@ let head_unfold_under_prod ts env sigma c = EConstr.Unsafe.to_constr (aux c) let betazetaevar_applist sigma n c l = - let open EConstr in let rec stacklam n env t stack = - if Int.equal n 0 then applist (Vars.substl env t, stack) else + if Int.equal n 0 then applist (substl env t, stack) else match EConstr.kind sigma t, stack with | Lambda(_,_,c), arg::stacktl -> stacklam (n-1) (arg::env) c stacktl - | LetIn(_,b,_,c), _ -> stacklam (n-1) (Vars.substl env b::env) c stack - | Evar _, _ -> applist (Vars.substl env t, stack) + | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack + | Evar _, _ -> applist (substl env t, stack) | _ -> anomaly (Pp.str "Not enough lambda/let's") in EConstr.Unsafe.to_constr (stacklam n [] c l) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index a7ccf98a66..6f03fc462a 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -10,13 +10,14 @@ open Pp open CErrors open Util open Term -open Vars open Inductive open Inductiveops open Names open Reductionops open Environ open Termops +open EConstr +open Vars open Arguments_renaming open Context.Rel.Declaration @@ -58,7 +59,6 @@ let local_def (na, b, t) = LocalDef (na, inj b, inj t) let get_type_from_constraints env sigma t = - let open EConstr in if isEvar sigma (EConstr.of_constr (fst (decompose_app_vect sigma t))) then match List.map_filter (fun (pbty,env,t1,t2) -> @@ -74,19 +74,17 @@ let get_type_from_constraints env sigma t = let rec subst_type env sigma typ = function | [] -> typ | h::rest -> - let open EConstr in match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma typ)) with - | Prod (na,c1,c2) -> subst_type env sigma (Vars.subst1 h c2) rest + | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest | _ -> retype_error NonFunctionalConstruction (* If ft is the type of f which itself is applied to args, *) (* [sort_of_atomic_type] computes ft[args] which has to be a sort *) let sort_of_atomic_type env sigma ft args = - let open EConstr in let rec concl_of_arity env n ar args = match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma ar)), args with - | Prod (na, t, b), h::l -> concl_of_arity (push_rel (local_def (na, Vars.lift n h, t)) env) (n + 1) b l + | Prod (na, t, b), h::l -> concl_of_arity (push_rel (local_def (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) @@ -101,7 +99,6 @@ let decomp_sort env sigma t = | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = - let open EConstr in let rec type_of env cstr = match EConstr.kind sigma cstr with | Meta n -> @@ -109,7 +106,7 @@ let retype ?(polyprop=true) sigma = with Not_found -> retype_error (BadMeta n)) | Rel n -> let ty = EConstr.of_constr (RelDecl.get_type (lookup_rel n env)) in - Vars.lift n ty + lift n ty | Var id -> type_of_var env id | Const cst -> EConstr.of_constr (rename_type_of_constant env cst) | Evar (evk, args) -> EConstr.of_constr (Evd.existential_type sigma (evk, Array.map EConstr.Unsafe.to_constr args)) @@ -133,7 +130,7 @@ let retype ?(polyprop=true) sigma = | Lambda (name,c1,c2) -> mkProd (name, c1, type_of (push_rel (local_assum (name,c1)) env) c2) | LetIn (name,b,c1,c2) -> - Vars.subst1 b (type_of (push_rel (local_def (name,b,c1)) env) c2) + subst1 b (type_of (push_rel (local_def (name,b,c1)) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) | App(f,args) when is_template_polymorphic env sigma f -> @@ -257,11 +254,11 @@ let sorts_of_context env evc ctxt = snd (aux ctxt) let expand_projection env sigma pr c args = - let inj = EConstr.Unsafe.to_constr in let ty = get_type_of ~lax:true env sigma c in let (i,u), ind_args = try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with Not_found -> retype_error BadRecursiveType in + let ind_args = List.map EConstr.of_constr ind_args in mkApp (mkConstU (Projection.constant pr,u), - Array.of_list (ind_args @ (inj c :: List.map inj args))) + Array.of_list (ind_args @ (c :: args))) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index c844038904..a20b11b76e 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -45,6 +45,6 @@ val type_of_global_reference_knowing_conclusion : val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list -val expand_projection : env -> evar_map -> Names.projection -> EConstr.constr -> EConstr.constr list -> constr +val expand_projection : env -> evar_map -> Names.projection -> EConstr.constr -> EConstr.constr list -> EConstr.constr val print_retype_error : retype_error -> Pp.std_ppcmds diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 5b8eaa50b1..ae53c12ae7 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -11,10 +11,11 @@ open CErrors open Util open Names open Term -open Vars open Libnames open Globnames open Termops +open EConstr +open Vars open Find_subterm open Namegen open Environ @@ -88,7 +89,6 @@ let evaluable_reference_eq sigma r1 r2 = match r1, r2 with | _ -> false let mkEvalRef ref u = - let open EConstr in match ref with | EvalConst cst -> mkConstU (cst,u) | EvalVar id -> mkVar id @@ -109,7 +109,6 @@ let destEvalRefU sigma c = match EConstr.kind sigma c with | _ -> anomaly (Pp.str "Not an unfoldable reference") let unsafe_reference_opt_value env sigma eval = - let open EConstr in match eval with | EvalConst cst -> (match (lookup_constant cst env).Declarations.const_body with @@ -118,20 +117,19 @@ let unsafe_reference_opt_value env sigma eval = | EvalVar id -> env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr | EvalRel n -> - env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value |> Option.map EConstr.of_constr + env |> lookup_rel n |> RelDecl.get_value |> Option.map (EConstr.of_constr %> lift n) | EvalEvar ev -> match EConstr.kind sigma (mkEvar ev) with | Evar _ -> None | c -> Some (EConstr.of_kind c) let reference_opt_value env sigma eval u = - let open EConstr in match eval with | EvalConst cst -> Option.map EConstr.of_constr (constant_opt_value_in env (cst,u)) | EvalVar id -> env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr | EvalRel n -> - env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value |> Option.map EConstr.of_constr + env |> lookup_rel n |> RelDecl.get_value |> Option.map (EConstr.of_constr %> lift n) | EvalEvar ev -> match EConstr.kind sigma (mkEvar ev) with | Evar _ -> None @@ -187,7 +185,6 @@ let eval_table = Summary.ref (Cmap.empty : frozen) ~name:"evaluation" *) let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = - let open EConstr in let n = List.length labs in let nargs = List.length args in if nargs > n then raise Elimconst; @@ -232,7 +229,6 @@ let check_fix_reversibility sigma labs args ((lv,i),(_,tys,bds)) = let invert_name labs l na0 env sigma ref = function | Name id -> - let open EConstr in let minfxargs = List.length l in begin match na0 with | Name id' when Id.equal id' id -> @@ -276,7 +272,6 @@ let local_def (na, b, t) = LocalDef (na, inj b, inj t) let compute_consteval_direct env sigma ref = - let open EConstr in let rec srec env n labs onlyproj c = let c',l = whd_betadeltazeta_stack env sigma c in match EConstr.kind sigma c' with @@ -295,7 +290,6 @@ let compute_consteval_direct env sigma ref = | Some c -> srec env 0 [] false c let compute_consteval_mutual_fix env sigma ref = - let open EConstr in let rec srec env minarg labs ref c = let c',l = whd_betalet_stack sigma c in let nargs = List.length l in @@ -367,7 +361,6 @@ let reference_eval env sigma = function let x = Name default_dependent_ident let make_elim_fun (names,(nbfix,lv,n)) u largs = - let open EConstr in let lu = List.firstn n largs in let p = List.length lv in let lyi = List.map fst lv in @@ -393,7 +386,7 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs = (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: do so that the reduction uses this extra information *) -let dummy = mkProp +let dummy = Constr.mkProp let vfx = Id.of_string "_expanded_fix_" let vfun = Id.of_string "_eliminator_function_" let venv = let open Context.Named.Declaration in @@ -403,7 +396,6 @@ let venv = let open Context.Named.Declaration in as a problem variable: an evar that can be instantiated either by vfx (expanded fixpoint) or vfun (named function). *) let substl_with_function subst sigma constr = - let open EConstr in let evd = ref sigma in let minargs = ref Evar.Map.empty in let v = Array.of_list subst in @@ -431,8 +423,7 @@ exception Partial reduction is solved by the expanded fix term. *) let solve_arity_problem env sigma fxminargs c = let evm = ref sigma in - let set_fix i = evm := Evd.define i (mkVar vfx) !evm in - let open EConstr in + let set_fix i = evm := Evd.define i (Constr.mkVar vfx) !evm in let rec check strict c = let c' = EConstr.of_constr (whd_betaiotazeta sigma c) in let (h,rcargs) = decompose_app_vect sigma c' in @@ -491,7 +482,6 @@ let reduce_fix whdfun sigma fix stack = let contract_fix_use_function env sigma f ((recindices,bodynum),(_names,_types,bodies as typedbodies)) = - let open EConstr in let nbodies = Array.length recindices in let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = List.init nbodies make_Fi in @@ -515,7 +505,6 @@ let reduce_fix_use_function env sigma f whfun fix stack = let contract_cofix_use_function env sigma f (bodynum,(_names,_,bodies as typedbodies)) = - let open EConstr in let nbodies = Array.length bodies in let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = List.init nbodies make_Fi in @@ -523,7 +512,6 @@ let contract_cofix_use_function env sigma f sigma (EConstr.of_constr (nf_beta sigma bodies.(bodynum))) let reduce_mind_case_use_function func env sigma mia = - let open EConstr in match EConstr.kind sigma mia.mconstr with | Construct ((ind_sp,i),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in @@ -573,11 +561,10 @@ let match_eval_ref_value env sigma constr = | Var id when is_evaluable env (EvalVarRef id) -> env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr | Rel n -> - env |> lookup_rel n |> RelDecl.map_value (lift n) |> RelDecl.get_value |> Option.map EConstr.of_constr + env |> lookup_rel n |> RelDecl.get_value |> Option.map (EConstr.of_constr %> lift n) | _ -> None let special_red_case env sigma whfun (ci, p, c, lf) = - let open EConstr in let rec redrec s = let (constr, cargs) = whfun s in match match_eval_ref env sigma constr with @@ -614,7 +601,6 @@ let reduce_projection env sigma pb (recarg'hd,stack') stack = | _ -> NotReducible) let reduce_proj env sigma whfun whfun' c = - let open EConstr in let rec redrec s = match EConstr.kind sigma s with | Proj (proj, c) -> @@ -641,7 +627,7 @@ let whd_nothing_for_iota env sigma s = | Rel n -> let open Context.Rel.Declaration in (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec (EConstr.of_constr (lift n body), stack) + | LocalDef (_,body,_) -> whrec (lift n (EConstr.of_constr body), stack) | _ -> s) | Var id -> let open Context.Named.Declaration in @@ -673,7 +659,6 @@ let whd_nothing_for_iota env sigma s = it fails if no redex is around *) let rec red_elim_const env sigma ref u largs = - let open EConstr in let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim, nocase = match recargs ref with @@ -747,7 +732,6 @@ and reduce_params env sigma stack l = a reducible iota/fix/cofix redex (the "simpl" tactic) *) and whd_simpl_stack env sigma = - let open EConstr in let rec redrec s = let (x, stack) = decompose_app_vect sigma s in let stack = Array.map_to_list EConstr.of_constr stack in @@ -818,7 +802,6 @@ and whd_simpl_stack env sigma = (* reduce until finding an applied constructor or fail *) and whd_construct_stack env sigma s = - let open EConstr in let (constr, cargs as s') = whd_simpl_stack env sigma s in if reducible_mind_case sigma constr then s' else match match_eval_ref env sigma constr with @@ -838,7 +821,6 @@ and whd_construct_stack env sigma s = let try_red_product env sigma c = let simpfun c = EConstr.of_constr (clos_norm_flags betaiotazeta env sigma c) in - let open EConstr in let rec redrec env x = let x = EConstr.of_constr (whd_betaiota sigma x) in match EConstr.kind sigma x with @@ -948,7 +930,6 @@ let whd_simpl_stack = immediately hides a non reducible fix or a cofix *) let whd_simpl_orelse_delta_but_fix env sigma c = - let open EConstr in let rec redrec s = let (constr, stack as s') = whd_simpl_stack env sigma s in match match_eval_ref_value env sigma constr with @@ -982,7 +963,6 @@ let simpl env sigma c = strong whd_simpl env sigma c (* Reduction at specific subterms *) let matches_head env sigma c t = - let open EConstr in match EConstr.kind sigma t with | App (f,_) -> Constr_matching.matches env sigma c f | Proj (p, _) -> Constr_matching.matches env sigma c (mkConstU (Projection.constant p, Univ.Instance.empty)) @@ -993,11 +973,9 @@ let matches_head env sigma c t = of the projection and its eta expanded form. *) let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = - let open EConstr in match EConstr.kind sigma c with | Proj (p, r) -> (* Treat specially for partial applications *) let t = Retyping.expand_projection env sigma p r [] in - let t = EConstr.of_constr t in let hdf, al = destApp sigma t in let a = al.(Array.length al - 1) in let app = (mkApp (hdf, Array.sub al 0 (Array.length al - 1))) in @@ -1011,7 +989,6 @@ let change_map_constr_with_binders_left_to_right g f (env, l as acc) sigma c = | _ -> map_constr_with_binders_left_to_right sigma g f acc c let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> - let open EConstr in let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in @@ -1138,7 +1115,6 @@ let unfoldn loccname env sigma c = (* Re-folding constants tactics: refold com in term c *) let fold_one_com com env sigma c = - let open EConstr in let rcom = try EConstr.of_constr (red_product env sigma com) with Redelimination -> error "Not reducible." in @@ -1176,7 +1152,6 @@ let compute = cbv_betadeltaiota * the specified occurrences. *) let abstract_scheme env sigma (locc,a) (c, sigma) = - let open EConstr in let ta = Retyping.get_type_of env sigma a in let ta = EConstr.of_constr ta in let na = named_hd env (EConstr.to_constr sigma ta) Anonymous in @@ -1189,7 +1164,6 @@ let abstract_scheme env sigma (locc,a) (c, sigma) = mkLambda (na,ta,c'), sigma' let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> - let open EConstr in let sigma = Sigma.to_evar_map sigma in let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in try @@ -1218,7 +1192,6 @@ let check_not_primitive_record env ind = return name, B and t' *) let reduce_to_ind_gen allow_product env sigma t = - let open EConstr in let rec elimrec env t l = let t = hnf_constr env sigma t in let t = EConstr.of_constr t in @@ -1246,7 +1219,7 @@ let reduce_to_atomic_ind env sigma c = reduce_to_ind_gen false env sigma (EConst let find_hnf_rectype env sigma t = let ind,t = reduce_to_atomic_ind env sigma t in - ind, snd (decompose_app t) + ind, snd (Term.decompose_app t) (* Reduce the weak-head redex [beta,iota/fix/cofix[all],cast,zeta,simpl/delta] or raise [NotStepReducible] if not a weak-head redex *) @@ -1254,7 +1227,6 @@ let find_hnf_rectype env sigma t = exception NotStepReducible let one_step_reduce env sigma c = - let open EConstr in let rec redrec (x, stack) = match EConstr.kind sigma x with | Lambda (n,t,c) -> @@ -1302,7 +1274,6 @@ let reduce_to_ref_gen allow_product env sigma ref t = else (* lazily reduces to match the head of [t] with the expected [ref] *) let rec elimrec env t l = - let open EConstr in let c, _ = decompose_app_vect sigma t in let c = EConstr.of_constr c in match EConstr.kind sigma c with diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 17adea5f2c..cf58a0b668 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -65,7 +65,6 @@ let e_assumption_of_judgment env evdref j = error_assumption env !evdref j let e_judge_of_apply env evdref funj argjv = - let open EConstr in let rec apply_rec n typ = function | [] -> { uj_val = mkApp (j_val funj, Array.map j_val argjv); @@ -100,7 +99,6 @@ let max_sort l = if Sorts.List.mem InSet l then InSet else InProp let e_is_correct_arity env evdref c pj ind specif params = - let open EConstr in let arsign = make_arity_signature env true (make_ind_family (ind,params)) in let allowed_sorts = elim_sorts specif in let error () = Pretype_errors.error_elim_arity env !evdref ind allowed_sorts c pj None in @@ -124,7 +122,6 @@ let e_is_correct_arity env evdref c pj ind specif params = srec env pj.uj_type (List.rev arsign) let lambda_applist_assum sigma n c l = - let open EConstr in let rec app n subst t l = if Int.equal n 0 then if l == [] then substl subst t @@ -150,7 +147,6 @@ let e_type_case_branches env evdref (ind,largs) pj c = (lc, ty) let e_judge_of_case env evdref ci pj cj lfj = - let open EConstr in let indspec = try find_mrectype env !evdref cj.uj_type with Not_found -> error_case_not_inductive env !evdref cj in @@ -161,7 +157,6 @@ let e_judge_of_case env evdref ci pj cj lfj = uj_type = rslty } let check_type_fixpoint loc env evdref lna lar vdefj = - let open EConstr in let lt = Array.length vdefj in if Int.equal (Array.length lar) lt then for i = 0 to lt-1 do @@ -183,7 +178,6 @@ let check_allowed_sort env sigma ind c p = (Some(ksort,s,Type_errors.error_elim_explain ksort s)) let e_judge_of_cast env evdref cj k tj = - let open EConstr in let expected_type = tj.utj_val in if not (Evarconv.e_cumul env evdref cj.uj_type expected_type) then error_actual_type_core env !evdref cj expected_type; @@ -259,7 +253,6 @@ let judge_of_letin env name defj typj j = (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env evdref cstr = - let open EConstr in let cstr = EConstr.of_constr (whd_evar !evdref (EConstr.Unsafe.to_constr cstr)) in match EConstr.kind !evdref cstr with | Meta n -> diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 1b209fa772..483fefaf2e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -85,7 +85,6 @@ let occur_meta_evd sigma mv c = gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) let abstract_scheme env evd c l lname_typ = - let open EConstr in let mkLambda_name env (n,a,b) = mkLambda (named_hd env (EConstr.Unsafe.to_constr a) n, a, b) in @@ -131,7 +130,6 @@ let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) let abstract_list_all_with_dependencies env evd typ c l = - let open EConstr in let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (ev, evd, _) = new_evar env evd typ in let evd = Sigma.to_evar_map evd in @@ -195,8 +193,6 @@ let pose_all_metas_as_evars env evd t = (!evdref, c) let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst : subst0) = - let open EConstr in - let open Vars in match EConstr.kind sigma f with | Meta k -> (* We enforce that the Meta does not depend on the [nb] @@ -476,7 +472,6 @@ let use_evars_pattern_unification flags = && Flags.version_strictly_greater Flags.V8_2 let use_metas_pattern_unification sigma flags nb l = - let open EConstr in !global_pattern_unification_flag && flags.use_pattern_unification || (Flags.version_less_or_equal Flags.V8_3 || flags.use_meta_bound_pattern_unification) && @@ -636,7 +631,6 @@ let check_compatibility env pbty flags (sigma,metasubst,evarsubst : subst0) tyM let rec is_neutral env sigma ts t = - let open EConstr in let (f, l) = decompose_app_vect sigma t in match EConstr.kind sigma (EConstr.of_constr f) with | Const (c, u) -> @@ -666,7 +660,6 @@ let is_eta_constructor_app env sigma ts f l1 term = | _ -> false let eta_constructor_app env sigma f l1 term = - let open EConstr in match EConstr.kind sigma f with | Construct (((_, i as ind), j), u) -> let mib = lookup_mind (fst ind) env in @@ -684,8 +677,6 @@ let print_constr_env env c = print_constr_env env (EConstr.Unsafe.to_constr c) let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = - let open EConstr in - let open Vars in let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in @@ -892,7 +883,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e let expand_proj c c' l = match EConstr.kind sigma c with | Proj (p, t) when not (Projection.unfolded p) && needs_expansion p c' -> - (try destApp sigma (EConstr.of_constr (Retyping.expand_projection curenv sigma p t (Array.to_list l))) + (try destApp sigma (Retyping.expand_projection curenv sigma p t (Array.to_list l)) with RetypeError _ -> (** Unification can be called on ill-typed terms, due to FO and eta in particular, fail gracefully in that case *) (c, l)) @@ -1128,8 +1119,6 @@ let right = false let rec unify_with_eta keptside flags env sigma c1 c2 = (* Question: try whd_all on ci if not two lambdas? *) - let open EConstr in - let open Vars in match EConstr.kind sigma c1, EConstr.kind sigma c2 with | (Lambda (na,t1,c1'), Lambda (_,t2,c2')) -> let env' = push_rel_assum (na,t1) env in @@ -1234,8 +1223,6 @@ let merge_instances env sigma flags st1 st2 c1 c2 = * since other metavars might also need to be resolved. *) let applyHead env (type r) (evd : r Sigma.t) n c = - let open EConstr in - let open Vars in let rec apprec : type s. _ -> _ -> _ -> (r, s) Sigma.le -> s Sigma.t -> (constr, r) Sigma.sigma = fun n c cty p evd -> if Int.equal n 0 then @@ -1307,7 +1294,6 @@ let order_metas metas = (* Solve an equation ?n[x1=u1..xn=un] = t where ?n is an evar *) let solve_simple_evar_eqn ts env evd ev rhs = - let open EConstr in match solve_simple_eqn (Evarconv.evar_conv_x ts) env evd (None,ev,rhs) with | UnifFailure (evd,reason) -> error_cannot_unify env evd ~reason (mkEvar ev,rhs); @@ -1319,8 +1305,6 @@ let solve_simple_evar_eqn ts env evd ev rhs = is true, unification of types of metas is required *) let w_merge env with_types flags (evd,metas,evars : subst0) = - let open EConstr in - let open Vars in let rec w_merge_rec evd metas evars eqns = (* Process evars *) @@ -1498,7 +1482,6 @@ let w_unify_core_0 env evd with_types cv_pb flags m n = let w_typed_unify env evd = w_unify_core_0 env evd true let w_typed_unify_array env evd flags f1 l1 f2 l2 = - let open EConstr in let f1 = EConstr.of_constr f1 in let f2 = EConstr.of_constr f2 in let l1 = Array.map EConstr.of_constr l1 in @@ -1529,7 +1512,6 @@ let iter_fail f a = contexts, with evars, and possibly with occurrences *) let indirectly_dependent sigma c d decls = - let open EConstr in not (isVar sigma c) && (* This test is not needed if the original term is a variable, but it is needed otherwise, as e.g. when abstracting over "2" in @@ -1590,7 +1572,6 @@ let default_matching_flags (sigma,_) = exception PatternNotFound let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = - let open EConstr in let flags = if from_prefix_of_ind then let flags = default_matching_flags pending in @@ -1600,7 +1581,6 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = else default_matching_flags pending in let n = Array.length (snd (decompose_app_vect sigma c)) in let matching_fun _ t = - let open EConstr in try let t',l2 = if from_prefix_of_ind then @@ -1754,8 +1734,6 @@ let keyed_unify env evd kop = Unifies [cl] to every subterm of [op] until it finds a match. Fails if no match is found *) let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = - let open EConstr in - let open Vars in let bestexn = ref None in let kop = Keys.constr_key (EConstr.to_constr evd op) in let rec matchrec cl = @@ -1831,8 +1809,6 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = Unifies [cl] to every subterm of [op] and return all the matches. Fails if no match is found *) let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = - let open EConstr in - let open Vars in let return a b = let (evd,c as a) = a () in if List.exists (fun (evd',c') -> EConstr.eq_constr evd' c c') b then b else a :: b @@ -1897,7 +1873,6 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = | _ -> res let w_unify_to_subterm_list env evd flags hdmeta oplist t = - let open EConstr in List.fold_right (fun op (evd,l) -> let op = whd_meta evd op in @@ -2008,7 +1983,6 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = - let open EConstr in let hd1,l1 = decompose_app_vect evd (EConstr.of_constr (whd_nored evd ty1)) in let hd2,l2 = decompose_app_vect evd (EConstr.of_constr (whd_nored evd ty2)) in let is_empty1 = Array.is_empty l1 in -- cgit v1.2.3 From cbea91d815f134d63d02d8fb1bd78ed97db28cd1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 19:52:48 +0100 Subject: Tacmach API using EConstr. --- pretyping/tacred.ml | 4 ++-- pretyping/tacred.mli | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) (limited to 'pretyping') diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index ae53c12ae7..24d4af89a6 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1214,8 +1214,8 @@ let reduce_to_ind_gen allow_product env sigma t = in elimrec env t [] -let reduce_to_quantified_ind env sigma c = reduce_to_ind_gen true env sigma (EConstr.of_constr c) -let reduce_to_atomic_ind env sigma c = reduce_to_ind_gen false env sigma (EConstr.of_constr c) +let reduce_to_quantified_ind env sigma c = reduce_to_ind_gen true env sigma c +let reduce_to_atomic_ind env sigma c = reduce_to_ind_gen false env sigma c let find_hnf_rectype env sigma t = let ind,t = reduce_to_atomic_ind env sigma t in diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index d32fcf4917..3587ae2810 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -75,12 +75,12 @@ val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> types -> pinductive * types +val reduce_to_atomic_ind : env -> evar_map -> EConstr.types -> pinductive * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types +val reduce_to_quantified_ind : env -> evar_map -> EConstr.types -> pinductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) @@ -91,7 +91,7 @@ val reduce_to_atomic_ref : env -> evar_map -> global_reference -> EConstr.types -> types val find_hnf_rectype : - env -> evar_map -> types -> pinductive * constr list + env -> evar_map -> EConstr.types -> pinductive * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function -- cgit v1.2.3 From 0489e8b56d7e10f7111c0171960e25d32201b963 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 21:55:33 +0100 Subject: Clenv API using EConstr. --- pretyping/evarconv.ml | 12 ++++++------ pretyping/miscops.ml | 13 +++++++++++++ pretyping/miscops.mli | 5 +++++ pretyping/reductionops.ml | 8 +++++--- pretyping/reductionops.mli | 4 ++-- pretyping/typing.ml | 3 ++- pretyping/typing.mli | 2 +- pretyping/unification.ml | 14 +++++++++----- 8 files changed, 43 insertions(+), 18 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 77e91095fc..ee6355736b 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -6,8 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -module CVars = Vars - open CErrors open Util open Names @@ -184,10 +182,12 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = | None -> raise Not_found | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in - let c' = EConstr.of_constr (CVars.subst_univs_level_constr subst c) in - let t' = CVars.subst_univs_level_constr subst t' in - let bs' = List.map (CVars.subst_univs_level_constr subst %> EConstr.of_constr) bs in - let h, _ = decompose_app_vect sigma (EConstr.of_constr t') in + let c = EConstr.of_constr c in + let c' = subst_univs_level_constr subst c in + let t' = EConstr.of_constr t' in + let t' = subst_univs_level_constr subst t' in + let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in + let h, _ = decompose_app_vect sigma t' in ctx',(EConstr.of_constr h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, (n, Stack.zip sigma (t2,sk2)) diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml index 142e430ff8..7fe81c9a43 100644 --- a/pretyping/miscops.ml +++ b/pretyping/miscops.ml @@ -58,3 +58,16 @@ let map_red_expr_gen f g h = function | CbvNative occs_o -> CbvNative (Option.map (map_occs (map_union g h)) occs_o) | Cbn flags -> Cbn (map_flags g flags) | ExtraRedExpr _ | Red _ | Hnf as x -> x + +(** Mapping bindings *) + +let map_explicit_bindings f l = + let map (loc, hyp, x) = (loc, hyp, f x) in + List.map map l + +let map_bindings f = function +| ImplicitBindings l -> ImplicitBindings (List.map f l) +| ExplicitBindings expl -> ExplicitBindings (map_explicit_bindings f expl) +| NoBindings -> NoBindings + +let map_with_bindings f (x, bl) = (f x, map_bindings f bl) diff --git a/pretyping/miscops.mli b/pretyping/miscops.mli index 337473a6fd..f30dc1a4b6 100644 --- a/pretyping/miscops.mli +++ b/pretyping/miscops.mli @@ -27,3 +27,8 @@ val intro_pattern_naming_eq : val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) -> ('a,'b,'c) red_expr_gen -> ('d,'e,'f) red_expr_gen + +(** Mapping bindings *) + +val map_bindings : ('a -> 'b) -> 'a bindings -> 'b bindings +val map_with_bindings : ('a -> 'b) -> 'a with_bindings -> 'b with_bindings diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0e0b807441..0dd615bfb7 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1588,9 +1588,11 @@ let meta_instance sigma b = if Metaset.is_empty fm then b.rebus else let c_sigma = Metamap.bind (fun mv -> meta_value sigma mv) fm in - instance sigma c_sigma (EConstr.of_constr b.rebus) + EConstr.of_constr (instance sigma c_sigma b.rebus) -let nf_meta sigma c = meta_instance sigma (mk_freelisted c) +let nf_meta sigma c = + let cl = mk_freelisted c in + EConstr.Unsafe.to_constr (meta_instance sigma { cl with rebus = EConstr.of_constr cl.rebus }) (* Instantiate metas that create beta/iota redexes *) @@ -1652,7 +1654,7 @@ let meta_reducible_instance evd b = | _ -> EConstr.map evd irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus - else EConstr.Unsafe.to_constr (irec (EConstr.of_constr b.rebus)) + else irec b.rebus let head_unfold_under_prod ts env sigma c = diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index c3b82729d5..864b1a625c 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -295,6 +295,6 @@ val whd_betaiota_deltazeta_for_iota_state : state * Cst_stack.t (** {6 Meta-related reduction functions } *) -val meta_instance : evar_map -> constr freelisted -> constr +val meta_instance : evar_map -> EConstr.constr freelisted -> EConstr.constr val nf_meta : evar_map -> constr -> constr -val meta_reducible_instance : evar_map -> constr freelisted -> constr +val meta_reducible_instance : evar_map -> EConstr.constr freelisted -> EConstr.constr diff --git a/pretyping/typing.ml b/pretyping/typing.ml index cf58a0b668..29697260f7 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -40,6 +40,7 @@ let meta_type evd mv = let ty = try Evd.meta_ftype evd mv with Not_found -> anomaly (str "unknown meta ?" ++ str (Nameops.string_of_meta mv)) in + let ty = Evd.map_fl EConstr.of_constr ty in meta_instance evd ty let constant_type_knowing_parameters env sigma cst jl = @@ -256,7 +257,7 @@ let rec execute env evdref cstr = let cstr = EConstr.of_constr (whd_evar !evdref (EConstr.Unsafe.to_constr cstr)) in match EConstr.kind !evdref cstr with | Meta n -> - { uj_val = cstr; uj_type = EConstr.of_constr (meta_type !evdref n) } + { uj_val = cstr; uj_type = meta_type !evdref n } | Evar ev -> let ty = EConstr.existential_type !evdref ev in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 1fb414906b..94a56b6e11 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -31,7 +31,7 @@ val e_sort_of : env -> evar_map ref -> EConstr.types -> sorts val e_check : env -> evar_map ref -> EConstr.constr -> EConstr.types -> unit (** Returns the instantiated type of a metavariable *) -val meta_type : evar_map -> metavariable -> types +val meta_type : evar_map -> metavariable -> EConstr.types (** Solve existential variables using typing *) val e_solve_evars : env -> evar_map ref -> EConstr.constr -> constr diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 483fefaf2e..2b2069ec45 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -617,10 +617,10 @@ let subst_defined_metas_evars sigma (bl,el) c = in try Some (substrec c) with Not_found -> None let check_compatibility env pbty flags (sigma,metasubst,evarsubst : subst0) tyM tyN = - match subst_defined_metas_evars sigma (metasubst,[]) (EConstr.of_constr tyM) with + match subst_defined_metas_evars sigma (metasubst,[]) tyM with | None -> sigma | Some m -> - match subst_defined_metas_evars sigma (metasubst,[]) (EConstr.of_constr tyN) with + match subst_defined_metas_evars sigma (metasubst,[]) tyN with | None -> sigma | Some n -> if is_ground_term sigma m && is_ground_term sigma n then @@ -705,6 +705,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in + let tyN = EConstr.of_constr tyN in check_compatibility curenv CUMUL flags substn tyN tyM with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma) @@ -724,6 +725,7 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if opt.with_types && flags.check_applied_meta_types then (try let tyM = get_type_of curenv ~lax:true sigma cM in + let tyM = EConstr.of_constr tyM in let tyN = Typing.meta_type sigma k in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> @@ -977,6 +979,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e try (* Ensure we call conversion on terms of the same type *) let tyM = get_type_of curenv ~lax:true sigma m1 in let tyN = get_type_of curenv ~lax:true sigma n1 in + let tyM = EConstr.of_constr tyM in + let tyN = EConstr.of_constr tyN in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma @@ -1265,7 +1269,7 @@ let w_coerce_to_type env evd c cty mvty = let w_coerce env evd mv c = let cty = get_type_of env evd c in let mvty = Typing.meta_type evd mv in - w_coerce_to_type env evd c (EConstr.of_constr cty) (EConstr.of_constr mvty) + w_coerce_to_type env evd c (EConstr.of_constr cty) mvty let unify_to_type env sigma flags c status u = let sigma, c = refresh_universes (Some false) env sigma c in @@ -1275,6 +1279,7 @@ let unify_to_type env sigma flags c status u = let unify_type env sigma flags mv status c = let mvty = Typing.meta_type sigma mv in + let mvty = EConstr.Unsafe.to_constr mvty in let mvty = nf_meta sigma mvty in unify_to_type env sigma (set_flags_for_type flags) @@ -1923,7 +1928,6 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let flags = { flags with core_unify_flags = flags.subterm_unify_flags } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in - let typp = EConstr.of_constr typp in let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in if not b then @@ -1942,7 +1946,7 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let evd, pred = abstract_list_all_with_dependencies env evd (EConstr.of_constr typp) typ oplist in + let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in let pred = EConstr.of_constr pred in w_merge env false flags.merge_unify_flags (evd,[p,pred,(Conv,TypeProcessed)],[]) -- cgit v1.2.3 From 485bbfbed4ae4a28119c4e42c5e40fd77abf4f8a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 13 Nov 2016 20:38:41 +0100 Subject: Tactics API using EConstr. --- pretyping/cases.ml | 9 +++------ pretyping/classops.ml | 1 + pretyping/coercion.ml | 2 +- pretyping/detyping.ml | 2 +- pretyping/evarconv.ml | 8 ++++---- pretyping/evardefine.ml | 17 ++++++++++------- pretyping/evarsolve.ml | 13 ++++++------- pretyping/inductiveops.ml | 1 + pretyping/inductiveops.mli | 2 +- pretyping/pretyping.ml | 6 +++--- pretyping/tacred.ml | 8 ++++---- pretyping/tacred.mli | 10 +++++----- pretyping/unification.ml | 9 ++++----- 13 files changed, 44 insertions(+), 44 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 57d12a19f6..360199fecb 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -297,7 +297,7 @@ let inductive_template evdref env tmloc ind = | LocalAssum (na,ty) -> let ty = EConstr.of_constr ty in let ty' = substl subst ty in - let e = EConstr.of_constr (e_new_evar env evdref ~src:(hole_source n) ty') in + let e = e_new_evar env evdref ~src:(hole_source n) ty' in (e::subst,e::evarl,n+1) | LocalDef (na,b,ty) -> let b = EConstr.of_constr b in @@ -380,7 +380,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = - let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in EConstr.of_constr e + let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in e let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in @@ -1663,7 +1663,6 @@ let abstract_tycon loc env evdref subst tycon extenv t = 1 (rel_context env) in let ty = EConstr.of_constr ty in let ev' = e_new_evar env evdref ~src ty in - let ev' = EConstr.of_constr ev' in begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false @@ -1698,7 +1697,6 @@ let abstract_tycon loc env evdref subst tycon extenv t = let candidates = u :: List.map mkRel vl in let candidates = List.map EConstr.Unsafe.to_constr candidates in let ev = e_new_evar extenv evdref ~src ~filter ~candidates ty in - let ev = EConstr.of_constr ev in lift k ev in aux (0,extenv,subst0) t0 @@ -1712,7 +1710,6 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let n' = Context.Rel.length (rel_context tycon_env) in let impossible_case_type, u = e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in - let impossible_case_type = EConstr.of_constr impossible_case_type in (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in @@ -2010,7 +2007,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let Sigma ((t, _), sigma, _) = new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in let sigma = Sigma.to_evar_map sigma in - sigma, EConstr.of_constr t + sigma, t in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 9011186a3d..23d20dad3e 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -51,6 +51,7 @@ type coe_info_typ = { coe_param : int } let coe_info_typ_equal c1 c2 = + let eq_constr c1 c2 = Termops.eq_constr Evd.empty (EConstr.of_constr c1) (EConstr.of_constr c2) in eq_constr c1.coe_value c2.coe_value && eq_constr c1.coe_type c2.coe_type && c1.coe_local == c2.coe_local && diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e7279df7a5..d67976232a 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -93,7 +93,7 @@ open Program let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c = let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in - EConstr.of_constr (Evarutil.e_new_evar env evdref ~src c) + Evarutil.e_new_evar env evdref ~src c let app_opt env evdref f t = EConstr.of_constr (whd_betaiota !evdref (app_opt f t)) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 4756ec30e7..ec8945e85e 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -294,7 +294,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with | na::nal -> match kind_of_term c with | Case (ci,p,c,cl) when - eq_constr c (mkRel (List.index Name.equal na (fst (snd e)))) + eq_constr sigma (EConstr.of_constr c) (EConstr.mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index ee6355736b..a968af7ff2 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -890,7 +890,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) let i = Sigma.Unsafe.of_evar_map i in let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in let i' = Sigma.to_evar_map i' in - (i', EConstr.of_constr ev :: ks, m - 1,test)) + (i', ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in let app = mkApp (c, Array.rev_of_list ks) in @@ -1066,13 +1066,13 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | Some _ -> error "Selection of specific occurrences not supported" | None -> let evty = set_holes evdref cty subst in - let instance = List.map EConstr.Unsafe.to_constr (Filter.filter_list filter instance) in + let instance = Filter.filter_list filter instance in let evd = Sigma.Unsafe.of_evar_map !evdref in let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in let evd = Sigma.to_evar_map evd in evdref := evd; - evsref := (fst (destEvar !evdref (EConstr.of_constr ev)),evty)::!evsref; - EConstr.of_constr ev in + evsref := (fst (destEvar !evdref ev),evty)::!evsref; + ev in set_holes evdref (apply_on_subterm env_rhs evdref set_var c rhs) subst | [] -> rhs in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index fa3b9ca0b7..3babc48a7f 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -22,6 +22,11 @@ open Sigma.Notations module RelDecl = Context.Rel.Declaration +let nlocal_assum (na, t) = + let open Context.Named.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in @@ -88,7 +93,7 @@ let define_pure_evar_as_product evd evk = (Sigma.to_evar_map evd1, e) in let evd2,rng = - let newenv = push_named (LocalAssum (id, dom)) evenv in + let newenv = push_named (nlocal_assum (id, dom)) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in if is_prop_sort s then @@ -105,8 +110,7 @@ let define_pure_evar_as_product evd evk = let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in evd3, rng in - let rng = EConstr.of_constr rng in - let prod = mkProd (Name id, EConstr.of_constr dom, subst_var id rng) in + let prod = mkProd (Name id, dom, subst_var id rng) in let evd3 = Evd.define evk (EConstr.Unsafe.to_constr prod) evd2 in evd3,prod @@ -140,14 +144,13 @@ let define_pure_evar_as_lambda env evd evk = | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd evd typ | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in - let dom = EConstr.Unsafe.to_constr dom in let id = - next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in - let newenv = push_named (LocalAssum (id, dom)) evenv in + next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd (EConstr.Unsafe.to_constr dom)) in + let newenv = push_named (nlocal_assum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in - let lam = mkLambda (Name id, EConstr.of_constr dom, subst_var id (EConstr.of_constr body)) in + let lam = mkLambda (Name id, dom, subst_var id body) in Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam let define_evar_as_lambda env evd (evk,args) = diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index b7db51d5c5..4ce8a44adc 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -518,15 +518,15 @@ let is_unification_pattern (env,nb) evd f l t = let solve_pattern_eqn env sigma l c = let c' = List.fold_right (fun a c -> let c' = subst_term sigma (lift 1 a) (lift 1 c) in + let c' = EConstr.of_constr c' in match EConstr.kind sigma a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> let open Context.Rel.Declaration in let d = map_constr (CVars.lift n) (lookup_rel n env) in - let c' = EConstr.of_constr c' in mkLambda_or_LetIn d c' | Var id -> - let d = lookup_named id env in EConstr.of_constr (mkNamedLambda_or_LetIn d c') + let d = lookup_named id env in mkNamedLambda_or_LetIn d c' | _ -> assert false) l c in (* Warning: we may miss some opportunity to eta-reduce more since c' @@ -592,10 +592,9 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd (EConstr.of_constr ty_t_in_sign) ~filter ~src (List.map EConstr.Unsafe.to_constr inst_in_env) in + let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd (EConstr.of_constr ty_t_in_sign) ~filter ~src inst_in_env in let evd = Sigma.to_evar_map evd in let t_in_env = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr t_in_env)) in - let evar_in_env = EConstr.of_constr evar_in_env in let (evk, _) = destEvar evd evar_in_env in let evd = define_fun env evd None (EConstr.destEvar evd evar_in_env) t_in_env in let ctxt = named_context_of_val sign in @@ -669,10 +668,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let evd = Sigma.Unsafe.of_evar_map evd in let ev2ty_in_sign = EConstr.of_constr ev2ty_in_sign in let Sigma (ev2_in_sign, evd, _) = - new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src (List.map EConstr.Unsafe.to_constr inst2_in_sign) in + new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in let evd = Sigma.to_evar_map evd in - let ev2_in_env = (fst (destEvar evd (EConstr.of_constr ev2_in_sign)), Array.of_list inst2_in_env) in - (evd, EConstr.of_constr ev2_in_sign, ev2_in_env) + let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in + (evd, ev2_in_sign, ev2_in_env) let restrict_upon_filter evd evk p args = let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index e30ba21fd1..98b267cfd4 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -556,6 +556,7 @@ let set_pattern_names env ind brv = let type_case_branches_with_names env sigma indspec p c = let (ind,args) = indspec in + let args = List.map EConstr.Unsafe.to_constr args in let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let (params,realargs) = List.chop nparams args in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index cf5523a50d..7af9731f9a 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -175,7 +175,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : - env -> evar_map -> pinductive * constr list -> constr -> constr -> types array * types + env -> evar_map -> pinductive * EConstr.constr list -> constr -> constr -> types array * types (** Annotation for cases *) val make_case_info : env -> inductive -> case_style -> case_info diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 49a0bccee9..7586b54ba1 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -116,7 +116,7 @@ let lookup_named id env = lookup_named id env.env let e_new_evar env evdref ?src ?naming typ = let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in let open Context.Named.Declaration in - let inst_vars = List.map (get_id %> Constr.mkVar) (named_context env.env) in + let inst_vars = List.map (get_id %> EConstr.mkVar) (named_context env.env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in let (subst, vsubst, _, nc) = Lazy.force env.extra in let typ' = subst2 subst vsubst typ in @@ -125,7 +125,7 @@ let e_new_evar env evdref ?src ?naming typ = let sigma = Sigma.Unsafe.of_evar_map !evdref in let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in evdref := Sigma.to_evar_map sigma; - EConstr.of_constr e + e let push_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> local_assum (na, lift i t)) lna typarray in @@ -546,7 +546,7 @@ let new_type_evar env evdref loc = univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) in evdref := Sigma.to_evar_map sigma; - EConstr.of_constr e + e let (f_genarg_interp, genarg_interp_hook) = Hook.make () diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 24d4af89a6..1ec8deb1b5 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1196,7 +1196,7 @@ let reduce_to_ind_gen allow_product env sigma t = let t = hnf_constr env sigma t in let t = EConstr.of_constr t in match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t))) with - | Ind ind-> (check_privacy env ind, EConstr.Unsafe.to_constr (it_mkProd_or_LetIn t l)) + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> let open Context.Rel.Declaration in if allow_product then @@ -1209,7 +1209,7 @@ let reduce_to_ind_gen allow_product env sigma t = let t' = whd_all env sigma t in let t' = EConstr.of_constr t' in match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t'))) with - | Ind ind-> (check_privacy env ind, EConstr.Unsafe.to_constr (it_mkProd_or_LetIn t' l)) + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) | _ -> user_err (str"Not an inductive product.") in elimrec env t [] @@ -1219,7 +1219,7 @@ let reduce_to_atomic_ind env sigma c = reduce_to_ind_gen false env sigma c let find_hnf_rectype env sigma t = let ind,t = reduce_to_atomic_ind env sigma t in - ind, snd (Term.decompose_app t) + ind, snd (decompose_app sigma t) (* Reduce the weak-head redex [beta,iota/fix/cofix[all],cast,zeta,simpl/delta] or raise [NotStepReducible] if not a weak-head redex *) @@ -1295,7 +1295,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = elimrec env t' l with NotStepReducible -> error_cannot_recognize ref in - EConstr.Unsafe.to_constr (elimrec env t []) + elimrec env t [] let reduce_to_quantified_ref = reduce_to_ref_gen true let reduce_to_atomic_ref = reduce_to_ref_gen false diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 3587ae2810..15b4e990d8 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -75,23 +75,23 @@ val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> EConstr.types -> pinductive * types +val reduce_to_atomic_ind : env -> evar_map -> EConstr.types -> pinductive * EConstr.types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> EConstr.types -> pinductive * types +val reduce_to_quantified_ind : env -> evar_map -> EConstr.types -> pinductive * EConstr.types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) val reduce_to_quantified_ref : - env -> evar_map -> global_reference -> EConstr.types -> types + env -> evar_map -> global_reference -> EConstr.types -> EConstr.types val reduce_to_atomic_ref : - env -> evar_map -> global_reference -> EConstr.types -> types + env -> evar_map -> global_reference -> EConstr.types -> EConstr.types val find_hnf_rectype : - env -> evar_map -> EConstr.types -> pinductive * constr list + env -> evar_map -> EConstr.types -> pinductive * EConstr.constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 2b2069ec45..bc59a41087 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -133,14 +133,14 @@ let abstract_list_all_with_dependencies env evd typ c l = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (ev, evd, _) = new_evar env evd typ in let evd = Sigma.to_evar_map evd in - let evd,ev' = evar_absorb_arguments env evd (destEvar evd (EConstr.of_constr ev)) l in + let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in if b then - let p = nf_evar evd ev in + let p = nf_evar evd (EConstr.Unsafe.to_constr ev) in evd, p else error_cannot_find_well_typed_abstraction env evd c l None @@ -184,8 +184,8 @@ let pose_all_metas_as_evars env evd t = let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in let src = Evd.evar_source_of_meta mv !evdref in let ev = Evarutil.e_new_evar env evdref ~src ty in - evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref; - EConstr.of_constr ev) + evdref := meta_assign mv (EConstr.Unsafe.to_constr ev,(Conv,TypeNotProcessed)) !evdref; + ev) | _ -> EConstr.map !evdref aux t in let c = aux t in @@ -1236,7 +1236,6 @@ let applyHead env (type r) (evd : r Sigma.t) n c = match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma cty)) with | Prod (_,c1,c2) -> let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in - let evar = EConstr.of_constr evar in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' | _ -> error "Apply_Head_Then" in -- cgit v1.2.3 From db252cb87e9c63f400fd4fddd2d771df3160d592 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 01:07:35 +0100 Subject: Inv API using EConstr. --- pretyping/nativenorm.ml | 2 ++ pretyping/recordops.ml | 4 +++- pretyping/reductionops.ml | 11 ++++++----- pretyping/reductionops.mli | 6 +++--- pretyping/vnorm.ml | 2 ++ 5 files changed, 16 insertions(+), 9 deletions(-) (limited to 'pretyping') diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index ff3424c44b..cdaa4e9eee 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -99,6 +99,8 @@ let build_branches_type env sigma (mind,_ as _ind) mib mip u params dep p = let build_one_branch i cty = let typi = type_constructor mind mib u cty params in let decl,indapp = Reductionops.splay_prod env sigma (EConstr.of_constr typi) in + let decl = List.map (on_snd EConstr.Unsafe.to_constr) decl in + let indapp = EConstr.Unsafe.to_constr indapp in let decl_with_letin,_ = decompose_prod_assum typi in let ind,cargs = find_rectype_a env indapp in let nparams = Array.length params in diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index f09f3221d9..3230f92da8 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -203,7 +203,8 @@ let compute_canonical_projections warn (con,ind) = let ctx = Univ.ContextSet.of_context ctx in let c = Environ.constant_value_in env (con,u) in let lt,t = Reductionops.splay_lam env Evd.empty (EConstr.of_constr c) in - let lt = List.rev_map snd lt in + let t = EConstr.Unsafe.to_constr t in + let lt = List.rev_map (snd %> EConstr.Unsafe.to_constr) lt in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = lookup_structure ind in @@ -303,6 +304,7 @@ let check_and_decompose_canonical_structure ref = | Some vc -> vc | None -> error_not_structure ref in let body = snd (splay_lam (Global.env()) Evd.empty (EConstr.of_constr vc)) (** FIXME *) in + let body = EConstr.Unsafe.to_constr body in let f,args = match kind_of_term body with | App (f,args) -> f,args | _ -> error_not_structure ref in diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0dd615bfb7..480ec23192 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1453,13 +1453,13 @@ let hnf_lam_applist env sigma t nl = List.fold_left (fun acc t -> hnf_lam_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl let bind_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - (na, inj t) + (na, t) let splay_prod env sigma = let rec decrec env m c = let t = whd_all env sigma c in - match EConstr.kind sigma (EConstr.of_constr t) with + let t = EConstr.of_constr t in + match EConstr.kind sigma t with | Prod (n,a,c0) -> decrec (push_rel (local_assum (n,a)) env) (bind_assum (n,a)::m) c0 @@ -1470,7 +1470,8 @@ let splay_prod env sigma = let splay_lam env sigma = let rec decrec env m c = let t = whd_all env sigma c in - match EConstr.kind sigma (EConstr.of_constr t) with + let t = EConstr.of_constr t in + match EConstr.kind sigma t with | Lambda (n,a,c0) -> decrec (push_rel (local_assum (n,a)) env) (bind_assum (n,a)::m) c0 @@ -1498,7 +1499,7 @@ let splay_prod_assum env sigma = let splay_arity env sigma c = let l, c = splay_prod env sigma c in - match EConstr.kind sigma (EConstr.of_constr c) with + match EConstr.kind sigma c with | Sort s -> l,s | _ -> invalid_arg "splay_arity" diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 864b1a625c..e67fad3fd4 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -213,9 +213,9 @@ val hnf_lam_app : env -> evar_map -> EConstr.t -> EConstr.t -> constr val hnf_lam_appvect : env -> evar_map -> EConstr.t -> EConstr.t array -> constr val hnf_lam_applist : env -> evar_map -> EConstr.t -> EConstr.t list -> constr -val splay_prod : env -> evar_map -> EConstr.t -> (Name.t * constr) list * constr -val splay_lam : env -> evar_map -> EConstr.t -> (Name.t * constr) list * constr -val splay_arity : env -> evar_map -> EConstr.t -> (Name.t * constr) list * sorts +val splay_prod : env -> evar_map -> EConstr.t -> (Name.t * EConstr.constr) list * EConstr.constr +val splay_lam : env -> evar_map -> EConstr.t -> (Name.t * EConstr.constr) list * EConstr.constr +val splay_arity : env -> evar_map -> EConstr.t -> (Name.t * EConstr.constr) list * sorts val sort_of_arity : env -> evar_map -> EConstr.t -> sorts val splay_prod_n : env -> evar_map -> int -> EConstr.t -> Context.Rel.t * constr val splay_lam_n : env -> evar_map -> int -> EConstr.t -> Context.Rel.t * constr diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 60f99fd3d8..31693d82f7 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -106,6 +106,8 @@ let build_branches_type env sigma (mind,_ as _ind) mib mip u params dep p = let build_one_branch i cty = let typi = type_constructor mind mib u cty params in let decl,indapp = Reductionops.splay_prod env sigma (EConstr.of_constr typi) in + let decl = List.map (on_snd EConstr.Unsafe.to_constr) decl in + let indapp = EConstr.Unsafe.to_constr indapp in let decl_with_letin,_ = decompose_prod_assum typi in let ((ind,u),cargs) = find_rectype_a env indapp in let nparams = Array.length params in -- cgit v1.2.3 From 7b43de20a4acd7c9da290f038d9a16fe67eccd59 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 01:59:07 +0100 Subject: Leminv API using EConstr. --- pretyping/cases.ml | 14 ++++---------- pretyping/inductiveops.ml | 14 ++++++++------ pretyping/inductiveops.mli | 12 ++++++------ pretyping/pretyping.ml | 1 - pretyping/retyping.ml | 2 +- 5 files changed, 19 insertions(+), 24 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 360199fecb..119e92c82e 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -326,7 +326,7 @@ let inh_coerce_to_ind evdref env loc ty tyi = let binding_vars_of_inductive sigma = function | NotInd _ -> [] - | IsInd (_,IndType(_,realargs),_) -> List.filter (isRel sigma) (List.map EConstr.of_constr realargs) + | IsInd (_,IndType(_,realargs),_) -> List.filter (isRel sigma) realargs let extract_inductive_data env sigma decl = match decl with @@ -422,7 +422,7 @@ let type_of_tomatch = function | NotInd (_,t) -> t let map_tomatch_type f = function - | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type (fun c -> EConstr.Unsafe.to_constr (f (EConstr.of_constr c))) ind,names) + | IsInd (t,ind,names) -> IsInd (f t,map_inductive_type f ind,names) | NotInd (c,t) -> NotInd (Option.map f c, f t) let liftn_tomatch_type n depth = map_tomatch_type (Vars.liftn n depth) @@ -873,7 +873,7 @@ let specialize_predicate_var (cur,typ,dep) tms ccl = let l = match typ with | IsInd (_, IndType (_, _), []) -> [] - | IsInd (_, IndType (_, realargs), names) -> List.map EConstr.of_constr realargs + | IsInd (_, IndType (_, realargs), names) -> realargs | NotInd _ -> [] in subst_predicate (l,c) ccl tms @@ -922,7 +922,7 @@ let rec extract_predicate ccl = function subst1 cur pred end | Pushed (_,((cur,IsInd (_,IndType(_,realargs),_)),_,na))::tms -> - let realargs = List.rev_map EConstr.of_constr realargs in + let realargs = List.rev realargs in let k, nrealargs = match na with | Anonymous -> 0, realargs | Name _ -> 1, (cur :: realargs) @@ -1064,7 +1064,6 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = snd (List.fold_left (expand_arg tms) (1,ccl''') newtomatchs) let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms = - let realargs = List.map EConstr.of_constr realargs in let pred = abstract_predicate env !evdref indf current realargs dep tms p in (pred, EConstr.of_constr (whd_betaiota !evdref (applist (pred, realargs@[current])))) @@ -1384,7 +1383,6 @@ and match_current pb (initial,tomatch) = if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then compile_all_variables initial tomatch pb else - let realargs = List.map EConstr.of_constr realargs in (* We generalize over terms depending on current term to match *) let pb,deps = generalize_problem (names,dep) pb deps in @@ -1749,7 +1747,6 @@ let build_inversion_problem loc env sigma tms t = match tms with | [] -> [], acc_sign, acc | (t, IsInd (_,IndType(indf,realargs),_)) :: tms -> - let realargs = List.map EConstr.of_constr realargs in let patl,acc = List.fold_map' reveal_pattern realargs acc in let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in @@ -1919,7 +1916,6 @@ let prepare_predicate_from_arsign_tycon env sigma loc tomatchs arsign c = (match tmtype with NotInd _ -> (subst, len - signlen) | IsInd (_, IndType(indf,realargs),_) -> - let realargs = List.map EConstr.of_constr realargs in let subst, len = List.fold_left (fun (subst, len) arg -> @@ -2119,7 +2115,6 @@ let constr_of_pat env evdref arsign pat avoid = let apptype = Retyping.get_type_of env ( !evdref) app in let apptype = EConstr.of_constr apptype in let IndType (indf, realargs) = find_rectype env (!evdref) apptype in - let realargs = List.map EConstr.of_constr realargs in match alias with Anonymous -> pat', sign, app, apptype, realargs, n, avoid @@ -2364,7 +2359,6 @@ let build_dependent_signature env evdref avoid tomatchs arsign = *) match ty with | IsInd (ty, IndType (indf, args), _) when List.length args > 0 -> - let args = List.map EConstr.of_constr args in (* Build the arity signature following the names in matched terms as much as possible *) let argsign = List.tl arsign in (* arguments in inverse application order *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 98b267cfd4..cb8b253232 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -58,21 +58,23 @@ let lift_inductive_family n = liftn_inductive_family n 1 let substnl_ind_family l n = map_ind_family (substnl l n) -type inductive_type = IndType of inductive_family * constr list +type inductive_type = IndType of inductive_family * EConstr.constr list let make_ind_type (indf, realargs) = IndType (indf,realargs) let dest_ind_type (IndType (indf,realargs)) = (indf,realargs) let map_inductive_type f (IndType (indf, realargs)) = - IndType (map_ind_family f indf, List.map f realargs) + let f' c = EConstr.Unsafe.to_constr (f (EConstr.of_constr c)) in + IndType (map_ind_family f' indf, List.map f realargs) -let liftn_inductive_type n d = map_inductive_type (liftn n d) +let liftn_inductive_type n d = map_inductive_type (EConstr.Vars.liftn n d) let lift_inductive_type n = liftn_inductive_type n 1 -let substnl_ind_type l n = map_inductive_type (substnl l n) +let substnl_ind_type l n = map_inductive_type (EConstr.Vars.substnl l n) let mkAppliedInd (IndType ((ind,params), realargs)) = - applist (mkIndU ind,params@realargs) + let open EConstr in + applist (mkIndU ind, (List.map EConstr.of_constr params)@realargs) (* Does not consider imbricated or mutually recursive types *) let mis_is_recursive_subset listind rarg = @@ -471,7 +473,7 @@ let find_rectype env sigma c = if mib.mind_nparams > List.length l then raise Not_found; let l = List.map EConstr.Unsafe.to_constr l in let (par,rargs) = List.chop mib.mind_nparams l in - IndType((indu, par),rargs) + IndType((indu, par),List.map EConstr.of_constr rargs) | _ -> raise Not_found let find_inductive env sigma c = diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 7af9731f9a..1614e1817e 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -37,15 +37,15 @@ val substnl_ind_family : constr list -> int -> inductive_family -> inductive_family (** An inductive type with its parameters and real arguments *) -type inductive_type = IndType of inductive_family * constr list -val make_ind_type : inductive_family * constr list -> inductive_type -val dest_ind_type : inductive_type -> inductive_family * constr list -val map_inductive_type : (constr -> constr) -> inductive_type -> inductive_type +type inductive_type = IndType of inductive_family * EConstr.constr list +val make_ind_type : inductive_family * EConstr.constr list -> inductive_type +val dest_ind_type : inductive_type -> inductive_family * EConstr.constr list +val map_inductive_type : (EConstr.constr -> EConstr.constr) -> inductive_type -> inductive_type val liftn_inductive_type : int -> int -> inductive_type -> inductive_type val lift_inductive_type : int -> inductive_type -> inductive_type -val substnl_ind_type : constr list -> int -> inductive_type -> inductive_type +val substnl_ind_type : EConstr.constr list -> int -> inductive_type -> inductive_type -val mkAppliedInd : inductive_type -> constr +val mkAppliedInd : inductive_type -> EConstr.constr val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : inductive * mutual_inductive_body * one_inductive_body -> bool diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 7586b54ba1..11d50926f4 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -860,7 +860,6 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let cloc = loc_of_glob_constr c in error_case_not_inductive ~loc:cloc env.ExtraEnv.env !evdref cj in - let realargs = List.map EConstr.of_constr realargs in let cstrs = get_constructors env.ExtraEnv.env indf in if not (Int.equal (Array.length cstrs) 1) then user_err ~loc (str "Destructing let is only for inductive types" ++ diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 6f03fc462a..88899e633e 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -123,7 +123,7 @@ let retype ?(polyprop=true) sigma = with Not_found -> retype_error BadRecursiveType in let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in - let t = EConstr.of_constr (betazetaevar_applist sigma n p (List.map EConstr.of_constr realargs)) in + let t = EConstr.of_constr (betazetaevar_applist sigma n p realargs) in (match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma (type_of env t))) with | Prod _ -> EConstr.of_constr (whd_beta sigma (applist (t, [c]))) | _ -> t) -- cgit v1.2.3 From 34e86e839be251717db96f1f5969d7724ab43097 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 02:45:54 +0100 Subject: Hints API using EConstr. --- pretyping/evarsolve.ml | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4ce8a44adc..7725719261 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1612,12 +1612,14 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = * ass. *) -let status_changed lev (pbty,_,t1,t2) = - (try Evar.Set.mem (head_evar t1) lev with NoHeadEvar -> false) || - (try Evar.Set.mem (head_evar t2) lev with NoHeadEvar -> false) +let status_changed evd lev (pbty,_,t1,t2) = + let t1 = EConstr.of_constr t1 in + let t2 = EConstr.of_constr t2 in + (try Evar.Set.mem (head_evar evd t1) lev with NoHeadEvar -> false) || + (try Evar.Set.mem (head_evar evd t2) lev with NoHeadEvar -> false) let reconsider_conv_pbs conv_algo evd = - let (evd,pbs) = extract_changed_conv_pbs evd status_changed in + let (evd,pbs) = extract_changed_conv_pbs evd (status_changed evd) in List.fold_left (fun p (pbty,env,t1,t2 as x) -> match p with -- cgit v1.2.3 From 67507df457be05ee5b651a423031a8cd584934ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 00:35:43 +0100 Subject: Class_tactics API using EConstr. --- pretyping/typeclasses.mli | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'pretyping') diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index ec36c57e04..e95aba695d 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -103,7 +103,7 @@ val is_class_type : evar_map -> EConstr.types -> bool val resolve_typeclasses : ?fast_path:bool -> ?filter:evar_filter -> ?unique:bool -> ?split:bool -> ?fail:bool -> env -> evar_map -> evar_map -val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> EConstr.types -> open_constr +val resolve_one_typeclass : ?unique:bool -> env -> evar_map -> EConstr.types -> evar_map * EConstr.constr val set_typeclass_transparency_hook : (evaluable_global_reference -> bool (*local?*) -> bool -> unit) Hook.t val set_typeclass_transparency : evaluable_global_reference -> bool -> bool -> unit @@ -120,7 +120,7 @@ val add_instance_hint : global_reference_or_constr -> global_reference list -> val remove_instance_hint : global_reference -> unit val solve_all_instances_hook : (env -> evar_map -> evar_filter -> bool -> bool -> bool -> evar_map) Hook.t -val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> open_constr) Hook.t +val solve_one_instance_hook : (env -> evar_map -> EConstr.types -> bool -> evar_map * EConstr.constr) Hook.t val declare_instance : int option -> bool -> global_reference -> unit -- cgit v1.2.3 From e6a8ab0f428c26fff2bd7e636126974f167101bf Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 01:35:54 +0100 Subject: Tactic_matching API using EConstr. --- pretyping/constr_matching.ml | 11 +++++------ pretyping/constr_matching.mli | 2 +- pretyping/detyping.ml | 1 + pretyping/patternops.ml | 4 +++- pretyping/pretyping.ml | 2 +- 5 files changed, 11 insertions(+), 9 deletions(-) (limited to 'pretyping') diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 4d2500ccd6..06daa5116a 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -16,6 +16,7 @@ open Nameops open Termops open Reductionops open Term +open EConstr open Vars open Pattern open Patternops @@ -61,11 +62,11 @@ let constrain sigma n (ids, m) (names, terms as subst) = let open EConstr in try let (ids', m') = Id.Map.find n terms in - if List.equal Id.equal ids ids' && eq_constr sigma m (EConstr.of_constr m') then subst + if List.equal Id.equal ids ids' && eq_constr sigma m m' then subst else raise PatternMatchingFailure with Not_found -> let () = if Id.Map.mem n names then warn_meta_collision n in - (names, Id.Map.add n (ids, EConstr.Unsafe.to_constr m) terms) + (names, Id.Map.add n (ids, m) terms) let add_binders na1 na2 binding_vars (names, terms as subst) = match na1, na2 with @@ -152,7 +153,6 @@ let merge_binding sigma allow_bound_rels ctx n cT subst = | [] -> (* Optimization *) ([], cT) | _ -> - let open EConstr in let frels = free_rels sigma cT in if allow_bound_rels then let vars = extract_bound_vars frels ctx in @@ -344,7 +344,7 @@ type matching_result = { m_sub : bound_ident_map * patvar_map; m_ctx : constr; } -let mkresult s c n = IStream.Cons ( { m_sub=s; m_ctx=EConstr.Unsafe.to_constr c; } , (IStream.thunk n) ) +let mkresult s c n = IStream.Cons ( { m_sub=s; m_ctx=c; } , (IStream.thunk n) ) let isPMeta = function PMeta _ -> true | _ -> false @@ -362,10 +362,9 @@ let matches_head env sigma pat c = (* Tells if it is an authorized occurrence and if the instance is closed *) let authorized_occ env sigma partial_app closed pat c mk_ctx = - let open EConstr in try let subst = matches_core_closed env sigma false partial_app pat c in - if closed && Id.Map.exists (fun _ c -> not (closed0 c)) (snd subst) + if closed && Id.Map.exists (fun _ c -> not (closed0 sigma c)) (snd subst) then (fun next -> next ()) else (fun next -> mkresult subst (mk_ctx (mkMeta special_meta)) next) with PatternMatchingFailure -> (fun next -> next ()) diff --git a/pretyping/constr_matching.mli b/pretyping/constr_matching.mli index 32bb48c937..4734c90a87 100644 --- a/pretyping/constr_matching.mli +++ b/pretyping/constr_matching.mli @@ -64,7 +64,7 @@ val matches_conv : env -> Evd.evar_map -> constr_pattern -> constr -> patvar_map (whose hole is denoted here with [special_meta]) *) type matching_result = { m_sub : bound_ident_map * patvar_map; - m_ctx : Constr.t } + m_ctx : EConstr.t } (** [match_subterm n pat c] returns the substitution and the context corresponding to each **closed** subterm of [c] matching [pat]. *) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index ec8945e85e..c0611dcec8 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -745,6 +745,7 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = with Not_found -> try (* assumes [detype] does not raise [Not_found] exceptions *) let (b,c) = Id.Map.find id cl.typed in + let c = EConstr.Unsafe.to_constr c in (* spiwack: I'm not sure it is the right thing to do, but I'm computing the detyping environment like [Printer.pr_constr_under_binders_env] does. *) diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index ffd6e73faa..26e23be23c 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -224,6 +224,8 @@ let error_instantiate_pattern id l = ++ strbrk " which " ++ str is ++ strbrk " not bound in the pattern.") let instantiate_pattern env sigma lvar c = + let open EConstr in + let open Vars in let rec aux vars = function | PVar id as x -> (try @@ -235,7 +237,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - pattern_of_constr env sigma (EConstr.of_constr c) + pattern_of_constr env sigma c with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 11d50926f4..c792bf2ca9 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -445,7 +445,7 @@ let pretype_id pretype k0 loc env evdref lvar id = try let (ids,c) = Id.Map.find id lvar.ltac_constrs in let subst = List.map (invert_ltac_bound_name lvar env id) ids in - let c = substl subst (EConstr.of_constr c) in + let c = substl subst c in { uj_val = c; uj_type = protected_get_type_of env sigma c } with Not_found -> try let {closure;term} = Id.Map.find id lvar.ltac_uconstrs in -- cgit v1.2.3 From d833b81b49366e95cf20a1d00f9c63883adb8942 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 03:04:13 +0100 Subject: Rewrite API using EConstr. --- pretyping/reductionops.ml | 3 ++- pretyping/reductionops.mli | 2 +- pretyping/unification.ml | 10 ++++++---- 3 files changed, 9 insertions(+), 6 deletions(-) (limited to 'pretyping') diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 480ec23192..31354217fd 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1592,8 +1592,9 @@ let meta_instance sigma b = EConstr.of_constr (instance sigma c_sigma b.rebus) let nf_meta sigma c = + let c = EConstr.Unsafe.to_constr c in let cl = mk_freelisted c in - EConstr.Unsafe.to_constr (meta_instance sigma { cl with rebus = EConstr.of_constr cl.rebus }) + meta_instance sigma { cl with rebus = EConstr.of_constr cl.rebus } (* Instantiate metas that create beta/iota redexes *) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index e67fad3fd4..1e6527b297 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -296,5 +296,5 @@ val whd_betaiota_deltazeta_for_iota_state : (** {6 Meta-related reduction functions } *) val meta_instance : evar_map -> EConstr.constr freelisted -> EConstr.constr -val nf_meta : evar_map -> constr -> constr +val nf_meta : evar_map -> EConstr.constr -> EConstr.constr val meta_reducible_instance : evar_map -> EConstr.constr freelisted -> EConstr.constr diff --git a/pretyping/unification.ml b/pretyping/unification.ml index bc59a41087..81d9ecad50 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1272,13 +1272,15 @@ let w_coerce env evd mv c = let unify_to_type env sigma flags c status u = let sigma, c = refresh_universes (Some false) env sigma c in - let t = get_type_of env sigma (EConstr.of_constr (nf_meta sigma c)) in - let t = nf_betaiota sigma (EConstr.of_constr (nf_meta sigma t)) in - unify_0 env sigma CUMUL flags (EConstr.of_constr t) (EConstr.of_constr u) + let c = EConstr.of_constr c in + let t = get_type_of env sigma (nf_meta sigma c) in + let t = EConstr.of_constr t in + let t = nf_betaiota sigma (nf_meta sigma t) in + let t = EConstr.of_constr t in + unify_0 env sigma CUMUL flags t u let unify_type env sigma flags mv status c = let mvty = Typing.meta_type sigma mv in - let mvty = EConstr.Unsafe.to_constr mvty in let mvty = nf_meta sigma mvty in unify_to_type env sigma (set_flags_for_type flags) -- cgit v1.2.3 From d4b344acb23f19b089098b7788f37ea22bc07b81 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 20:09:26 +0100 Subject: Eliminating parts of the right-hand side compatibility layer --- pretyping/cases.ml | 2 +- pretyping/coercion.ml | 4 ++-- pretyping/constr_matching.ml | 2 +- pretyping/detyping.ml | 3 ++- pretyping/evarconv.ml | 6 +++--- pretyping/evarsolve.ml | 14 ++++++-------- pretyping/inductiveops.ml | 4 ++-- pretyping/inductiveops.mli | 6 +++--- pretyping/pretyping.ml | 3 +-- pretyping/reductionops.ml | 14 +++++++------- pretyping/reductionops.mli | 2 +- pretyping/retyping.ml | 11 +++++------ pretyping/tacred.ml | 14 ++++---------- pretyping/typeclasses.ml | 8 ++++---- pretyping/typing.ml | 3 +-- pretyping/unification.ml | 13 ++++--------- 16 files changed, 47 insertions(+), 62 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 119e92c82e..76ced2b1d6 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -2335,7 +2335,7 @@ let abstract_tomatch env sigma tomatchs tycon = Rel n -> (lift lenctx c, lift_tomatch_type lenctx t) :: prev, ctx, names, tycon | _ -> let tycon = Option.map - (fun t -> EConstr.of_constr (subst_term sigma (lift 1 c) (lift 1 t))) tycon in + (fun t -> subst_term sigma (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, local_def (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index d67976232a..48f7be4bbb 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -502,8 +502,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in let t2 = match v2 with | None -> subst_term evd' v1 t2 - | Some v2 -> Retyping.get_type_of env1 evd' (EConstr.of_constr v2) in - let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly (Option.map EConstr.of_constr v2) (EConstr.of_constr t2) u2 in + | Some v2 -> EConstr.of_constr (Retyping.get_type_of env1 evd' v2) in + let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 06daa5116a..55612aa665 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -185,7 +185,7 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels else false) in let rec sorec ctx env subst p t = - let cT = EConstr.of_constr (strip_outer_cast sigma t) in + let cT = strip_outer_cast sigma t in match p, EConstr.kind sigma cT with | PSoApp (n,args),m -> let fold (ans, seen) = function diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index c0611dcec8..87561868f7 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -267,7 +267,7 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = | [] -> (List.rev nal,(e,c)) | b::tags -> let na,c,f,body,t = - match kind_of_term (strip_outer_cast sigma (EConstr.of_constr c)), b with + match kind_of_term (EConstr.Unsafe.to_constr (strip_outer_cast sigma (EConstr.of_constr c))), b with | Lambda (na,t,c),false -> na,c,compute_displayed_let_name_in,None,Some t | LetIn (na,b,t,c),true -> na,c,compute_displayed_name_in,Some b,Some t @@ -503,6 +503,7 @@ let rec detype flags avoid env sigma t = let body = pb.Declarations.proj_body in let ty = Retyping.get_type_of (snd env) sigma (EConstr.of_constr c) in let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma (EConstr.of_constr ty) in + let args = List.map EConstr.Unsafe.to_constr args in let body' = strip_lam_assum body in let body' = subst_instance_constr u body' in substl (c :: List.rev args) body' diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a968af7ff2..9675ae2ea9 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -170,7 +170,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let (i,u), ind_args = try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with _ -> raise Not_found - in Stack.append_app_list (List.map EConstr.of_constr ind_args) Stack.empty, c, sk1 + in Stack.append_app_list ind_args Stack.empty, c, sk1 | None -> match Stack.strip_n_app nparams sk1 with | Some (params1, c1, extra_args1) -> params1, c1, extra_args1 @@ -188,7 +188,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let t' = subst_univs_level_constr subst t' in let bs' = List.map (EConstr.of_constr %> subst_univs_level_constr subst) bs in let h, _ = decompose_app_vect sigma t' in - ctx',(EConstr.of_constr h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), + ctx',(h, t2),c',bs',(Stack.append_app_list params Stack.empty,params1), (Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, (n, Stack.zip sigma (t2,sk2)) @@ -907,7 +907,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) (fun i -> exact_ise_stack2 env i (evar_conv_x trs) sk1 sk2); test; (fun i -> evar_conv_x trs env i CONV h2 - (EConstr.of_constr (fst (decompose_app_vect i (substl ks h)))))] + (fst (decompose_app_vect i (substl ks h))))] else UnifFailure(evd,(*dummy*)NotSameHead) and eta_constructor ts env evd sk1 ((ind, i), u) sk2 term2 = diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 7725719261..65b6d287d5 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -518,7 +518,6 @@ let is_unification_pattern (env,nb) evd f l t = let solve_pattern_eqn env sigma l c = let c' = List.fold_right (fun a c -> let c' = subst_term sigma (lift 1 a) (lift 1 c) in - let c' = EConstr.of_constr c' in match EConstr.kind sigma a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> @@ -557,7 +556,7 @@ let make_projectable_subst aliases sigma evi args = | LocalAssum (id,c), a::rest -> let cstrs = let a',args = decompose_app_vect sigma a in - match EConstr.kind sigma (EConstr.of_constr a') with + match EConstr.kind sigma a' with | Construct cstr -> let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in Constrmap.add (fst cstr) ((args,id)::l) cstrs @@ -691,7 +690,7 @@ let find_projectable_constructor env evd cstr k args cstr_subst = List.filter (fun (args',id) -> (* is_conv is maybe too strong (and source of useless computation) *) (* (at least expansion of aliases is needed) *) - Array.for_all2 (fun c1 c2 -> is_conv env evd c1 (EConstr.of_constr c2)) args args') l in + Array.for_all2 (fun c1 c2 -> is_conv env evd c1 c2) args args') l in List.map snd l with Not_found -> [] @@ -1104,14 +1103,14 @@ exception CannotProject of evar_map * EConstr.existential let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect evd t in - match EConstr.kind evd (EConstr.of_constr f) with + match EConstr.kind evd f with | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in if n > Array.length args then true (* We don't try to be more clever *) else let params = fst (Array.chop n args) in - Array.for_all (EConstr.of_constr %> is_constrainable_in false evd k g) params - | Ind _ -> Array.for_all (EConstr.of_constr %> is_constrainable_in false evd k g) args + Array.for_all (is_constrainable_in false evd k g) params + | Ind _ -> Array.for_all (is_constrainable_in false evd k g) args | Prod (na,t1,t2) -> is_constrainable_in false evd k g t1 && is_constrainable_in false evd k g t2 | Evar (ev',_) -> top || not (Evar.equal ev' ev) (*If ev' needed, one may also try to restrict it*) | Var id -> Id.Set.mem id fv_ids @@ -1463,8 +1462,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = progress := true; match let c,args = decompose_app_vect !evdref t in - let args = Array.map EConstr.of_constr args in - match EConstr.kind !evdref (EConstr.of_constr c) with + match EConstr.kind !evdref c with | Construct (cstr,u) when noccur_between !evdref 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index cb8b253232..9c5a2e894a 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -451,13 +451,13 @@ let extract_mrectype sigma t = let open EConstr in let (t, l) = decompose_app sigma t in match EConstr.kind sigma t with - | Ind ind -> (ind, List.map EConstr.Unsafe.to_constr l) + | Ind ind -> (ind, l) | _ -> raise Not_found let find_mrectype_vect env sigma c = let open EConstr in let (t, l) = Termops.decompose_app_vect sigma (EConstr.of_constr (whd_all env sigma c)) in - match EConstr.kind sigma (EConstr.of_constr t) with + match EConstr.kind sigma t with | Ind ind -> (ind, l) | _ -> raise Not_found diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 1614e1817e..4bb4847591 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -161,9 +161,9 @@ val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given a valid inductive type *) -val extract_mrectype : evar_map -> EConstr.t -> pinductive * constr list -val find_mrectype : env -> evar_map -> EConstr.types -> pinductive * constr list -val find_mrectype_vect : env -> evar_map -> EConstr.types -> pinductive * constr array +val extract_mrectype : evar_map -> EConstr.t -> pinductive * EConstr.constr list +val find_mrectype : env -> evar_map -> EConstr.types -> pinductive * EConstr.constr list +val find_mrectype_vect : env -> evar_map -> EConstr.types -> pinductive * EConstr.constr array val find_rectype : env -> evar_map -> EConstr.types -> inductive_type val find_inductive : env -> evar_map -> EConstr.types -> pinductive * constr list val find_coinductive : env -> evar_map -> EConstr.types -> pinductive * constr list diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c792bf2ca9..f814028f98 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -971,7 +971,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (EConstr.of_constr (beta_applist !evdref (pred,[cj.uj_val]))) in + let typ = lift (- nar) (beta_applist !evdref (pred,[cj.uj_val])) in pred, typ | None -> let p = match tycon with @@ -987,7 +987,6 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in - let pi = EConstr.of_constr pi in let csgn = if not !allow_anonymous_refs then List.map (set_name Anonymous) cs.cs_args diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 31354217fd..6ec3cd985c 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -669,7 +669,7 @@ let beta_app sigma (c,l) = let beta_applist sigma (c,l) = let zip s = Stack.zip sigma s in - EConstr.Unsafe.to_constr (stacklam zip [] sigma c (Stack.append_app_list l Stack.empty)) + stacklam zip [] sigma c (Stack.append_app_list l Stack.empty) (* Iota reduction tools *) @@ -1611,8 +1611,8 @@ let meta_reducible_instance evd b = let u = whd_betaiota Evd.empty u (** FIXME *) in let u = EConstr.of_constr u in match EConstr.kind evd u with - | Case (ci,p,c,bl) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd c)) -> - let m = destMeta evd (EConstr.of_constr (strip_outer_cast evd c)) in + | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> + let m = destMeta evd (strip_outer_cast evd c) in (match try let g, s = Metamap.find m metas in @@ -1623,8 +1623,8 @@ let meta_reducible_instance evd b = with | Some g -> irec (mkCase (ci,p,g,bl)) | None -> mkCase (ci,irec p,c,Array.map irec bl)) - | App (f,l) when EConstr.isMeta evd (EConstr.of_constr (strip_outer_cast evd f)) -> - let m = destMeta evd (EConstr.of_constr (strip_outer_cast evd f)) in + | App (f,l) when EConstr.isMeta evd (strip_outer_cast evd f) -> + let m = destMeta evd (strip_outer_cast evd f) in (match try let g, s = Metamap.find m metas in @@ -1671,8 +1671,8 @@ let head_unfold_under_prod ts env sigma c = | Prod (n,t,c) -> mkProd (n,aux t, aux c) | _ -> let (h,l) = decompose_app_vect sigma c in - match EConstr.kind sigma (EConstr.of_constr h) with - | Const cst -> beta_app sigma (unfold cst, Array.map EConstr.of_constr l) + match EConstr.kind sigma h with + | Const cst -> beta_app sigma (unfold cst, l) | _ -> c in EConstr.Unsafe.to_constr (aux c) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 1e6527b297..3b3242537f 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -204,7 +204,7 @@ val shrink_eta : EConstr.constr -> EConstr.constr val safe_evar_value : evar_map -> existential -> constr option -val beta_applist : evar_map -> EConstr.t * EConstr.t list -> constr +val beta_applist : evar_map -> EConstr.t * EConstr.t list -> EConstr.constr val hnf_prod_app : env -> evar_map -> EConstr.t -> EConstr.t -> constr val hnf_prod_appvect : env -> evar_map -> EConstr.t -> EConstr.t array -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 88899e633e..3142ea5cba 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -59,7 +59,7 @@ let local_def (na, b, t) = LocalDef (na, inj b, inj t) let get_type_from_constraints env sigma t = - if isEvar sigma (EConstr.of_constr (fst (decompose_app_vect sigma t))) then + if isEvar sigma (fst (decompose_app_vect sigma t)) then match List.map_filter (fun (pbty,env,t1,t2) -> if is_fconv Reduction.CONV env sigma t (EConstr.of_constr t1) then Some t2 @@ -102,7 +102,7 @@ let retype ?(polyprop=true) sigma = let rec type_of env cstr = match EConstr.kind sigma cstr with | Meta n -> - EConstr.of_constr (try strip_outer_cast sigma (EConstr.of_constr (Evd.meta_ftype sigma n).Evd.rebus) + (try strip_outer_cast sigma (EConstr.of_constr (Evd.meta_ftype sigma n).Evd.rebus) with Not_found -> retype_error (BadMeta n)) | Rel n -> let ty = EConstr.of_constr (RelDecl.get_type (lookup_rel n env)) in @@ -135,10 +135,10 @@ let retype ?(polyprop=true) sigma = | CoFix (i,(_,tys,_)) -> tys.(i) | App(f,args) when is_template_polymorphic env sigma f -> let t = type_of_global_reference_knowing_parameters env f args in - EConstr.of_constr (strip_outer_cast sigma (subst_type env sigma t (Array.to_list args))) + strip_outer_cast sigma (subst_type env sigma t (Array.to_list args)) | App(f,args) -> - EConstr.of_constr (strip_outer_cast sigma - (subst_type env sigma (type_of env f) (Array.to_list args))) + strip_outer_cast sigma + (subst_type env sigma (type_of env f) (Array.to_list args)) | Proj (p,c) -> let ty = type_of env c in EConstr.of_constr (try @@ -259,6 +259,5 @@ let expand_projection env sigma pr c args = try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) with Not_found -> retype_error BadRecursiveType in - let ind_args = List.map EConstr.of_constr ind_args in mkApp (mkConstU (Projection.constant pr,u), Array.of_list (ind_args @ (c :: args))) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 1ec8deb1b5..1d179c6834 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -427,8 +427,6 @@ let solve_arity_problem env sigma fxminargs c = let rec check strict c = let c' = EConstr.of_constr (whd_betaiotazeta sigma c) in let (h,rcargs) = decompose_app_vect sigma c' in - let rcargs = Array.map EConstr.of_constr rcargs in - let h = EConstr.of_constr h in match EConstr.kind sigma h with Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> let minargs = Evar.Map.find i fxminargs in @@ -734,14 +732,13 @@ and reduce_params env sigma stack l = and whd_simpl_stack env sigma = let rec redrec s = let (x, stack) = decompose_app_vect sigma s in - let stack = Array.map_to_list EConstr.of_constr stack in - let x = EConstr.of_constr x in + let stack = Array.to_list stack in let s' = (x, stack) in match EConstr.kind sigma x with | Lambda (na,t,c) -> (match stack with | [] -> s' - | a :: rest -> redrec (EConstr.of_constr (beta_applist sigma (x, stack)))) + | a :: rest -> redrec (beta_applist sigma (x, stack))) | LetIn (n,b,t,c) -> redrec (applist (Vars.substl [b] c, stack)) | App (f,cl) -> redrec (applist(f, (Array.to_list cl)@stack)) | Cast (c,_,_) -> redrec (applist(c, stack)) @@ -1122,14 +1119,12 @@ let fold_one_com com env sigma c = unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) let a = subst_term sigma (EConstr.of_constr (clos_norm_flags unfold_side_red env sigma rcom)) c in - let a = EConstr.of_constr a in if not (EConstr.eq_constr sigma a c) then Vars.subst1 com a else (* Then reason on the non beta-iota-zeta form for compatibility - even if it is probably a useless configuration *) let a = subst_term sigma rcom c in - let a = EConstr.of_constr a in Vars.subst1 com a let fold_commands cl env sigma c = @@ -1195,7 +1190,7 @@ let reduce_to_ind_gen allow_product env sigma t = let rec elimrec env t l = let t = hnf_constr env sigma t in let t = EConstr.of_constr t in - match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t))) with + match EConstr.kind sigma (fst (decompose_app_vect sigma t)) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> let open Context.Rel.Declaration in @@ -1208,7 +1203,7 @@ let reduce_to_ind_gen allow_product env sigma t = was partially the case between V5.10 and V8.1 *) let t' = whd_all env sigma t in let t' = EConstr.of_constr t' in - match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t'))) with + match EConstr.kind sigma (fst (decompose_app_vect sigma t')) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) | _ -> user_err (str"Not an inductive product.") in @@ -1275,7 +1270,6 @@ let reduce_to_ref_gen allow_product env sigma ref t = (* lazily reduces to match the head of [t] with the expected [ref] *) let rec elimrec env t l = let c, _ = decompose_app_vect sigma t in - let c = EConstr.of_constr c in match EConstr.kind sigma c with | Prod (n,ty,t') -> if allow_product then diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index a970c434f4..f59a6dcd94 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -156,17 +156,17 @@ let class_of_constr sigma c = try Some (dest_class_arity (Global.env ()) sigma c) with e when CErrors.noncritical e -> None -let is_class_constr c = - try let gr, u = Universes.global_of_constr c in +let is_class_constr sigma c = + try let gr, u = Termops.global_of_constr sigma c in Refmap.mem gr !classes with Not_found -> false let rec is_class_type evd c = let c, _ = Termops.decompose_app_vect evd c in - match EConstr.kind evd (EConstr.of_constr c) with + match EConstr.kind evd c with | Prod (_, _, t) -> is_class_type evd t | Cast (t, _, _) -> is_class_type evd t - | _ -> is_class_constr c + | _ -> is_class_constr evd c let is_class_evar evd evi = is_class_type evd (EConstr.of_constr evi.Evd.evar_concl) diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 29697260f7..40ef2450a3 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -138,7 +138,7 @@ let e_type_case_branches env evdref (ind,largs) pj c = let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in - let realargs = List.map EConstr.of_constr realargs in + let params = List.map EConstr.Unsafe.to_constr params in let () = e_is_correct_arity env evdref c pj ind specif params in let lc = build_branches_type ind specif params (EConstr.to_constr !evdref p) in let lc = Array.map EConstr.of_constr lc in @@ -232,7 +232,6 @@ let judge_of_projection env sigma p cj = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in - let args = List.map EConstr.of_constr args in let ty = EConstr.of_constr (CVars.subst_instance_constr u pb.Declarations.proj_type) in let ty = substl (cj.uj_val :: List.rev args) ty in {uj_val = EConstr.mkProj (p,cj.uj_val); diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 81d9ecad50..169dd45bc8 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -632,7 +632,7 @@ let check_compatibility env pbty flags (sigma,metasubst,evarsubst : subst0) tyM let rec is_neutral env sigma ts t = let (f, l) = decompose_app_vect sigma t in - match EConstr.kind sigma (EConstr.of_constr f) with + match EConstr.kind sigma f with | Const (c, u) -> not (Environ.evaluable_constant c env) || not (is_transparent env (ConstKey c)) || @@ -1488,10 +1488,6 @@ let w_unify_core_0 env evd with_types cv_pb flags m n = let w_typed_unify env evd = w_unify_core_0 env evd true let w_typed_unify_array env evd flags f1 l1 f2 l2 = - let f1 = EConstr.of_constr f1 in - let f2 = EConstr.of_constr f2 in - let l1 = Array.map EConstr.of_constr l1 in - let l2 = Array.map EConstr.of_constr l2 in let f1,l1,f2,l2 = adjust_app_array_size f1 l1 f2 l2 in let (mc1,evd') = retract_coercible_metas evd in let fold_subst subst m n = unify_0_with_initial_metas subst true env CONV flags.core_unify_flags m n in @@ -1743,7 +1739,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let bestexn = ref None in let kop = Keys.constr_key (EConstr.to_constr evd op) in let rec matchrec cl = - let cl = EConstr.of_constr (strip_outer_cast evd cl) in + let cl = strip_outer_cast evd cl in (try if closed0 evd cl && not (isEvar evd cl) && keyed_unify env evd kop cl then (try @@ -1837,7 +1833,6 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = in let rec matchrec cl = let cl = strip_outer_cast evd cl in - let cl = EConstr.of_constr cl in (bind (if closed0 evd cl then return (fun () -> w_typed_unify env evd CONV flags op cl,cl) @@ -1898,7 +1893,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = unify pre-existing non frozen evars of the goal or of the pattern *) set_no_delta_flags flags in - let t' = (EConstr.of_constr (strip_outer_cast evd op),t) in + let t' = (strip_outer_cast evd op,t) in let (evd',cl) = try if is_keyed_unification () then @@ -1992,7 +1987,7 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let hd2,l2 = decompose_app_vect evd (EConstr.of_constr (whd_nored evd ty2)) in let is_empty1 = Array.is_empty l1 in let is_empty2 = Array.is_empty l2 in - match kind_of_term hd1, not is_empty1, kind_of_term hd2, not is_empty2 with + match EConstr.kind evd hd1, not is_empty1, EConstr.kind evd hd2, not is_empty2 with (* Pattern case *) | (Meta _, true, Lambda _, _ | Lambda _, _, Meta _, true) when Int.equal (Array.length l1) (Array.length l2) -> -- cgit v1.2.3 From 0cdb7e42f64674e246d4e24e3c725e23ceeec6bd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Nov 2016 12:13:05 +0100 Subject: Reductionops now return EConstrs. --- pretyping/cases.ml | 11 ++--- pretyping/classops.ml | 2 - pretyping/coercion.ml | 22 ++++------ pretyping/evardefine.ml | 8 ++-- pretyping/evarsolve.ml | 10 ++--- pretyping/indrec.ml | 6 ++- pretyping/inductiveops.ml | 10 ++--- pretyping/nativenorm.ml | 2 +- pretyping/nativenorm.mli | 2 +- pretyping/pretyping.ml | 4 +- pretyping/recordops.ml | 8 ++-- pretyping/reductionops.ml | 79 +++++++++++++++++------------------ pretyping/reductionops.mli | 101 ++++++++++++++++++++++----------------------- pretyping/retyping.ml | 12 +++--- pretyping/tacred.ml | 51 +++++++++++------------ pretyping/typeclasses.ml | 1 + pretyping/typing.ml | 7 ++-- pretyping/unification.ml | 23 +++++------ pretyping/vnorm.ml | 2 +- pretyping/vnorm.mli | 2 +- 20 files changed, 171 insertions(+), 192 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 76ced2b1d6..c0141f0116 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1057,7 +1057,6 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = (* Note: applying the substitution in tms is not important (is it sure?) *) let ccl'' = whd_betaiota Evd.empty (subst_predicate (realargsi, copti) ccl' tms) in - let ccl'' = EConstr.of_constr ccl'' in (* We adjust ccl st: gamma, x'1..x'n, x1..xn, tms |- ccl'' *) let ccl''' = liftn_predicate n (n+1) ccl'' tms in (* We finally get gamma,x'1..x'n,x |- [X1;x1:I(X1)]..[Xn;xn:I(Xn)]pred'''*) @@ -1065,8 +1064,8 @@ let specialize_predicate newtomatchs (names,depna) arsign cs tms ccl = let find_predicate loc env evdref p current (IndType (indf,realargs)) dep tms = let pred = abstract_predicate env !evdref indf current realargs dep tms p in - (pred, EConstr.of_constr (whd_betaiota !evdref - (applist (pred, realargs@[current])))) + (pred, whd_betaiota !evdref + (applist (pred, realargs@[current]))) (* Take into account that a type has been discovered to be inductive, leading to more dependencies in the predicate if the type has indices *) @@ -1221,7 +1220,7 @@ let rec generalize_problem names pb = function | LocalDef (Anonymous,_,_) -> pb', deps | _ -> (* for better rendering *) - let d = RelDecl.map_type (fun c -> whd_betaiota !(pb.evdref) (EConstr.of_constr c)) d in + let d = RelDecl.map_type (fun c -> EConstr.Unsafe.to_constr (whd_betaiota !(pb.evdref) (EConstr.of_constr c))) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch !(pb.evdref) (i+1) 1 tomatch in { pb' with @@ -1400,7 +1399,6 @@ and match_current pb (initial,tomatch) = pred current indt (names,dep) tomatch in let ci = make_case_info pb.env (fst mind) pb.casestyle in let pred = nf_betaiota !(pb.evdref) pred in - let pred = EConstr.of_constr pred in let case = make_case_or_project pb.env !(pb.evdref) indf ci pred current brvals in @@ -1638,7 +1636,6 @@ let rec list_assoc_in_triple x = function let abstract_tycon loc env evdref subst tycon extenv t = let t = nf_betaiota !evdref t in (* it helps in some cases to remove K-redex*) - let t = EConstr.of_constr t in let src = match EConstr.kind !evdref t with | Evar (evk,_) -> (loc,Evar_kinds.SubEvar evk) | _ -> (loc,Evar_kinds.CasesType true) in @@ -1734,7 +1731,7 @@ let build_inversion_problem loc env sigma tms t = let id = next_name_away (named_hd env (EConstr.Unsafe.to_constr t) Anonymous) avoid in PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with + match EConstr.kind sigma (whd_all env sigma t) with | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc | App (f,v) when isConstruct sigma f -> let cstr,u = destConstruct sigma f in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 23d20dad3e..e4331aade2 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -234,7 +234,6 @@ let class_of env sigma t = (t, n1, i, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let t = EConstr.of_constr t in let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in (t, n1, i, u, args) @@ -279,7 +278,6 @@ let apply_on_class_of env sigma t cont = with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let t = EConstr.of_constr t in let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 48f7be4bbb..7e85596308 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -64,7 +64,7 @@ let apply_coercion_args env evd check isproj argl funj = { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) - match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref typ)) with + match EConstr.kind !evdref (whd_all env !evdref typ) with | Prod (_,c1,c2) -> if check && not (e_cumul env evdref (EConstr.of_constr (Retyping.get_type_of env !evdref h)) c1) then raise NoCoercion; @@ -96,7 +96,7 @@ let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdre Evarutil.e_new_evar env evdref ~src c let app_opt env evdref f t = - EConstr.of_constr (whd_betaiota !evdref (app_opt f t)) + whd_betaiota !evdref (app_opt f t) let pair_of_array a = (a.(0), a.(1)) @@ -134,11 +134,10 @@ let local_assum (na, t) = let mu env evdref t = let rec aux v = let v' = hnf env !evdref v in - let v' = EConstr.of_constr v' in match disc_subset !evdref v' with | Some (u, p) -> let f, ct = aux u in - let p = EConstr.of_constr (hnf_nodelta env !evdref p) in + let p = hnf_nodelta env !evdref p in (Some (fun x -> app_opt env evdref f (papp evdref sig_proj1 [| u; p; x |])), @@ -152,8 +151,6 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) let open Context.Rel.Declaration in let rec coerce_unify env x y = let x = hnf env !evdref x and y = hnf env !evdref y in - let x = EConstr.of_constr x in - let y = EConstr.of_constr y in try evdref := the_conv_x_leq env x y !evdref; None @@ -162,7 +159,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) let subco () = subset_coerce env evdref x y in let dest_prod c = match Reductionops.splay_prod_n env (!evdref) 1 c with - | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na, EConstr.of_constr t), EConstr.of_constr c + | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na, EConstr.of_constr t), c | _ -> raise NoSubtacCoercion in let coerce_application typ typ' c c' l l' = @@ -344,7 +341,7 @@ let app_coercion env evdref coercion v = | None -> v | Some f -> let v' = Typing.e_solve_evars env evdref (f v) in - EConstr.of_constr (whd_betaiota !evdref (EConstr.of_constr v')) + whd_betaiota !evdref (EConstr.of_constr v') let coerce_itf loc env evd v t c1 = let evdref = ref evd in @@ -381,7 +378,6 @@ let apply_coercion env sigma p hj typ_cl = (* Try to coerce to a funclass; raise NoCoercion if not possible *) let inh_app_fun_core env evd j = let t = whd_all env evd j.uj_type in - let t = EConstr.of_constr t in match EConstr.kind evd t with | Prod (_,_,_) -> (evd,j) | Evar ev -> @@ -413,7 +409,7 @@ let inh_app_fun resolve_tc env evd j = with NoCoercion -> (evd, j) let type_judgment env sigma j = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma j.uj_type)) with + match EConstr.kind sigma (whd_all env sigma j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | _ -> error_not_a_type env sigma j @@ -429,7 +425,7 @@ let inh_tosort_force loc env evd j = let inh_coerce_to_sort loc env evd j = let typ = whd_all env evd j.uj_type in - match EConstr.kind evd (EConstr.of_constr typ) with + match EConstr.kind evd typ with | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) | Evar ev -> let (evd',s) = Evardefine.define_evar_as_sort env evd ev in @@ -480,8 +476,8 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = try inh_coerce_to_fail env evd rigidonly v t c1 with NoCoercion -> match - EConstr.kind evd (EConstr.of_constr (whd_all env evd t)), - EConstr.kind evd (EConstr.of_constr (whd_all env evd c1)) + EConstr.kind evd (whd_all env evd t), + EConstr.kind evd (whd_all env evd c1) with | Prod (name,t1,t2), Prod (_,u1,u2) -> (* Conversion did not work, we may succeed with a coercion. *) diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 3babc48a7f..d4b46c0465 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -39,7 +39,7 @@ let env_nf_evar sigma env = let env_nf_betaiotaevar sigma env = process_rel_context (fun d e -> - push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota sigma (EConstr.of_constr c)) d) e) env + push_rel (RelDecl.map_constr (fun c -> EConstr.Unsafe.to_constr (Reductionops.nf_betaiota sigma (EConstr.of_constr c))) d) e) env (****************************************) (* Operations on value/type constraints *) @@ -85,7 +85,6 @@ let define_pure_evar_as_product evd evk = let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in let concl = Reductionops.whd_all evenv evd (EConstr.of_constr evi.evar_concl) in - let concl = EConstr.of_constr concl in let s = destSort evd concl in let evd1,(dom,u1) = let evd = Sigma.Unsafe.of_evar_map evd in @@ -138,7 +137,7 @@ let define_pure_evar_as_lambda env evd evk = let open Context.Named.Declaration in let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in - let typ = EConstr.of_constr (Reductionops.whd_all evenv evd (EConstr.of_constr (evar_concl evi))) in + let typ = Reductionops.whd_all evenv evd (EConstr.of_constr (evar_concl evi)) in let evd1,(na,dom,rng) = match EConstr.kind evd typ with | Prod (na,dom,rng) -> (evd,(na,dom,rng)) | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd evd typ @@ -177,7 +176,6 @@ let define_evar_as_sort env evd (ev,args) = let evi = Evd.find_undefined evd ev in let s = Type u in let concl = Reductionops.whd_all (evar_env evi) evd (EConstr.of_constr evi.evar_concl) in - let concl = EConstr.of_constr concl in let sort = destSort evd concl in let evd' = Evd.define ev (Constr.mkSort s) evd in Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s @@ -190,7 +188,7 @@ let define_evar_as_sort env evd (ev,args) = let split_tycon loc env evd tycon = let rec real_split evd c = let t = Reductionops.whd_all env evd c in - match EConstr.kind evd (EConstr.of_constr t) with + match EConstr.kind evd t with | Prod (na,dom,rng) -> evd, (na, dom, rng) | Evar ev (* ev is undefined because of whd_all *) -> let (evd',prod) = define_evar_as_product evd ev in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 65b6d287d5..27436fdd8b 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -149,7 +149,7 @@ let recheck_applications conv_algo env evdref t = let argsty = Array.map (fun x -> aux env x; EConstr.of_constr (Retyping.get_type_of env !evdref x)) args in let rec aux i ty = if i < Array.length argsty then - match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref ty)) with + match EConstr.kind !evdref (whd_all env !evdref ty) with | Prod (na, dom, codom) -> (match conv_algo env !evdref Reduction.CUMUL argsty.(i) dom with | Success evd -> evdref := evd; @@ -814,7 +814,7 @@ let rec do_projection_effects define_fun env ty evd = function let evd = Evd.define evk (Constr.mkVar id) evd in (* TODO: simplify constraints involving evk *) let evd = do_projection_effects define_fun env ty evd p in - let ty = EConstr.of_constr (whd_all env evd (Lazy.force ty)) in + let ty = whd_all env evd (Lazy.force ty) in if not (isSort evd ty) then (* Don't try to instantiate if a sort because if evar_concl is an evar it may commit to a univ level which is not the right @@ -1494,7 +1494,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = map_constr_with_full_binders !evdref (fun d (env,k) -> push_rel d env, k+1) imitate envk t in - let rhs = EConstr.of_constr (whd_beta evd rhs) (* heuristic *) in + let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in let names = ref Idset.empty in @@ -1576,7 +1576,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = raise e | OccurCheckIn (evd,rhs) -> (* last chance: rhs actually reduces to ev *) - let c = EConstr.of_constr (whd_all env evd rhs) in + let c = whd_all env evd rhs in match EConstr.kind evd c with | Evar (evk',argsv2) when Evar.equal evk evk' -> solve_refl (fun env sigma pb c c' -> is_fconv pb env sigma c c') @@ -1637,7 +1637,7 @@ let reconsider_conv_pbs conv_algo evd = (* Rq: uncomplete algorithm if pbty = CONV_X_LEQ ! *) let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = try - let t2 = EConstr.of_constr (whd_betaiota evd t2) in (* includes whd_evar *) + let t2 = whd_betaiota evd t2 in (* includes whd_evar *) let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in reconsider_conv_pbs conv_algo evd with diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 4fa5ad06d3..1adeb4db2f 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -173,6 +173,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = base | _ -> let t' = whd_all env sigma (EConstr.of_constr p) in + let t' = EConstr.Unsafe.to_constr t' in if Term.eq_constr p' t' then assert false else prec env i sign t' in @@ -247,6 +248,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = applist(lift i fk,realargs@[arg]) | _ -> let t' = whd_all env sigma (EConstr.of_constr p) in + let t' = EConstr.Unsafe.to_constr t' in if Term.eq_constr t' p' then assert false else prec env i hyps t' in @@ -265,7 +267,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = | None -> mkLambda_name env (n,t,process_constr (push_rel d env) (i+1) - (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)])))) + (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1)]))))) (cprest,rest)) | Some(_,f_0) -> let nF = lift (i+1+decF) f_0 in @@ -273,7 +275,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = let arg = process_pos env' nF (lift 1 t) in mkLambda_name env (n,t,process_constr env' (i+1) - (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg])))) + (EConstr.Unsafe.to_constr (whd_beta Evd.empty (EConstr.of_constr (applist (lift 1 f, [(mkRel 1); arg]))))) (cprest,rest))) | (LocalDef (n,c,t) as d)::cprest, rest -> mkLetIn diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 9c5a2e894a..120adb9fef 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -456,7 +456,7 @@ let extract_mrectype sigma t = let find_mrectype_vect env sigma c = let open EConstr in - let (t, l) = Termops.decompose_app_vect sigma (EConstr.of_constr (whd_all env sigma c)) in + let (t, l) = Termops.decompose_app_vect sigma (whd_all env sigma c) in match EConstr.kind sigma t with | Ind ind -> (ind, l) | _ -> raise Not_found @@ -466,7 +466,7 @@ let find_mrectype env sigma c = let find_rectype env sigma c = let open EConstr in - let (t, l) = decompose_app sigma (EConstr.of_constr (whd_all env sigma c)) in + let (t, l) = decompose_app sigma (whd_all env sigma c) in match EConstr.kind sigma t with | Ind (ind,u as indu) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in @@ -478,7 +478,7 @@ let find_rectype env sigma c = let find_inductive env sigma c = let open EConstr in - let (t, l) = decompose_app sigma (EConstr.of_constr (whd_all env sigma c)) in + let (t, l) = decompose_app sigma (whd_all env sigma c) in match EConstr.kind sigma t with | Ind ind when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite <> Decl_kinds.CoFinite -> @@ -488,7 +488,7 @@ let find_inductive env sigma c = let find_coinductive env sigma c = let open EConstr in - let (t, l) = decompose_app sigma (EConstr.of_constr (whd_all env sigma c)) in + let (t, l) = decompose_app sigma (whd_all env sigma c) in match EConstr.kind sigma t with | Ind ind when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite == Decl_kinds.CoFinite -> @@ -503,7 +503,7 @@ let find_coinductive env sigma c = let is_predicate_explicitly_dep env sigma pred arsign = let rec srec env pval arsign = - let pv' = EConstr.of_constr (whd_all env sigma pval) in + let pv' = whd_all env sigma pval in match EConstr.kind sigma pv', arsign with | Lambda (na,t,b), (LocalAssum _)::arsign -> srec (push_rel_assum (na, t) env) b arsign diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index cdaa4e9eee..0228f63cdc 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -404,7 +404,7 @@ let native_norm env sigma c ty = let t2 = Sys.time () in let time_info = Format.sprintf "Reification done in %.5f@." (t2 -. t1) in if !Flags.debug then Feedback.msg_debug (Pp.str time_info); - res + EConstr.of_constr res | _ -> anomaly (Pp.str "Compilation failure") let native_conv_generic pb sigma t = diff --git a/pretyping/nativenorm.mli b/pretyping/nativenorm.mli index ba46138a4f..c899340c8c 100644 --- a/pretyping/nativenorm.mli +++ b/pretyping/nativenorm.mli @@ -12,7 +12,7 @@ open Evd (** This module implements normalization by evaluation to OCaml code *) -val native_norm : env -> evar_map -> constr -> types -> Constr.t +val native_norm : env -> evar_map -> constr -> types -> constr (** Conversion with inference of universe constraints *) val native_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f814028f98..7d2c96bb90 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -743,7 +743,6 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let argloc = loc_of_glob_constr c in let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env.ExtraEnv.env) evdref resj in let resty = whd_all env.ExtraEnv.env !evdref resj.uj_type in - let resty = EConstr.of_constr resty in match EConstr.kind !evdref resty with | Prod (na,c1,c2) -> let tycon = Some c1 in @@ -917,7 +916,6 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre @[EConstr.of_constr (build_dependent_constructor cs)] in let lp = lift cs.cs_nargs p in let fty = hnf_lam_applist env.ExtraEnv.env !evdref lp inst in - let fty = EConstr.of_constr fty in let fj = pretype (mk_tycon fty) env_f evdref lvar d in let v = let ind,_ = dest_ind_family indf in @@ -1100,7 +1098,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let sigma = !evdref in let t = Retyping.get_type_of env.ExtraEnv.env sigma v in let t = EConstr.of_constr t in - match EConstr.kind sigma (EConstr.of_constr (whd_all env.ExtraEnv.env sigma t)) with + match EConstr.kind sigma (whd_all env.ExtraEnv.env sigma t) with | Sort s -> s | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 3230f92da8..8362a2a26a 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -324,15 +324,15 @@ let lookup_canonical_conversion (proj,pat) = assoc_pat pat (Refmap.find proj !object_table) let is_open_canonical_projection env sigma (c,args) = + let open EConstr in try - let c = EConstr.Unsafe.to_constr c in - let ref = global_of_constr c in + let (ref, _) = Termops.global_of_constr sigma c in let n = find_projection_nparams ref in (** Check if there is some canonical projection attached to this structure *) let _ = Refmap.find ref !object_table in try let arg = whd_all env sigma (Stack.nth args n) in - let hd = match kind_of_term arg with App (hd, _) -> hd | _ -> arg in - not (isConstruct hd) + let hd = match EConstr.kind sigma arg with App (hd, _) -> hd | _ -> arg in + not (isConstruct sigma hd) with Failure _ -> false with Not_found -> false diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 6ec3cd985c..45e7abcb79 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -588,10 +588,10 @@ end (** The type of (machine) states (= lambda-bar-calculus' cuts) *) type state = constr * constr Stack.t -type contextual_reduction_function = env -> evar_map -> constr -> Constr.constr +type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function -type local_reduction_function = evar_map -> constr -> Constr.constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (Constr.constr, 'r) Sigma.sigma } +type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -629,19 +629,18 @@ let safe_meta_value sigma ev = let strong whdfun env sigma t = let rec strongrec env t = - let t = EConstr.of_constr (whdfun env sigma t) in - map_constr_with_full_binders sigma push_rel strongrec env t in - EConstr.Unsafe.to_constr (strongrec env t) + map_constr_with_full_binders sigma push_rel strongrec env (whdfun env sigma t) in + strongrec env t let local_strong whdfun sigma = - let rec strongrec t = EConstr.map sigma strongrec (EConstr.of_constr (whdfun sigma t)) in - fun c -> EConstr.Unsafe.to_constr (strongrec c) + let rec strongrec t = EConstr.map sigma strongrec (whdfun sigma t) in + strongrec let rec strong_prodspine redfun sigma c = - let x = EConstr.of_constr (redfun sigma c) in + let x = redfun sigma c in match EConstr.kind sigma x with - | Prod (na,a,b) -> EConstr.Unsafe.to_constr (mkProd (na,a,EConstr.of_constr (strong_prodspine redfun sigma b))) - | _ -> EConstr.Unsafe.to_constr x + | Prod (na,a,b) -> mkProd (na,a,strong_prodspine redfun sigma b) + | _ -> x (*************************************) (*** Reduction using bindingss ***) @@ -1140,7 +1139,7 @@ let iterate_whd_gen refold flags env sigma s = in aux s let red_of_state_red f sigma x = - EConstr.Unsafe.to_constr (Stack.zip sigma (f sigma (x,Stack.empty))) + Stack.zip sigma (f sigma (x,Stack.empty)) (* 0. No Reduction Functions *) @@ -1217,9 +1216,9 @@ let nf_evar = Evarutil.nf_evar let clos_norm_flags flgs env sigma t = try let evars ev = safe_evar_value sigma ev in - CClosure.norm_val + EConstr.of_constr (CClosure.norm_val (CClosure.create_clos_infos ~evars flgs env) - (CClosure.inject (EConstr.Unsafe.to_constr t)) + (CClosure.inject (EConstr.Unsafe.to_constr t))) with e when is_anomaly e -> error "Tried to normalize ill-typed term" let nf_beta = clos_norm_flags CClosure.beta (Global.env ()) @@ -1309,6 +1308,7 @@ let sigma_univ_state = let infer_conv_gen conv_fun ?(catch_incon=true) ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + (** FIXME *) let x = EConstr.Unsafe.to_constr x in let y = EConstr.Unsafe.to_constr y in try @@ -1352,8 +1352,8 @@ let vm_infer_conv ?(pb=Reduction.CUMUL) env t1 t2 = (********************************************************************) let whd_meta sigma c = match EConstr.kind sigma c with - | Meta p -> (try meta_value sigma p with Not_found -> EConstr.Unsafe.to_constr c) - | _ -> EConstr.Unsafe.to_constr c + | Meta p -> (try EConstr.of_constr (meta_value sigma p) with Not_found -> c) + | _ -> c let default_plain_instance_ident = Id.of_string "H" @@ -1431,26 +1431,26 @@ let instance sigma s c = * error message. *) let hnf_prod_app env sigma t n = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with - | Prod (_,_,b) -> EConstr.Unsafe.to_constr (subst1 n b) + match EConstr.kind sigma (whd_all env sigma t) with + | Prod (_,_,b) -> subst1 n b | _ -> anomaly ~label:"hnf_prod_app" (Pp.str "Need a product") let hnf_prod_appvect env sigma t nl = - Array.fold_left (fun acc t -> hnf_prod_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl + Array.fold_left (fun acc t -> hnf_prod_app env sigma acc t) t nl let hnf_prod_applist env sigma t nl = - List.fold_left (fun acc t -> hnf_prod_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl + List.fold_left (fun acc t -> hnf_prod_app env sigma acc t) t nl let hnf_lam_app env sigma t n = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with - | Lambda (_,_,b) -> EConstr.Unsafe.to_constr (subst1 n b) + match EConstr.kind sigma (whd_all env sigma t) with + | Lambda (_,_,b) -> subst1 n b | _ -> anomaly ~label:"hnf_lam_app" (Pp.str "Need an abstraction") let hnf_lam_appvect env sigma t nl = - Array.fold_left (fun acc t -> hnf_lam_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl + Array.fold_left (fun acc t -> hnf_lam_app env sigma acc t) t nl let hnf_lam_applist env sigma t nl = - List.fold_left (fun acc t -> hnf_lam_app env sigma (EConstr.of_constr acc) t) (EConstr.Unsafe.to_constr t) nl + List.fold_left (fun acc t -> hnf_lam_app env sigma acc t) t nl let bind_assum (na, t) = (na, t) @@ -1458,7 +1458,6 @@ let bind_assum (na, t) = let splay_prod env sigma = let rec decrec env m c = let t = whd_all env sigma c in - let t = EConstr.of_constr t in match EConstr.kind sigma t with | Prod (n,a,c0) -> decrec (push_rel (local_assum (n,a)) env) @@ -1470,7 +1469,6 @@ let splay_prod env sigma = let splay_lam env sigma = let rec decrec env m c = let t = whd_all env sigma c in - let t = EConstr.of_constr t in match EConstr.kind sigma t with | Lambda (n,a,c0) -> decrec (push_rel (local_assum (n,a)) env) @@ -1482,7 +1480,7 @@ let splay_lam env sigma = let splay_prod_assum env sigma = let rec prodec_rec env l c = let t = whd_allnolet env sigma c in - match EConstr.kind sigma (EConstr.of_constr t) with + match EConstr.kind sigma t with | Prod (x,t,c) -> prodec_rec (push_rel (local_assum (x,t)) env) (Context.Rel.add (local_assum (x,t)) l) c @@ -1491,9 +1489,9 @@ let splay_prod_assum env sigma = (Context.Rel.add (local_def (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> - let t' = whd_all env sigma (EConstr.of_constr t) in - if Term.eq_constr t t' then l,t - else prodec_rec env l (EConstr.of_constr t') + let t' = whd_all env sigma t in + if EConstr.eq_constr sigma t t' then l,t + else prodec_rec env l t' in prodec_rec env Context.Rel.empty @@ -1506,8 +1504,8 @@ let splay_arity env sigma c = let sort_of_arity env sigma c = snd (splay_arity env sigma c) let splay_prod_n env sigma n = - let rec decrec env m ln c = if Int.equal m 0 then (ln, EConstr.Unsafe.to_constr c) else - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma c)) with + let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else + match EConstr.kind sigma (whd_all env sigma c) with | Prod (n,a,c0) -> decrec (push_rel (local_assum (n,a)) env) (m-1) (Context.Rel.add (local_assum (n,a)) ln) c0 @@ -1516,8 +1514,8 @@ let splay_prod_n env sigma n = decrec env n Context.Rel.empty let splay_lam_n env sigma n = - let rec decrec env m ln c = if Int.equal m 0 then (ln, EConstr.Unsafe.to_constr c) else - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma c)) with + let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else + match EConstr.kind sigma (whd_all env sigma c) with | Lambda (n,a,c0) -> decrec (push_rel (local_assum (n,a)) env) (m-1) (Context.Rel.add (local_assum (n,a)) ln) c0 @@ -1526,7 +1524,7 @@ let splay_lam_n env sigma n = decrec env n Context.Rel.empty let is_sort env sigma t = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with + match EConstr.kind sigma (whd_all env sigma t) with | Sort s -> true | _ -> false @@ -1559,7 +1557,7 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let find_conclusion env sigma = let rec decrec env c = let t = whd_all env sigma c in - match EConstr.kind sigma (EConstr.of_constr t) with + match EConstr.kind sigma t with | Prod (x,t,c0) -> decrec (push_rel (local_assum (x,t)) env) c0 | Lambda (x,t,c0) -> decrec (push_rel (local_assum (x,t)) env) c0 | t -> t @@ -1579,7 +1577,7 @@ let meta_value evd mv = match meta_opt_fvalue evd mv with | Some (b,_) -> let metas = Metamap.bind valrec b.freemetas in - EConstr.of_constr (instance evd metas (EConstr.of_constr b.rebus)) + instance evd metas (EConstr.of_constr b.rebus) | None -> mkMeta mv in valrec mv @@ -1589,7 +1587,7 @@ let meta_instance sigma b = if Metaset.is_empty fm then b.rebus else let c_sigma = Metamap.bind (fun mv -> meta_value sigma mv) fm in - EConstr.of_constr (instance sigma c_sigma b.rebus) + instance sigma c_sigma b.rebus let nf_meta sigma c = let c = EConstr.Unsafe.to_constr c in @@ -1609,7 +1607,6 @@ let meta_reducible_instance evd b = let metas = Metaset.fold fold fm Metamap.empty in let rec irec u = let u = whd_betaiota Evd.empty u (** FIXME *) in - let u = EConstr.of_constr u in match EConstr.kind evd u with | Case (ci,p,c,bl) when EConstr.isMeta evd (strip_outer_cast evd c) -> let m = destMeta evd (strip_outer_cast evd c) in @@ -1674,7 +1671,7 @@ let head_unfold_under_prod ts env sigma c = match EConstr.kind sigma h with | Const cst -> beta_app sigma (unfold cst, l) | _ -> c in - EConstr.Unsafe.to_constr (aux c) + aux c let betazetaevar_applist sigma n c l = let rec stacklam n env t stack = @@ -1684,4 +1681,4 @@ let betazetaevar_applist sigma n c l = | LetIn(_,b,_,c), _ -> stacklam (n-1) (substl env b::env) c stack | Evar _, _ -> applist (substl env t, stack) | _ -> anomaly (Pp.str "Not enough lambda/let's") in - EConstr.Unsafe.to_constr (stacklam n [] c l) + stacklam n [] c l diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 3b3242537f..add1d186bb 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Univ open Evd open Environ @@ -38,7 +39,6 @@ val set_refolding_in_reduction : bool -> unit cst applied to params must convertible to term of the state applied to args *) module Cst_stack : sig - open EConstr type t val empty : t val add_param : constr -> t -> t @@ -52,7 +52,6 @@ end module Stack : sig - open EConstr type 'a app_node val pr_app_node : ('a -> Pp.std_ppcmds) -> 'a app_node -> Pp.std_ppcmds @@ -109,19 +108,19 @@ end (************************************************************************) -type state = EConstr.t * EConstr.t Stack.t +type state = constr * constr Stack.t -type contextual_reduction_function = env -> evar_map -> EConstr.t -> constr +type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function -type local_reduction_function = evar_map -> EConstr.t -> constr +type local_reduction_function = evar_map -> constr -> constr -type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> EConstr.t -> (constr, 'r) Sigma.sigma } +type e_reduction_function = { e_redfun : 'r. env -> 'r Sigma.t -> constr -> (constr, 'r) Sigma.sigma } type contextual_stack_reduction_function = - env -> evar_map -> EConstr.t -> EConstr.t * EConstr.t list + env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function type local_stack_reduction_function = - evar_map -> EConstr.t -> EConstr.t * EConstr.t list + evar_map -> constr -> constr * constr list type contextual_state_reduction_function = env -> evar_map -> state -> state @@ -139,13 +138,13 @@ val strong_prodspine : local_reduction_function -> local_reduction_function val stack_reduction_of_reduction : 'a reduction_function -> 'a state_reduction_function i*) -val stacklam : (state -> 'a) -> EConstr.t list -> evar_map -> EConstr.t -> EConstr.t Stack.t -> 'a +val stacklam : (state -> 'a) -> constr list -> evar_map -> constr -> constr Stack.t -> 'a val whd_state_gen : ?csts:Cst_stack.t -> refold:bool -> tactic_mode:bool -> CClosure.RedFlags.reds -> Environ.env -> Evd.evar_map -> state -> state * Cst_stack.t val iterate_whd_gen : bool -> CClosure.RedFlags.reds -> - Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr + Environ.env -> Evd.evar_map -> constr -> constr (** {6 Generic Optimized Reduction Function using Closures } *) @@ -156,11 +155,11 @@ val nf_beta : local_reduction_function val nf_betaiota : local_reduction_function val nf_betaiotazeta : local_reduction_function val nf_all : reduction_function -val nf_evar : evar_map -> constr -> constr +val nf_evar : evar_map -> Constr.constr -> Constr.constr (** Lazy strategy, weak head reduction *) -val whd_evar : evar_map -> constr -> constr +val whd_evar : evar_map -> Constr.constr -> Constr.constr val whd_nored : local_reduction_function val whd_beta : local_reduction_function val whd_betaiota : local_reduction_function @@ -198,45 +197,45 @@ val whd_zeta_stack : local_stack_reduction_function val whd_zeta_state : local_state_reduction_function val whd_zeta : local_reduction_function -val shrink_eta : EConstr.constr -> EConstr.constr +val shrink_eta : constr -> constr (** Various reduction functions *) -val safe_evar_value : evar_map -> existential -> constr option +val safe_evar_value : evar_map -> Constr.existential -> Constr.constr option -val beta_applist : evar_map -> EConstr.t * EConstr.t list -> EConstr.constr +val beta_applist : evar_map -> constr * constr list -> constr -val hnf_prod_app : env -> evar_map -> EConstr.t -> EConstr.t -> constr -val hnf_prod_appvect : env -> evar_map -> EConstr.t -> EConstr.t array -> constr -val hnf_prod_applist : env -> evar_map -> EConstr.t -> EConstr.t list -> constr -val hnf_lam_app : env -> evar_map -> EConstr.t -> EConstr.t -> constr -val hnf_lam_appvect : env -> evar_map -> EConstr.t -> EConstr.t array -> constr -val hnf_lam_applist : env -> evar_map -> EConstr.t -> EConstr.t list -> constr +val hnf_prod_app : env -> evar_map -> constr -> constr -> constr +val hnf_prod_appvect : env -> evar_map -> constr -> constr array -> constr +val hnf_prod_applist : env -> evar_map -> constr -> constr list -> constr +val hnf_lam_app : env -> evar_map -> constr -> constr -> constr +val hnf_lam_appvect : env -> evar_map -> constr -> constr array -> constr +val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr -val splay_prod : env -> evar_map -> EConstr.t -> (Name.t * EConstr.constr) list * EConstr.constr -val splay_lam : env -> evar_map -> EConstr.t -> (Name.t * EConstr.constr) list * EConstr.constr -val splay_arity : env -> evar_map -> EConstr.t -> (Name.t * EConstr.constr) list * sorts -val sort_of_arity : env -> evar_map -> EConstr.t -> sorts -val splay_prod_n : env -> evar_map -> int -> EConstr.t -> Context.Rel.t * constr -val splay_lam_n : env -> evar_map -> int -> EConstr.t -> Context.Rel.t * constr +val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr +val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr +val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts +val sort_of_arity : env -> evar_map -> constr -> sorts +val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr +val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr val splay_prod_assum : - env -> evar_map -> EConstr.t -> Context.Rel.t * constr + env -> evar_map -> constr -> Context.Rel.t * constr type 'a miota_args = { - mP : EConstr.t; (** the result type *) - mconstr : EConstr.t; (** the constructor *) + mP : constr; (** the result type *) + mconstr : constr; (** the constructor *) mci : case_info; (** special info to re-build pattern *) mcargs : 'a list; (** the constructor's arguments *) mlf : 'a array } (** the branch code vector *) -val reducible_mind_case : evar_map -> EConstr.t -> bool -val reduce_mind_case : evar_map -> EConstr.t miota_args -> EConstr.t +val reducible_mind_case : evar_map -> constr -> bool +val reduce_mind_case : evar_map -> constr miota_args -> constr -val find_conclusion : env -> evar_map -> EConstr.t -> (EConstr.t,EConstr.t) kind_of_term -val is_arity : env -> evar_map -> EConstr.t -> bool -val is_sort : env -> evar_map -> EConstr.types -> bool +val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term +val is_arity : env -> evar_map -> constr -> bool +val is_sort : env -> evar_map -> types -> bool -val contract_fix : ?env:Environ.env -> evar_map -> ?reference:Constant.t -> (EConstr.t, EConstr.t) pfixpoint -> EConstr.t +val contract_fix : ?env:Environ.env -> evar_map -> ?reference:Constant.t -> fixpoint -> constr val fix_recarg : ('a, 'a) pfixpoint -> 'b Stack.t -> (int * 'b) option (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) @@ -249,14 +248,14 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val is_conv : ?reds:transparent_state -> env -> evar_map -> EConstr.t -> EConstr.t -> bool -val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> EConstr.t -> EConstr.t -> bool -val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> EConstr.t -> EConstr.t -> bool +val is_conv : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_conv_leq : ?reds:transparent_state -> env -> evar_map -> constr -> constr -> bool +val is_fconv : ?reds:transparent_state -> conv_pb -> env -> evar_map -> constr -> constr -> bool (** [check_conv] Checks universe constraints only. pb defaults to CUMUL and ts to a full transparent state. *) -val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> EConstr.t -> EConstr.t -> bool +val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool (** [infer_conv] Adds necessary universe constraints to the evar map. pb defaults to CUMUL and ts to a full transparent state. @@ -264,29 +263,29 @@ val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> ECo otherwise returns false in that case. *) val infer_conv : ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> - env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map * bool + env -> evar_map -> constr -> constr -> evar_map * bool (** Conversion with inference of universe constraints *) -val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> EConstr.constr -> EConstr.constr -> +val set_vm_infer_conv : (?pb:conv_pb -> env -> evar_map -> constr -> constr -> evar_map * bool) -> unit -val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> EConstr.constr -> EConstr.constr -> +val vm_infer_conv : ?pb:conv_pb -> env -> evar_map -> constr -> constr -> evar_map * bool (** [infer_conv_gen] behaves like [infer_conv] but is parametrized by a conversion function. Used to pretype vm and native casts. *) val infer_conv_gen : (conv_pb -> l2r:bool -> evar_map -> transparent_state -> - (constr, evar_map) Reduction.generic_conversion_function) -> + (Constr.constr, evar_map) Reduction.generic_conversion_function) -> ?catch_incon:bool -> ?pb:conv_pb -> ?ts:transparent_state -> env -> - evar_map -> EConstr.constr -> EConstr.constr -> evar_map * bool + evar_map -> constr -> constr -> evar_map * bool (** {6 Special-Purpose Reduction Functions } *) val whd_meta : local_reduction_function -val plain_instance : evar_map -> EConstr.t Metamap.t -> EConstr.t -> EConstr.t -val instance : evar_map -> EConstr.t Metamap.t -> EConstr.t -> constr +val plain_instance : evar_map -> constr Metamap.t -> constr -> constr +val instance : evar_map -> constr Metamap.t -> constr -> constr val head_unfold_under_prod : transparent_state -> reduction_function -val betazetaevar_applist : evar_map -> int -> EConstr.t -> EConstr.t list -> constr +val betazetaevar_applist : evar_map -> int -> constr -> constr list -> constr (** {6 Heuristic for Conversion with Evar } *) @@ -295,6 +294,6 @@ val whd_betaiota_deltazeta_for_iota_state : state * Cst_stack.t (** {6 Meta-related reduction functions } *) -val meta_instance : evar_map -> EConstr.constr freelisted -> EConstr.constr -val nf_meta : evar_map -> EConstr.constr -> EConstr.constr -val meta_reducible_instance : evar_map -> EConstr.constr freelisted -> EConstr.constr +val meta_instance : evar_map -> constr freelisted -> constr +val nf_meta : evar_map -> constr -> constr +val meta_reducible_instance : evar_map -> constr freelisted -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 3142ea5cba..7db30bf234 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -74,7 +74,7 @@ let get_type_from_constraints env sigma t = let rec subst_type env sigma typ = function | [] -> typ | h::rest -> - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma typ)) with + match EConstr.kind sigma (whd_all env sigma typ) with | Prod (na,c1,c2) -> subst_type env sigma (subst1 h c2) rest | _ -> retype_error NonFunctionalConstruction @@ -83,7 +83,7 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma ar)), args with + match EConstr.kind sigma (whd_all env sigma ar), args with | Prod (na, t, b), h::l -> concl_of_arity (push_rel (local_def (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> s | _ -> retype_error NotASort @@ -94,7 +94,7 @@ let type_of_var env id = with Not_found -> retype_error (BadVariable id) let decomp_sort env sigma t = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with + match EConstr.kind sigma (whd_all env sigma t) with | Sort s -> s | _ -> retype_error NotASort @@ -123,9 +123,9 @@ let retype ?(polyprop=true) sigma = with Not_found -> retype_error BadRecursiveType in let n = inductive_nrealdecls_env env (fst (fst (dest_ind_family indf))) in - let t = EConstr.of_constr (betazetaevar_applist sigma n p realargs) in - (match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma (type_of env t))) with - | Prod _ -> EConstr.of_constr (whd_beta sigma (applist (t, [c]))) + let t = betazetaevar_applist sigma n p realargs in + (match EConstr.kind sigma (whd_all env sigma (type_of env t)) with + | Prod _ -> whd_beta sigma (applist (t, [c])) | _ -> t) | Lambda (name,c1,c2) -> mkProd (name, c1, type_of (push_rel (local_assum (name,c1)) env) c2) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 1d179c6834..02524f8962 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -425,7 +425,7 @@ let solve_arity_problem env sigma fxminargs c = let evm = ref sigma in let set_fix i = evm := Evd.define i (Constr.mkVar vfx) !evm in let rec check strict c = - let c' = EConstr.of_constr (whd_betaiotazeta sigma c) in + let c' = whd_betaiotazeta sigma c in let (h,rcargs) = decompose_app_vect sigma c' in match EConstr.kind sigma h with Evar(i,_) when Evar.Map.mem i fxminargs && not (Evd.is_defined !evm i) -> @@ -473,7 +473,7 @@ let reduce_fix whdfun sigma fix stack = | None -> NotReducible | Some (recargnum,recarg) -> let (recarg'hd,_ as recarg') = whdfun sigma recarg in - let stack' = List.assign stack recargnum (EConstr.applist recarg') in + let stack' = List.assign stack recargnum (applist recarg') in (match EConstr.kind sigma recarg'hd with | Construct _ -> Reduced (contract_fix sigma fix, stack') | _ -> NotReducible) @@ -483,7 +483,7 @@ let contract_fix_use_function env sigma f let nbodies = Array.length recindices in let make_Fi j = (mkFix((recindices,j),typedbodies), f j) in let lbodies = List.init nbodies make_Fi in - substl_checking_arity env (List.rev lbodies) sigma (EConstr.of_constr (nf_beta sigma bodies.(bodynum))) + substl_checking_arity env (List.rev lbodies) sigma (nf_beta sigma bodies.(bodynum)) let reduce_fix_use_function env sigma f whfun fix stack = match fix_recarg fix (Stack.append_app_list stack Stack.empty) with @@ -495,7 +495,7 @@ let reduce_fix_use_function env sigma f whfun fix stack = (recarg, []) else whfun recarg in - let stack' = List.assign stack recargnum (EConstr.applist recarg') in + let stack' = List.assign stack recargnum (applist recarg') in (match EConstr.kind sigma recarg'hd with | Construct _ -> Reduced (contract_fix_use_function env sigma f fix,stack') @@ -507,7 +507,7 @@ let contract_cofix_use_function env sigma f let make_Fi j = (mkCoFix(j,typedbodies), f j) in let subbodies = List.init nbodies make_Fi in substl_checking_arity env (List.rev subbodies) - sigma (EConstr.of_constr (nf_beta sigma bodies.(bodynum))) + sigma (nf_beta sigma bodies.(bodynum)) let reduce_mind_case_use_function func env sigma mia = match EConstr.kind sigma mia.mconstr with @@ -689,7 +689,7 @@ let rec red_elim_const env sigma ref u largs = let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (EConstr.of_constr (nf_beta sigma c), rest), nocase) + | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> let rec descend (ref,u) args = let c = reference_value env sigma ref u in @@ -704,14 +704,14 @@ let rec red_elim_const env sigma ref u largs = let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix sigma d) lrest with | NotReducible -> raise Redelimination - | Reduced (c,rest) -> (EConstr.of_constr (nf_beta sigma c), rest), nocase) + | Reduced (c,rest) -> (nf_beta sigma c, rest), nocase) | NotAnElimination when unfold_nonelim -> let c = reference_value env sigma ref u in - (EConstr.of_constr (whd_betaiotazeta sigma (applist (c, largs))), []), nocase + (whd_betaiotazeta sigma (applist (c, largs)), []), nocase | _ -> raise Redelimination with Redelimination when unfold_anyway -> let c = reference_value env sigma ref u in - (EConstr.of_constr (whd_betaiotazeta sigma (applist (c, largs))), []), nocase + (whd_betaiotazeta sigma (applist (c, largs)), []), nocase and reduce_params env sigma stack l = let len = List.length stack in @@ -721,7 +721,7 @@ and reduce_params env sigma stack l = let arg = List.nth stack i in let rarg = whd_construct_stack env sigma arg in match EConstr.kind sigma (fst rarg) with - | Construct _ -> List.assign stack i (EConstr.applist rarg) + | Construct _ -> List.assign stack i (applist rarg) | _ -> raise Redelimination) stack l @@ -817,9 +817,9 @@ and whd_construct_stack env sigma s = *) let try_red_product env sigma c = - let simpfun c = EConstr.of_constr (clos_norm_flags betaiotazeta env sigma c) in + let simpfun c = clos_norm_flags betaiotazeta env sigma c in let rec redrec env x = - let x = EConstr.of_constr (whd_betaiota sigma x) in + let x = whd_betaiota sigma x in match EConstr.kind sigma x with | App (f,l) -> (match EConstr.kind sigma f with @@ -856,7 +856,7 @@ let try_red_product env sigma c = | None -> raise Redelimination | Some c -> c) | _ -> raise Redelimination) - in EConstr.Unsafe.to_constr (redrec env c) + in redrec env c let red_product env sigma c = try try_red_product env sigma c @@ -953,7 +953,7 @@ let hnf_constr = whd_simpl_orelse_delta_but_fix (* The "simpl" reduction tactic *) let whd_simpl env sigma c = - EConstr.Unsafe.to_constr (EConstr.applist (whd_simpl_stack env sigma c)) + applist (whd_simpl_stack env sigma c) let simpl env sigma c = strong whd_simpl env sigma c @@ -1010,7 +1010,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> if locs != [] then ignore (traverse_below (Some (!pos-1)) envc t); let Sigma (t, evm, _) = (f subst).e_redfun env (Sigma.Unsafe.of_evar_map !evd) t in - (evd := Sigma.to_evar_map evm; EConstr.of_constr t) + (evd := Sigma.to_evar_map evm; t) end else traverse_below nested envc t @@ -1029,7 +1029,7 @@ let e_contextually byhead (occs,c) f = { e_redfun = begin fun env sigma t -> in let t' = traverse None (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr t', !evd) + Sigma.Unsafe.of_pair (t', !evd) end } let contextually byhead occs f env sigma t = @@ -1080,7 +1080,7 @@ let string_of_evaluable_ref env = function let unfold env sigma name c = if is_evaluable env name then - EConstr.of_constr (clos_norm_flags (unfold_red name) env sigma c) + clos_norm_flags (unfold_red name) env sigma c else error (string_of_evaluable_ref env name^" is opaque.") @@ -1098,7 +1098,7 @@ let unfoldoccs env sigma (occs,name) c = | [] -> () | _ -> error_invalid_occurrence rest in - EConstr.of_constr (nf_betaiotazeta sigma uc) + nf_betaiotazeta sigma uc in match occs with | NoOccurrences -> c @@ -1108,17 +1108,17 @@ let unfoldoccs env sigma (occs,name) c = (* Unfold reduction tactic: *) let unfoldn loccname env sigma c = - EConstr.Unsafe.to_constr (List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname) + List.fold_left (fun c occname -> unfoldoccs env sigma occname c) c loccname (* Re-folding constants tactics: refold com in term c *) let fold_one_com com env sigma c = let rcom = - try EConstr.of_constr (red_product env sigma com) + try red_product env sigma com with Redelimination -> error "Not reducible." in (* Reason first on the beta-iota-zeta normal form of the constant as unfold produces it, so that the "unfold f; fold f" configuration works to refold fix expressions *) - let a = subst_term sigma (EConstr.of_constr (clos_norm_flags unfold_side_red env sigma rcom)) c in + let a = subst_term sigma (clos_norm_flags unfold_side_red env sigma rcom) c in if not (EConstr.eq_constr sigma a c) then Vars.subst1 com a else @@ -1128,12 +1128,12 @@ let fold_one_com com env sigma c = Vars.subst1 com a let fold_commands cl env sigma c = - EConstr.Unsafe.to_constr (List.fold_right (fun com c -> fold_one_com com env sigma c) (List.rev cl) c) + List.fold_right (fun com c -> fold_one_com com env sigma c) (List.rev cl) c (* call by value reduction functions *) let cbv_norm_flags flags env sigma t = - cbv_norm (create_cbv_infos flags env sigma) t + EConstr.of_constr (cbv_norm (create_cbv_infos flags env sigma) t) let cbv_beta = cbv_norm_flags beta empty_env let cbv_betaiota = cbv_norm_flags betaiota empty_env @@ -1163,7 +1163,7 @@ let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> let abstr_trm, sigma = List.fold_right (abstract_scheme env sigma) loccs_trm (c,sigma) in try let _ = Typing.unsafe_type_of env sigma abstr_trm in - Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr (applist(abstr_trm, List.map snd loccs_trm)), sigma) + Sigma.Unsafe.of_pair (applist(abstr_trm, List.map snd loccs_trm), sigma) with Type_errors.TypeError (env',t) -> raise (ReductionTacticError (InvalidAbstraction (env,sigma,abstr_trm,(env',t)))) end } @@ -1189,7 +1189,6 @@ let check_not_primitive_record env ind = let reduce_to_ind_gen allow_product env sigma t = let rec elimrec env t l = let t = hnf_constr env sigma t in - let t = EConstr.of_constr t in match EConstr.kind sigma (fst (decompose_app_vect sigma t)) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> @@ -1202,7 +1201,6 @@ let reduce_to_ind_gen allow_product env sigma t = (* Last chance: we allow to bypass the Opaque flag (as it was partially the case between V5.10 and V8.1 *) let t' = whd_all env sigma t in - let t' = EConstr.of_constr t' in match EConstr.kind sigma (fst (decompose_app_vect sigma t')) with | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) | _ -> user_err (str"Not an inductive product.") @@ -1285,7 +1283,6 @@ let reduce_to_ref_gen allow_product env sigma ref t = with Not_found -> try let t' = nf_betaiota sigma (one_step_reduce env sigma t) in - let t' = EConstr.of_constr t' in elimrec env t' l with NotStepReducible -> error_cannot_recognize ref in diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index f59a6dcd94..9ee34341ba 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -291,6 +291,7 @@ let build_subclasses ~check env sigma glob pri = let instapp = Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect 0 rels))) in + let instapp = EConstr.Unsafe.to_constr instapp in let projargs = Array.of_list (args @ [instapp]) in let projs = List.map_filter (fun (n, b, proj) -> diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 40ef2450a3..f67e0bddc7 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -53,7 +53,7 @@ let inductive_type_knowing_parameters env sigma (ind,u) jl = EConstr.of_constr (Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp) let e_type_judgment env evdref j = - match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref j.uj_type)) with + match EConstr.kind !evdref (whd_all env !evdref j.uj_type) with | Sort s -> {utj_val = j.uj_val; utj_type = s } | Evar ev -> let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in @@ -71,7 +71,7 @@ let e_judge_of_apply env evdref funj argjv = { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ } | hj::restjl -> - match EConstr.kind !evdref (EConstr.of_constr (whd_all env !evdref typ)) with + match EConstr.kind !evdref (whd_all env !evdref typ) with | Prod (_,c1,c2) -> if Evarconv.e_cumul env evdref hj.uj_type c1 then apply_rec (n+1) (subst1 hj.uj_val c2) restjl @@ -104,7 +104,7 @@ let e_is_correct_arity env evdref c pj ind specif params = let allowed_sorts = elim_sorts specif in let error () = Pretype_errors.error_elim_arity env !evdref ind allowed_sorts c pj None in let rec srec env pt ar = - let pt' = EConstr.of_constr (whd_all env !evdref pt) in + let pt' = whd_all env !evdref pt in match EConstr.kind !evdref pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> if not (Evarconv.e_cumul env evdref a1 (EConstr.of_constr a1')) then error (); @@ -144,7 +144,6 @@ let e_type_case_branches env evdref (ind,largs) pj c = let lc = Array.map EConstr.of_constr lc in let n = (snd specif).Declarations.mind_nrealdecls in let ty = whd_betaiota !evdref (lambda_applist_assum !evdref (n+1) p (realargs@[c])) in - let ty = EConstr.of_constr ty in (lc, ty) let e_judge_of_case env evdref ci pj cj lfj = diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 169dd45bc8..8a8649f111 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -75,7 +75,6 @@ let occur_meta_evd sigma mv c = let rec occrec c = (* Note: evars are not instantiated by terms with metas *) let c = whd_meta sigma c in - let c = EConstr.of_constr c in match EConstr.kind sigma c with | Meta mv' when Int.equal mv mv' -> raise Occur | _ -> EConstr.iter sigma occrec c @@ -1003,24 +1002,24 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l1)))) cN + (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l2)))) + (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb opt substn cM - (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l2)))) + (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb opt substn - (EConstr.of_constr (whd_betaiotazeta sigma (mkApp(c,l1)))) cN + (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> error_cannot_unify curenv sigma (cM,cN))) @@ -1233,7 +1232,7 @@ let applyHead env (type r) (evd : r Sigma.t) n c = Sigma (c, evd, p) else let sigma = Sigma.to_evar_map evd in - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma cty)) with + match EConstr.kind sigma (whd_all env sigma cty) with | Prod (_,c1,c2) -> let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' @@ -1263,7 +1262,7 @@ let w_coerce_to_type env evd c cty mvty = but there are cases where it though it was not rigid (like in fst (nat,nat)) and stops while it could have seen that it is rigid *) let cty = Tacred.hnf_constr env evd cty in - try_to_coerce env evd c (EConstr.of_constr cty) tycon + try_to_coerce env evd c cty tycon let w_coerce env evd mv c = let cty = get_type_of env evd c in @@ -1276,7 +1275,6 @@ let unify_to_type env sigma flags c status u = let t = get_type_of env sigma (nf_meta sigma c) in let t = EConstr.of_constr t in let t = nf_betaiota sigma (nf_meta sigma t) in - let t = EConstr.of_constr t in unify_0 env sigma CUMUL flags t u let unify_type env sigma flags mv status c = @@ -1379,7 +1377,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = else let evd' = if occur_meta_evd evd mv c then - if isMetaOf mv (whd_all env evd c) then evd + if isMetaOf evd mv (whd_all env evd c) then evd else error_cannot_unify env evd (mkMeta mv,c) else meta_assign mv (EConstr.Unsafe.to_constr c,(status,TypeProcessed)) evd in @@ -1618,7 +1616,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = (fun test -> match test.testing_state with | None -> None | Some (sigma,_,l) -> - let c = applist (EConstr.of_constr (nf_evar sigma (local_strong whd_meta sigma c)), l) in + let c = applist (EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr (local_strong whd_meta sigma c))), l) in let univs, subst = nf_univ_variables sigma in Some (sigma,EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr c)))) @@ -1877,7 +1875,6 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = List.fold_right (fun op (evd,l) -> let op = whd_meta evd op in - let op = EConstr.of_constr op in if isMeta evd op then if flags.allow_K_in_toplevel_higher_order_unification then (evd,op::l) else error_abstraction_over_meta env evd hdmeta (destMeta evd op) @@ -1983,8 +1980,8 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = - let hd1,l1 = decompose_app_vect evd (EConstr.of_constr (whd_nored evd ty1)) in - let hd2,l2 = decompose_app_vect evd (EConstr.of_constr (whd_nored evd ty2)) in + let hd1,l1 = decompose_app_vect evd (whd_nored evd ty1) in + let hd2,l2 = decompose_app_vect evd (whd_nored evd ty2) in let is_empty1 = Array.is_empty l1 in let is_empty2 = Array.is_empty l2 in match EConstr.kind evd hd1, not is_empty1, EConstr.kind evd hd2, not is_empty2 with diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index 31693d82f7..74998349be 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -360,7 +360,7 @@ let cbv_vm env sigma c t = let c = EConstr.to_constr sigma c in let t = EConstr.to_constr sigma t in let v = Vconv.val_of_constr env c in - nf_val env sigma v t + EConstr.of_constr (nf_val env sigma v t) let vm_infer_conv ?(pb=Reduction.CUMUL) env sigma t1 t2 = Reductionops.infer_conv_gen (fun pb ~l2r sigma ts -> Vconv.vm_conv_gen pb) diff --git a/pretyping/vnorm.mli b/pretyping/vnorm.mli index 650f3f2911..8a4202c887 100644 --- a/pretyping/vnorm.mli +++ b/pretyping/vnorm.mli @@ -10,4 +10,4 @@ open EConstr open Environ (** {6 Reduction functions } *) -val cbv_vm : env -> Evd.evar_map -> constr -> types -> Constr.t +val cbv_vm : env -> Evd.evar_map -> constr -> types -> constr -- cgit v1.2.3 From fa638c3e71752b6a59261776b36f1bed7d9c26d2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 12:07:55 +0100 Subject: Cc API using EConstr. --- pretyping/reductionops.ml | 8 ++++++++ pretyping/reductionops.mli | 1 + 2 files changed, 9 insertions(+) (limited to 'pretyping') diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 45e7abcb79..c796a91caa 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -1221,6 +1221,14 @@ let clos_norm_flags flgs env sigma t = (CClosure.inject (EConstr.Unsafe.to_constr t))) with e when is_anomaly e -> error "Tried to normalize ill-typed term" +let clos_whd_flags flgs env sigma t = + try + let evars ev = safe_evar_value sigma ev in + EConstr.of_constr (CClosure.whd_val + (CClosure.create_clos_infos ~evars flgs env) + (CClosure.inject (EConstr.Unsafe.to_constr t))) + with e when is_anomaly e -> error "Tried to normalize ill-typed term" + let nf_beta = clos_norm_flags CClosure.beta (Global.env ()) let nf_betaiota = clos_norm_flags CClosure.betaiota (Global.env ()) let nf_betaiotazeta = clos_norm_flags CClosure.betaiotazeta (Global.env ()) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index add1d186bb..8aaeeb2c21 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -149,6 +149,7 @@ val iterate_whd_gen : bool -> CClosure.RedFlags.reds -> (** {6 Generic Optimized Reduction Function using Closures } *) val clos_norm_flags : CClosure.RedFlags.reds -> reduction_function +val clos_whd_flags : CClosure.RedFlags.reds -> reduction_function (** Same as [(strong whd_beta[delta][iota])], but much faster on big terms *) val nf_beta : local_reduction_function -- cgit v1.2.3 From b36adb2124d3ba8a5547605e7f89bb0835d0ab10 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 15:50:17 +0100 Subject: Removing some return type compatibility layers in Termops. --- pretyping/cases.ml | 1 - pretyping/detyping.ml | 8 +++++--- pretyping/evarconv.ml | 2 +- pretyping/evarsolve.ml | 4 ++-- pretyping/inductiveops.ml | 4 ++-- pretyping/program.ml | 2 +- pretyping/reductionops.ml | 8 ++++---- 7 files changed, 15 insertions(+), 14 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index c0141f0116..01e2db08cb 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1690,7 +1690,6 @@ let abstract_tycon loc env evdref subst tycon extenv t = (named_context extenv) in let filter = Filter.make (rel_filter @ named_filter) in let candidates = u :: List.map mkRel vl in - let candidates = List.map EConstr.Unsafe.to_constr candidates in let ev = e_new_evar extenv evdref ~src ~filter ~candidates ty in lift k ev in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 87561868f7..3d5a5f0259 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -210,16 +210,18 @@ let computable p k = && noccur_between 1 (k+1) ccl +let pop t = Vars.lift (-1) t + let lookup_name_as_displayed env t s = let rec lookup avoid n c = match kind_of_term c with | Prod (name,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' - | (Anonymous,avoid') -> lookup avoid' (n+1) (pop (EConstr.of_constr c'))) + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> (match compute_displayed_name_in RenamingForGoal avoid name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' - | (Anonymous,avoid') -> lookup avoid' (n+1) (pop (EConstr.of_constr c'))) + | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c | _ -> None in lookup (ids_of_named_context (named_context env)) 1 t @@ -439,7 +441,7 @@ let detype_instance sigma l = else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) let rec detype flags avoid env sigma t = - match kind_of_term (collapse_appl sigma (EConstr.of_constr t)) with + match kind_of_term (EConstr.Unsafe.to_constr (collapse_appl sigma (EConstr.of_constr t))) with | Rel n -> (try match lookup_name_of_rel n (fst env) with | Name id -> GVar (dl, id) diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 9675ae2ea9..6dce8627da 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -147,7 +147,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = let _, a, b = destProd sigma t2 in if noccurn sigma 1 b then lookup_canonical_conversion (proji, Prod_cs), - (Stack.append_app [|a;EConstr.of_constr (pop b)|] Stack.empty) + (Stack.append_app [|a;pop b|] Stack.empty) else raise Not_found | Sort s -> lookup_canonical_conversion diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 27436fdd8b..3003620d7e 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -189,8 +189,8 @@ let restrict_evar_key evd evk filter candidates = | None -> evar_filter evi | Some filter -> filter in let candidates = match candidates with - | NoUpdate -> evi.evar_candidates - | UpdateWith c -> Some (List.map EConstr.Unsafe.to_constr c) in + | NoUpdate -> Option.map (fun l -> List.map EConstr.of_constr l) evi.evar_candidates + | UpdateWith c -> Some c in let sigma = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, sigma, _) = restrict_evar sigma evk filter candidates in (Sigma.to_evar_map sigma, evk) diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 120adb9fef..1dcd6399e7 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -443,7 +443,7 @@ let build_branch_type env dep p cs = (applist (base,[build_dependent_constructor cs])) cs.cs_args else - it_mkProd_or_LetIn base cs.cs_args + Term.it_mkProd_or_LetIn base cs.cs_args (**************************************************) @@ -575,7 +575,7 @@ let arity_of_case_predicate env (ind,params) dep k = let arsign,_ = get_arity env (ind,params) in let mind = build_dependent_inductive env (ind,params) in let concl = if dep then mkArrow mind (mkSort k) else mkSort k in - it_mkProd_or_LetIn concl arsign + Term.it_mkProd_or_LetIn concl arsign (***********************************************) (* Inferring the sort of parameters of a polymorphic inductive type diff --git a/pretyping/program.ml b/pretyping/program.ml index 8ec6083f71..caa5a5c8a6 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -31,7 +31,7 @@ let init_reference dir s () = coq_reference "Program" dir s let papp evdref r args = let open EConstr in let gr = delayed_force r in - mkApp (EConstr.of_constr (Evarutil.e_new_global evdref gr), args) + mkApp (Evarutil.e_new_global evdref gr, args) let sig_typ = init_reference ["Init"; "Specif"] "sig" let sig_intro = init_reference ["Init"; "Specif"] "exist" diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index c796a91caa..90c5b241b8 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -203,10 +203,10 @@ module Cst_stack = struct let reconstruct_head = List.fold_left (fun t (i,args) -> mkApp (t,Array.sub args i (Array.length args - i))) in List.fold_right - (fun (cst,params,args) t -> EConstr.of_constr (Termops.replace_term sigma + (fun (cst,params,args) t -> Termops.replace_term sigma (reconstruct_head d args) (applist (cst, List.rev params)) - t)) cst_l c + t) cst_l c let pr l = let open Pp in @@ -969,7 +969,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in let u = if Int.equal napp 1 then f else mkApp (f,lc) in - if noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty),Cst_stack.empty else fold () + if noccurn sigma 1 u then (pop u,Stack.empty),Cst_stack.empty else fold () | _ -> fold () else fold () | _ -> fold ()) @@ -1068,7 +1068,7 @@ let local_whd_state_gen flags sigma = | Rel 1, [] -> let lc = Array.sub cl 0 (napp-1) in let u = if Int.equal napp 1 then f else mkApp (f,lc) in - if noccurn sigma 1 u then (EConstr.of_constr (pop u),Stack.empty) else s + if noccurn sigma 1 u then (pop u,Stack.empty) else s | _ -> s else s | _ -> s) -- cgit v1.2.3 From 531590c223af42c07a93142ab0cea470a98964e6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 17:15:15 +0100 Subject: Removing compatibility layers in Retyping --- pretyping/cases.ml | 12 +++------- pretyping/classops.ml | 1 + pretyping/coercion.ml | 4 ++-- pretyping/detyping.ml | 2 +- pretyping/evarconv.ml | 6 ++--- pretyping/evarsolve.ml | 59 +++++++++++++++++++++++++++--------------------- pretyping/evarsolve.mli | 4 ++-- pretyping/pretyping.ml | 7 +----- pretyping/retyping.ml | 10 ++++---- pretyping/retyping.mli | 17 +++++++------- pretyping/tacred.ml | 1 - pretyping/typeclasses.ml | 4 ++-- pretyping/typing.ml | 4 ++-- pretyping/typing.mli | 4 ++-- pretyping/unification.ml | 24 ++++++-------------- 15 files changed, 73 insertions(+), 86 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 01e2db08cb..565a9725c2 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -1502,7 +1502,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = if not (Flags.is_program_mode ()) && (isRel sigma orig || isVar sigma orig) then (* Try to compile first using non expanded alias *) try - if initial then f orig (EConstr.of_constr (Retyping.get_type_of pb.env sigma orig)) + if initial then f orig (Retyping.get_type_of pb.env sigma orig) else just_pop () with e when precatchable_exception e -> (* Try then to compile using expanded alias *) @@ -1517,7 +1517,7 @@ and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = (* Could be needed in case of a recursive call which requires to be on a variable for size reasons *) pb.evdref := sigma; - if initial then f orig (EConstr.of_constr (Retyping.get_type_of pb.env !(pb.evdref) orig)) + if initial then f orig (Retyping.get_type_of pb.env !(pb.evdref) orig) else just_pop () @@ -1650,13 +1650,12 @@ let abstract_tycon loc env evdref subst tycon extenv t = | Rel n when is_local_def (lookup_rel n env) -> t | Evar ev -> let ty = get_type_of env !evdref t in - let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref (EConstr.of_constr ty) in + let ty = Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in let inst = List.map_i (fun i _ -> try list_assoc_in_triple i subst0 with Not_found -> mkRel i) 1 (rel_context env) in - let ty = EConstr.of_constr ty in let ev' = e_new_evar env evdref ~src ty in begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with | Success evd -> evdref := evd @@ -1672,10 +1671,8 @@ let abstract_tycon loc env evdref subst tycon extenv t = let vl = List.map pi1 good in let ty = let ty = get_type_of env !evdref t in - let ty = EConstr.of_constr ty in Evarutil.evd_comb1 (refresh_universes (Some false) env) evdref ty in - let ty = EConstr.of_constr ty in let ty = lift (-k) (aux x ty) in let depvl = free_rels !evdref ty in let inst = @@ -1708,7 +1705,6 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in let evd,tt = Typing.type_of extenv !evdref t in - let tt = EConstr.of_constr tt in evdref := evd; (t,tt) in let b = e_cumul env evdref tt (mkSort s) (* side effect *) in @@ -2109,7 +2105,6 @@ let constr_of_pat env evdref arsign pat avoid = let app = applist (cstr, List.map (lift (List.length sign)) params) in let app = applist (app, args) in let apptype = Retyping.get_type_of env ( !evdref) app in - let apptype = EConstr.of_constr apptype in let IndType (indf, realargs) = find_rectype env (!evdref) apptype in match alias with Anonymous -> @@ -2370,7 +2365,6 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let t = RelDecl.get_type decl in let t = EConstr.of_constr t in let argt = Retyping.get_type_of env !evdref arg in - let argt = EConstr.of_constr argt in let eq, refl_arg = if Reductionops.is_conv env !evdref argt t then (mk_eq evdref (lift (nargeqs + slift) argt) diff --git a/pretyping/classops.ml b/pretyping/classops.ml index e4331aade2..13310c44d5 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -442,6 +442,7 @@ let cache_coercion (_, c) = let it, _ = class_info c.coercion_target in let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in let typ = Retyping.get_type_of (Global.env ()) Evd.empty (EConstr.of_constr value) in + let typ = EConstr.Unsafe.to_constr typ in let xf = { coe_value = value; coe_type = typ; diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 7e85596308..f569d9fc4a 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -66,7 +66,7 @@ let apply_coercion_args env evd check isproj argl funj = | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas a faire hnf_constr *) match EConstr.kind !evdref (whd_all env !evdref typ) with | Prod (_,c1,c2) -> - if check && not (e_cumul env evdref (EConstr.of_constr (Retyping.get_type_of env !evdref h)) c1) then + if check && not (e_cumul env evdref (Retyping.get_type_of env !evdref h) c1) then raise NoCoercion; apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") @@ -498,7 +498,7 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = let v2 = Option.map (fun v -> beta_applist evd' (lift 1 v,[v1])) v in let t2 = match v2 with | None -> subst_term evd' v1 t2 - | Some v2 -> EConstr.of_constr (Retyping.get_type_of env1 evd' v2) in + | Some v2 -> Retyping.get_type_of env1 evd' v2 in let (evd'',v2') = inh_conv_coerce_to_fail loc env1 evd' rigidonly v2 t2 u2 in (evd'', Option.map (fun v2' -> mkLambda (name, u1, v2')) v2') | _ -> raise (NoCoercionNoUnifier (best_failed_evd,e)) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 3d5a5f0259..d4e156fa4b 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -504,7 +504,7 @@ let rec detype flags avoid env sigma t = let pb = Environ.lookup_projection p (snd env) in let body = pb.Declarations.proj_body in let ty = Retyping.get_type_of (snd env) sigma (EConstr.of_constr c) in - let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma (EConstr.of_constr ty) in + let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in let args = List.map EConstr.Unsafe.to_constr args in let body' = strip_lam_assum body in let body' = subst_instance_constr u body' in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 6dce8627da..afb0bf6d5a 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -168,7 +168,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = | Some c -> (* A primitive projection applied to c *) let ty = Retyping.get_type_of ~lax:true env sigma c in let (i,u), ind_args = - try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) + try Inductiveops.find_mrectype env sigma ty with _ -> raise Not_found in Stack.append_app_list ind_args Stack.empty, c, sk1 | None -> @@ -882,7 +882,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) List.fold_left (fun (i,ks,m,test) b -> if match n with Some n -> Int.equal m n | None -> false then - let ty = EConstr.of_constr (Retyping.get_type_of env i t2) in + let ty = Retyping.get_type_of env i t2 in let test i = evar_conv_x trs env i CUMUL ty (substl ks b) in (i,t2::ks, m-1, test) else @@ -1052,7 +1052,7 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = let id = NamedDecl.get_id decl' in let t = EConstr.of_constr (NamedDecl.get_type decl') in let evs = ref [] in - let ty = EConstr.of_constr (Retyping.get_type_of env_rhs evd c) in + let ty = Retyping.get_type_of env_rhs evd c in let filter' = filter_possible_projections evd c ty ctxt args in (id,t,c,ty,evs,Filter.make filter',occs) :: make_subst (ctxt',l,occsl) | _, _, [] -> [] diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 3003620d7e..de2e46a781 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -23,6 +23,14 @@ open Evarutil open Pretype_errors open Sigma.Notations +let nlocal_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + Context.Named.Declaration.LocalAssum (na, inj t) + +let nlocal_def (na, b, t) = + let inj = EConstr.Unsafe.to_constr in + Context.Named.Declaration.LocalDef (na, inj b, inj t) + let normalize_evar evd ev = match EConstr.kind evd (mkEvar ev) with | Evar (evk,args) -> (evk,args) @@ -108,11 +116,11 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) | Some dir -> refresh status dir t) else (refresh_term_evars false true t; t) in - if !modified then !evdref, EConstr.Unsafe.to_constr t' else !evdref, EConstr.Unsafe.to_constr t + if !modified then !evdref, t' else !evdref, t let get_type_of_refresh ?(polyprop=true) ?(lax=false) env sigma c = let ty = Retyping.get_type_of ~polyprop ~lax env sigma c in - refresh_universes (Some false) env sigma (EConstr.of_constr ty) + refresh_universes (Some false) env sigma ty (************************) @@ -146,7 +154,7 @@ let recheck_applications conv_algo env evdref t = | App (f, args) -> let () = aux env f in let fty = Retyping.get_type_of env !evdref f in - let argsty = Array.map (fun x -> aux env x; EConstr.of_constr (Retyping.get_type_of env !evdref x)) args in + let argsty = Array.map (fun x -> aux env x; Retyping.get_type_of env !evdref x) args in let rec aux i ty = if i < Array.length argsty then match EConstr.kind !evdref (whd_all env !evdref ty) with @@ -158,7 +166,7 @@ let recheck_applications conv_algo env evdref t = Pretype_errors.error_cannot_unify env evd ~reason (argsty.(i), dom)) | _ -> raise (IllTypedInstance (env, ty, argsty.(i))) else () - in aux 0 (EConstr.of_constr fty) + in aux 0 fty | _ -> iter_with_full_binders !evdref (fun d env -> push_rel d env) aux env t in aux env t @@ -173,7 +181,7 @@ type 'a update = | NoUpdate open Context.Named.Declaration -let inst_of_vars sign = Array.map_of_list (get_id %> EConstr.mkVar) sign +let inst_of_vars sign = Array.map_of_list (get_id %> mkVar) sign let restrict_evar_key evd evk filter candidates = match filter, candidates with @@ -413,9 +421,9 @@ let free_vars_and_rels_up_alias_expansion sigma aliases c = let rec expand_and_check_vars sigma aliases = function | [] -> [] - | a::l when EConstr.isRel sigma a || EConstr.isVar sigma a -> + | a::l when isRel sigma a || isVar sigma a -> let a = expansion_of_var sigma aliases a in - if EConstr.isRel sigma a || EConstr.isVar sigma a then a :: expand_and_check_vars sigma aliases l + if isRel sigma a || isVar sigma a then a :: expand_and_check_vars sigma aliases l else raise Exit | _ -> raise Exit @@ -480,7 +488,7 @@ let is_unification_pattern_meta env evd nb m l t = (* so we need to be a rel <= nb *) if List.for_all (fun x -> isRel evd x && destRel evd x <= nb) l then match find_unification_pattern_args env evd l t with - | Some _ as x when not (dependent evd (EConstr.mkMeta m) t) -> x + | Some _ as x when not (dependent evd (mkMeta m) t) -> x | _ -> None else None @@ -591,15 +599,15 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd (EConstr.of_constr ty_t_in_sign) ~filter ~src inst_in_env in + let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in let evd = Sigma.to_evar_map evd in let t_in_env = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr t_in_env)) in let (evk, _) = destEvar evd evar_in_env in - let evd = define_fun env evd None (EConstr.destEvar evd evar_in_env) t_in_env in + let evd = define_fun env evd None (destEvar evd evar_in_env) t_in_env in let ctxt = named_context_of_val sign in let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in let evar_in_sign = mkEvar (evk, inst_in_sign) in - (evd,whd_evar evd (EConstr.Unsafe.to_constr evar_in_sign)) + (evd,EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr evar_in_sign))) (* We have x1..xq |- ?e1 : τ and had to solve something like * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some @@ -624,7 +632,7 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = if Evd.is_defined evd evk1 then (* Some circularity somewhere (see e.g. #3209) *) raise MorePreciseOccurCheckNeeeded; - let (evk1,args1) = EConstr.destEvar evd (EConstr.mkEvar (evk1,args1)) in + let (evk1,args1) = destEvar evd (mkEvar (evk1,args1)) in let evi1 = Evd.find_undefined evd evk1 in let env1,rel_sign = env_rel_context_chop k env in let sign1 = evar_hyps evi1 in @@ -641,16 +649,16 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let t_in_env = EConstr.of_constr t_in_env in let s = Retyping.get_sort_of env evd t_in_env in let evd,ty_t_in_sign = refresh_universes - ~status:univ_flexible (Some false) env evd (EConstr.mkSort s) in + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in let evd,d' = match d with - | LocalAssum _ -> evd, Context.Named.Declaration.LocalAssum (id,t_in_sign) + | LocalAssum _ -> evd, nlocal_assum (id,t_in_sign) | LocalDef (_,b,_) -> let b = EConstr.of_constr b in let evd,b = define_evar_from_virtual_equation define_fun env evd src b t_in_sign sign filter inst_in_env in - evd, Context.Named.Declaration.LocalDef (id,b,t_in_sign) in + evd, nlocal_def (id,b,t_in_sign) in (push_named_context_val d' sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), @@ -661,11 +669,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let evd,ev2ty_in_sign = let s = Retyping.get_sort_of env evd ty_in_env in let evd,ty_t_in_sign = refresh_universes - ~status:univ_flexible (Some false) env evd (EConstr.mkSort s) in + ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src ty_in_env ty_t_in_sign sign2 filter2 inst2_in_env in let evd = Sigma.Unsafe.of_evar_map evd in - let ev2ty_in_sign = EConstr.of_constr ev2ty_in_sign in let Sigma (ev2_in_sign, evd, _) = new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in let evd = Sigma.to_evar_map evd in @@ -899,7 +906,7 @@ let extract_unique_projection = function let extract_candidates sols = try UpdateWith - (List.map (function (id,ProjectVar) -> EConstr.mkVar id | _ -> raise Exit) sols) + (List.map (function (id,ProjectVar) -> mkVar id | _ -> raise Exit) sols) with Exit -> NoUpdate @@ -1171,7 +1178,7 @@ let check_evar_instance evd evk1 body conv_algo = (* FIXME: The body might be ill-typed when this is called from w_merge *) (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) let ty = - try EConstr.of_constr (Retyping.get_type_of ~lax:true evenv evd body) + try Retyping.get_type_of ~lax:true evenv evd body with Retyping.RetypeError _ -> error "Ill-typed evar instance" in match conv_algo evenv evd Reduction.CUMUL ty (EConstr.of_constr evi.evar_concl) with @@ -1378,7 +1385,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | (id,p)::_::_ -> if choose then (mkVar id, p) else raise (NotUniqueInType sols) in - let ty = lazy (EConstr.of_constr (Retyping.get_type_of env !evdref t)) in + let ty = lazy (Retyping.get_type_of env !evdref t) in let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in evdref := evd; c @@ -1440,7 +1447,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = if not !progress then raise (NotEnoughInformationEvarEvar t); (* Make the virtual left evar real *) - let ty = EConstr.of_constr (get_type_of env' evd t) in + let ty = get_type_of env' evd t in let (evd,evar'',ev'') = materialize_evar (evar_define conv_algo ~choose) env' evd k ev ty in (* materialize_evar may instantiate ev' by another evar; adjust it *) @@ -1474,7 +1481,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | _ -> None with | Some l -> - let ty = EConstr.of_constr (get_type_of env' !evdref t) in + let ty = get_type_of env' !evdref t in let candidates = try let t = @@ -1563,15 +1570,15 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = str "----> " ++ int ev ++ str " := " ++ print_constr body); raise e in*) - let evd' = check_evar_instance evd' evk (EConstr.of_constr body) conv_algo in - Evd.define evk body evd' + let evd' = check_evar_instance evd' evk body conv_algo in + Evd.define evk (EConstr.Unsafe.to_constr body) evd' with | NotEnoughInformationToProgress sols -> postpone_non_unique_projection env evd pbty ev sols rhs | NotEnoughInformationEvarEvar t -> - add_conv_oriented_pb (pbty,env,EConstr.mkEvar ev,t) evd + add_conv_oriented_pb (pbty,env,mkEvar ev,t) evd | MorePreciseOccurCheckNeeeded -> - add_conv_oriented_pb (pbty,env,EConstr.mkEvar ev,rhs) evd + add_conv_oriented_pb (pbty,env,mkEvar ev,rhs) evd | NotInvertibleUsingOurAlgorithm _ | MetaOccurInBodyInternal as e -> raise e | OccurCheckIn (evd,rhs) -> diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index b83147514b..f2102f8cd1 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -42,7 +42,7 @@ val refresh_universes : (* Also refresh Prop and Set universes, so that the returned type can be any supertype of the original type *) bool option (* direction: true for levels lower than the existing levels *) -> - env -> evar_map -> types -> evar_map * Constr.types + env -> evar_map -> types -> evar_map * types val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> bool option -> existential_key -> constr array -> constr array -> evar_map @@ -77,4 +77,4 @@ val remove_instance_local_defs : evar_map -> existential_key -> 'a array -> 'a list val get_type_of_refresh : - ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * Constr.types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> evar_map * types diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 7d2c96bb90..a0d8faab44 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -426,7 +426,7 @@ let invert_ltac_bound_name lvar env id0 id = str " which is not bound in current context.") let protected_get_type_of env sigma c = - try EConstr.of_constr (Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c) + try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c with Retyping.RetypeError _ -> user_err (str "Cannot reinterpret " ++ quote (print_constr (EConstr.Unsafe.to_constr c)) ++ @@ -774,9 +774,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre refreshed right away. *) let c = mkApp (f, args) in let c = evd_comb1 (Evarsolve.refresh_universes (Some true) env.ExtraEnv.env) evdref c in - let c = EConstr.of_constr c in let t = Retyping.get_type_of env.ExtraEnv.env !evdref c in - let t = EConstr.of_constr t in make_judge c (* use this for keeping evars: resj.uj_val *) t else resj | _ -> resj @@ -840,7 +838,6 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let t = evd_comb1 (Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) evdref j.uj_type in - let t = EConstr.of_constr t in (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) @@ -1025,7 +1022,6 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let tval = evd_comb1 (Evarsolve.refresh_universes ~onlyalg:true ~status:Evd.univ_flexible (Some false) env.ExtraEnv.env) evdref tj.utj_val in - let tval = EConstr.of_constr tval in let tval = nf_evar !evdref tval in let cj, tval = match k with | VMcast -> @@ -1097,7 +1093,6 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let s = let sigma = !evdref in let t = Retyping.get_type_of env.ExtraEnv.env sigma v in - let t = EConstr.of_constr t in match EConstr.kind sigma (whd_all env.ExtraEnv.env sigma t) with | Sort s -> s | Evar ev when is_Type (existential_type sigma ev) -> diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 7db30bf234..a9529d560c 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -109,7 +109,7 @@ let retype ?(polyprop=true) sigma = lift n ty | Var id -> type_of_var env id | Const cst -> EConstr.of_constr (rename_type_of_constant env cst) - | Evar (evk, args) -> EConstr.of_constr (Evd.existential_type sigma (evk, Array.map EConstr.Unsafe.to_constr args)) + | Evar ev -> existential_type sigma ev | Ind ind -> EConstr.of_constr (rename_type_of_inductive env ind) | Construct cstr -> EConstr.of_constr (rename_type_of_constructor env cstr) | Case (_,p,c,lf) -> @@ -210,7 +210,7 @@ let get_sort_of ?(polyprop=true) env sigma t = let get_sort_family_of ?(polyprop=true) env sigma c = let _,_,f,_ = retype ~polyprop sigma in anomaly_on_error (f env) c let type_of_global_reference_knowing_parameters env sigma c args = - let _,_,_,f = retype sigma in EConstr.Unsafe.to_constr (anomaly_on_error (f env c) args) + let _,_,_,f = retype sigma in anomaly_on_error (f env c) args let type_of_global_reference_knowing_conclusion env sigma c conclty = match EConstr.kind sigma c with @@ -238,10 +238,10 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_,_ = retype ~polyprop sigma in - if lax then EConstr.Unsafe.to_constr (f env c) else EConstr.Unsafe.to_constr (anomaly_on_error (f env) c) + if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) -let get_judgment_of env evc c = { uj_val = c; uj_type = EConstr.of_constr (get_type_of env evc c) } +let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } (* Returns sorts of a context *) let sorts_of_context env evc ctxt = @@ -256,7 +256,7 @@ let sorts_of_context env evc ctxt = let expand_projection env sigma pr c args = let ty = get_type_of ~lax:true env sigma c in let (i,u), ind_args = - try Inductiveops.find_mrectype env sigma (EConstr.of_constr ty) + try Inductiveops.find_mrectype env sigma ty with Not_found -> retype_error BadRecursiveType in mkApp (mkConstU (Projection.constant pr,u), diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index a20b11b76e..ce9e1635fc 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -9,6 +9,7 @@ open Term open Evd open Environ +open EConstr (** This family of functions assumes its constr argument is known to be well-typable. It does not type-check, just recompute the type @@ -26,25 +27,25 @@ type retype_error exception RetypeError of retype_error val get_type_of : - ?polyprop:bool -> ?lax:bool -> env -> evar_map -> EConstr.constr -> types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types val get_sort_of : - ?polyprop:bool -> env -> evar_map -> EConstr.types -> sorts + ?polyprop:bool -> env -> evar_map -> types -> sorts val get_sort_family_of : - ?polyprop:bool -> env -> evar_map -> EConstr.types -> sorts_family + ?polyprop:bool -> env -> evar_map -> types -> sorts_family (** Makes an unsafe judgment from a constr *) -val get_judgment_of : env -> evar_map -> EConstr.constr -> EConstr.unsafe_judgment +val get_judgment_of : env -> evar_map -> constr -> unsafe_judgment -val type_of_global_reference_knowing_parameters : env -> evar_map -> EConstr.constr -> - EConstr.constr array -> types +val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> + constr array -> types val type_of_global_reference_knowing_conclusion : - env -> evar_map -> EConstr.constr -> EConstr.types -> evar_map * EConstr.types + env -> evar_map -> constr -> types -> evar_map * types val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list -val expand_projection : env -> evar_map -> Names.projection -> EConstr.constr -> EConstr.constr list -> EConstr.constr +val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr val print_retype_error : retype_error -> Pp.std_ppcmds diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 02524f8962..3fc01c86c6 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1148,7 +1148,6 @@ let compute = cbv_betadeltaiota let abstract_scheme env sigma (locc,a) (c, sigma) = let ta = Retyping.get_type_of env sigma a in - let ta = EConstr.of_constr ta in let na = named_hd env (EConstr.to_constr sigma ta) Anonymous in if occur_meta sigma ta then error "Cannot find a type for the generalisation."; if occur_meta sigma a then diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 9ee34341ba..9da7005e09 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -270,7 +270,7 @@ let add_class cl = let check_instance env sigma c = try let (evd, c) = resolve_one_typeclass env sigma - (EConstr.of_constr (Retyping.get_type_of env sigma c)) in + (Retyping.get_type_of env sigma c) in not (Evd.has_undefined evd) with e when CErrors.noncritical e -> false @@ -314,7 +314,7 @@ let build_subclasses ~check env sigma glob pri = let declare_proj hints (cref, pri, body) = let path' = cref :: path in let ty = Retyping.get_type_of env sigma (EConstr.of_constr body) in - let rest = aux pri body (EConstr.of_constr ty) path' in + let rest = aux pri body ty path' in hints @ (path', pri, body) :: rest in List.fold_left declare_proj [] projs in diff --git a/pretyping/typing.ml b/pretyping/typing.ml index f67e0bddc7..d24160ea54 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -395,7 +395,7 @@ let type_of ?(refresh=false) env evd c = (* side-effect on evdref *) if refresh then Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type - else !evdref, EConstr.Unsafe.to_constr j.uj_type + else !evdref, j.uj_type let e_type_of ?(refresh=false) env evdref c = let env = enrich_env env evdref in @@ -405,7 +405,7 @@ let e_type_of ?(refresh=false) env evdref c = let evd, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env !evdref j.uj_type in let () = evdref := evd in c - else EConstr.Unsafe.to_constr j.uj_type + else j.uj_type let e_solve_evars env evdref c = let env = enrich_env env evdref in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 94a56b6e11..bf26358a22 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -19,10 +19,10 @@ val unsafe_type_of : env -> evar_map -> EConstr.constr -> types (** Typecheck a term and return its type + updated evars, optionally refreshing universes *) -val type_of : ?refresh:bool -> env -> evar_map -> EConstr.constr -> evar_map * types +val type_of : ?refresh:bool -> env -> evar_map -> EConstr.constr -> evar_map * EConstr.types (** Variant of [type_of] using references instead of state-passing. *) -val e_type_of : ?refresh:bool -> env -> evar_map ref -> EConstr.constr -> types +val e_type_of : ?refresh:bool -> env -> evar_map ref -> EConstr.constr -> EConstr.types (** Typecheck a type and return its sort *) val e_sort_of : env -> evar_map ref -> EConstr.types -> sorts diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 8a8649f111..233b58e91c 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -122,7 +122,6 @@ let abstract_list_all env evd typ c l = error_cannot_find_well_typed_abstraction env evd p l None | Pretype_errors.PretypeError (env',evd,TypingError x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in - let typp = EConstr.of_constr typp in evd,(p,typp) let set_occurrences_of_last_arg args = @@ -704,7 +703,6 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in - let tyN = EConstr.of_constr tyN in check_compatibility curenv CUMUL flags substn tyN tyM with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma) @@ -724,7 +722,6 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e if opt.with_types && flags.check_applied_meta_types then (try let tyM = get_type_of curenv ~lax:true sigma cM in - let tyM = EConstr.of_constr tyM in let tyN = Typing.meta_type sigma k in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> @@ -911,8 +908,6 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e try (* Force unification of the types to fill in parameters *) let ty1 = get_type_of curenv ~lax:true sigma c1 in let ty2 = get_type_of curenv ~lax:true sigma c2 in - let ty1 = EConstr.of_constr ty1 in - let ty2 = EConstr.of_constr ty2 in unify_0_with_initial_metas substn true curenv cv_pb { flags with modulo_conv_on_closed_terms = Some full_transparent_state; modulo_delta = full_transparent_state; @@ -978,8 +973,6 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e try (* Ensure we call conversion on terms of the same type *) let tyM = get_type_of curenv ~lax:true sigma m1 in let tyN = get_type_of curenv ~lax:true sigma n1 in - let tyM = EConstr.of_constr tyM in - let tyN = EConstr.of_constr tyN in check_compatibility curenv CUMUL flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) sigma @@ -1267,13 +1260,11 @@ let w_coerce_to_type env evd c cty mvty = let w_coerce env evd mv c = let cty = get_type_of env evd c in let mvty = Typing.meta_type evd mv in - w_coerce_to_type env evd c (EConstr.of_constr cty) mvty + w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = let sigma, c = refresh_universes (Some false) env sigma c in - let c = EConstr.of_constr c in let t = get_type_of env sigma (nf_meta sigma c) in - let t = EConstr.of_constr t in let t = nf_betaiota sigma (nf_meta sigma t) in unify_0 env sigma CUMUL flags t u @@ -1406,7 +1397,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = let evd' = Sigma.to_evar_map evd' in let (evd'',mc,ec) = unify_0 sp_env evd' CUMUL flags - (EConstr.of_constr (get_type_of sp_env evd' c)) (EConstr.of_constr ev.evar_concl) in + (get_type_of sp_env evd' c) (EConstr.of_constr ev.evar_concl) in let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' then Evd.define sp (EConstr.Unsafe.to_constr c) evd''' @@ -1458,13 +1449,13 @@ let check_types env flags (sigma,_,_ as subst) m n = if isEvar_or_Meta sigma (head_app sigma m) then unify_0_with_initial_metas subst true env CUMUL flags - (EConstr.of_constr (get_type_of env sigma n)) - (EConstr.of_constr (get_type_of env sigma m)) + (get_type_of env sigma n) + (get_type_of env sigma m) else if isEvar_or_Meta sigma (head_app sigma n) then unify_0_with_initial_metas subst true env CUMUL flags - (EConstr.of_constr (get_type_of env sigma m)) - (EConstr.of_constr (get_type_of env sigma n)) + (get_type_of env sigma m) + (get_type_of env sigma n) else subst let try_resolve_typeclasses env evd flag m n = @@ -1595,7 +1586,6 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = else t, [] in let sigma = w_typed_unify env sigma Reduction.CONV flags c t' in let ty = Retyping.get_type_of env sigma t in - let ty = EConstr.of_constr ty in if not (is_correct_type ty) then raise (NotUnifiable None); Some(sigma, t, l2) with @@ -1628,8 +1618,8 @@ let make_eq_test env evd c = let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let id = - let ty = Option.map EConstr.Unsafe.to_constr ty in let t = match ty with Some t -> t | None -> get_type_of env sigma c in + let t = EConstr.Unsafe.to_constr t in let x = id_of_name_using_hdchar (Global.env()) t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else -- cgit v1.2.3 From 05afd04095e35d77ca135bd2c1cb8d303ea2d6a8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 18:18:17 +0100 Subject: Ltac now uses evar-based constrs. --- pretyping/evardefine.ml | 4 ++-- pretyping/evardefine.mli | 2 +- pretyping/pretyping.ml | 3 ++- pretyping/pretyping.mli | 2 +- pretyping/recordops.ml | 6 +++--- pretyping/reductionops.ml | 6 +++--- pretyping/unification.ml | 5 +---- 7 files changed, 13 insertions(+), 15 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index d4b46c0465..875e4a1189 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -208,6 +208,6 @@ let split_tycon loc env evd tycon = let valcon_of_tycon x = x let lift_tycon n = Option.map (lift n) -let pr_tycon env = function +let pr_tycon env sigma = function None -> str "None" - | Some t -> Termops.print_constr_env env (EConstr.Unsafe.to_constr t) + | Some t -> Termops.print_constr_env env sigma t diff --git a/pretyping/evardefine.mli b/pretyping/evardefine.mli index 9c03a6e3f1..2f7ac4efbe 100644 --- a/pretyping/evardefine.mli +++ b/pretyping/evardefine.mli @@ -43,5 +43,5 @@ val define_evar_as_sort : env -> evar_map -> existential -> evar_map * sorts (** {6 debug pretty-printer:} *) -val pr_tycon : env -> type_constraint -> Pp.std_ppcmds +val pr_tycon : env -> evar_map -> type_constraint -> Pp.std_ppcmds diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index a0d8faab44..09b99983cc 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -429,7 +429,7 @@ let protected_get_type_of env sigma c = try Retyping.get_type_of ~lax:true env.ExtraEnv.env sigma c with Retyping.RetypeError _ -> user_err - (str "Cannot reinterpret " ++ quote (print_constr (EConstr.Unsafe.to_constr c)) ++ + (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") let pretype_id pretype k0 loc env evdref lvar id = @@ -1225,6 +1225,7 @@ let type_uconstr ?(flags = constr_flags) } in let sigma = Sigma.to_evar_map sigma in let (sigma, c) = understand_ltac flags env sigma vars expected_type term in + let c = EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) end } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 2f3ce3afac..a1602088ab 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -119,7 +119,7 @@ val understand_judgment_tcc : env -> evar_map ref -> val type_uconstr : ?flags:inference_flags -> ?expected_type:typing_constraint -> - Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open + Geninterp.interp_sign -> Glob_term.closed_glob_constr -> EConstr.constr Tactypes.delayed_open (** Trying to solve remaining evars and remaining conversion problems possibly using type classes, heuristics, external tactic solver diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 8362a2a26a..bc9e3a1f46 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -191,7 +191,7 @@ let warn_projection_no_head_constant = CWarnings.create ~name:"projection-no-head-constant" ~category:"typechecker" (fun (t,con_pp,proji_sp_pp) -> strbrk "Projection value has no head constant: " - ++ Termops.print_constr t ++ strbrk " in canonical instance " + ++ Termops.print_constr (EConstr.of_constr t) ++ strbrk " in canonical instance " ++ con_pp ++ str " of " ++ proji_sp_pp ++ strbrk ", ignoring it.") (* Intended to always succeed *) @@ -256,8 +256,8 @@ let add_canonical_structure warn o = in match ocs with | None -> object_table := Refmap.add proj ((pat,s)::l) !object_table; | Some (c, cs) -> - let old_can_s = (Termops.print_constr cs.o_DEF) - and new_can_s = (Termops.print_constr s.o_DEF) in + let old_can_s = (Termops.print_constr (EConstr.of_constr cs.o_DEF)) + and new_can_s = (Termops.print_constr (EConstr.of_constr s.o_DEF)) in let prj = (Nametab.pr_global_env Id.Set.empty proj) and hd_val = (pr_cs_pattern cs_pat) in if warn then warn_redundant_canonical_projection (hd_val,prj,new_can_s,old_can_s)) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 90c5b241b8..bc5c629f4e 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -210,7 +210,7 @@ module Cst_stack = struct let pr l = let open Pp in - let p_c c = Termops.print_constr (EConstr.Unsafe.to_constr c) in + let p_c c = Termops.print_constr c in prlist_with_sep pr_semicolon (fun (c,params,args) -> hov 1 (str"(" ++ p_c c ++ str ")" ++ spc () ++ pr_sequence p_c params ++ spc () ++ str "(args:" ++ @@ -606,7 +606,7 @@ type local_state_reduction_function = evar_map -> state -> state let pr_state (tm,sk) = let open Pp in - let pr c = Termops.print_constr (EConstr.Unsafe.to_constr c) in + let pr c = Termops.print_constr c in h 0 (pr tm ++ str "|" ++ cut () ++ Stack.pr pr sk) let local_assum (na, t) = @@ -835,7 +835,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = let rec whrec cst_l (x, stack) = let () = if !debug_RAKAM then let open Pp in - let pr c = Termops.print_constr (EConstr.Unsafe.to_constr c) in + let pr c = Termops.print_constr c in Feedback.msg_notice (h 0 (str "<<" ++ pr x ++ str "|" ++ cut () ++ Cst_stack.pr cst_l ++ diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 233b58e91c..c6fad1a349 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -671,16 +671,13 @@ let eta_constructor_app env sigma f l1 term = | _ -> assert false) | _ -> assert false -let print_constr_env env c = - print_constr_env env (EConstr.Unsafe.to_constr c) - let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top env cv_pb flags m n = let rec unirec_rec (curenv,nb as curenvnb) pb opt ((sigma,metasubst,evarsubst) as substn : subst0) curm curn = let cM = Evarutil.whd_head_evar sigma curm and cN = Evarutil.whd_head_evar sigma curn in let () = if !debug_unification then - Feedback.msg_debug (print_constr_env curenv cM ++ str" ~= " ++ print_constr_env curenv cN) + Feedback.msg_debug (print_constr_env curenv sigma cM ++ str" ~= " ++ print_constr_env curenv sigma cN) in match (EConstr.kind sigma cM, EConstr.kind sigma cN) with | Meta k1, Meta k2 -> -- cgit v1.2.3 From 778e863b77bcafc8ed339dd02226e85e5fee2532 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Nov 2016 11:36:09 +0100 Subject: Removing compatibility layers related to printing. --- pretyping/evarconv.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'pretyping') diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index afb0bf6d5a..87267d5389 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -385,7 +385,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty match is_unification_pattern_evar env evd ev lF tM with | None -> fallback () | Some l1' -> (* Miller-Pfenning's patterns unification *) - let t2 = EConstr.of_constr (nf_evar evd (EConstr.Unsafe.to_constr tM)) (** FIXME *) in + let t2 = tM in let t2 = solve_pattern_eqn env evd l1' t2 in solve_simple_eqn (evar_conv_x ts) env evd (position_problem on_left pbty,ev,t2) -- cgit v1.2.3 From 02dd160233adc784eac732d97a88356d1f0eaf9b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Nov 2016 18:34:53 +0100 Subject: Removing various compatibility layers of tactics. --- pretyping/cases.ml | 2 +- pretyping/cbv.ml | 2 +- pretyping/cbv.mli | 6 +++++- pretyping/coercion.ml | 8 ++++---- pretyping/pretyping.ml | 8 +++----- pretyping/pretyping.mli | 6 +++--- pretyping/tacred.ml | 2 +- pretyping/typing.ml | 6 +++--- pretyping/typing.mli | 27 ++++++++++++++------------- pretyping/unification.ml | 2 +- 10 files changed, 36 insertions(+), 33 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 565a9725c2..eea94f021e 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -2076,7 +2076,7 @@ let constr_of_pat env evdref arsign pat avoid = let IndType (indf, _) = try find_rectype env ( !evdref) (lift (-(List.length realargs)) ty) with Not_found -> error_case_not_inductive env !evdref - {uj_val = ty; uj_type = EConstr.of_constr (Typing.unsafe_type_of env !evdref ty)} + {uj_val = ty; uj_type = Typing.unsafe_type_of env !evdref ty} in let (ind,u), params = dest_ind_family indf in let params = List.map EConstr.of_constr params in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index a42061f283..e18625c427 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -377,7 +377,7 @@ and cbv_norm_value info = function (* reduction under binders *) (* with profiling *) let cbv_norm infos constr = let constr = EConstr.Unsafe.to_constr constr in - with_stats (lazy (cbv_norm_term infos (subs_id 0) constr)) + EConstr.of_constr (with_stats (lazy (cbv_norm_term infos (subs_id 0) constr))) type cbv_infos = cbv_value infos diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 3d17457679..b014af2c7f 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Environ open CClosure open Esubst @@ -19,10 +20,13 @@ open Esubst type cbv_infos val create_cbv_infos : RedFlags.reds -> env -> Evd.evar_map -> cbv_infos -val cbv_norm : cbv_infos -> EConstr.constr -> constr +val cbv_norm : cbv_infos -> constr -> constr (*********************************************************************** i This is for cbv debug *) + +open Term + type cbv_value = | VAL of int * constr | STACK of int * cbv_value * cbv_stack diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index f569d9fc4a..ead44cee2f 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -194,7 +194,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) (subst1 hdy restT') (succ i) (fun x -> eq_app (co x)) else Some (fun x -> let term = co x in - EConstr.of_constr (Typing.e_solve_evars env evdref term)) + Typing.e_solve_evars env evdref term) in if isEvar !evdref c || isEvar !evdref c' || not (Program.is_program_generalized_coercion ()) then (* Second-order unification needed. *) @@ -302,7 +302,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) with NoSubtacCoercion -> let typ = Typing.unsafe_type_of env evm c in let typ' = Typing.unsafe_type_of env evm c' in - coerce_application (EConstr.of_constr typ) (EConstr.of_constr typ') c c' l l') + coerce_application typ typ' c c' l l') else subco () | x, y when EConstr.eq_constr !evdref c c' -> @@ -310,7 +310,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) let evm = !evdref in let lam_type = Typing.unsafe_type_of env evm c in let lam_type' = Typing.unsafe_type_of env evm c' in - coerce_application (EConstr.of_constr lam_type) (EConstr.of_constr lam_type') c c' l l' + coerce_application lam_type lam_type' c c' l l' else subco () | _ -> subco ()) | _, _ -> subco () @@ -341,7 +341,7 @@ let app_coercion env evdref coercion v = | None -> v | Some f -> let v' = Typing.e_solve_evars env evdref (f v) in - whd_betaiota !evdref (EConstr.of_constr v') + whd_betaiota !evdref v' let coerce_itf loc env evd v t c1 = let evdref = ref evd in diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 09b99983cc..f76f608d0d 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -524,7 +524,6 @@ let pretype_ref loc evdref env ref us = let evd, c = pretype_global loc univ_flexible env !evdref ref us in let () = evdref := evd in let ty = unsafe_type_of env.ExtraEnv.env evd c in - let ty = EConstr.of_constr ty in make_judge c ty let judge_of_Type loc evd s = @@ -1194,16 +1193,16 @@ let understand let understand_tcc ?(flags=all_no_fail_flags) env sigma ?(expected_type=WithoutTypeConstraint) c = let (sigma, c) = ise_pretype_gen flags env sigma empty_lvar expected_type c in - (sigma, EConstr.Unsafe.to_constr c) + (sigma, c) let understand_tcc_evars ?(flags=all_no_fail_flags) env evdref ?(expected_type=WithoutTypeConstraint) c = let sigma, c = ise_pretype_gen flags env !evdref empty_lvar expected_type c in evdref := sigma; - EConstr.Unsafe.to_constr c + c let understand_ltac flags env sigma lvar kind c = let (sigma, c) = ise_pretype_gen flags env sigma lvar kind c in - (sigma, EConstr.Unsafe.to_constr c) + (sigma, c) let constr_flags = { use_typeclasses = true; @@ -1225,7 +1224,6 @@ let type_uconstr ?(flags = constr_flags) } in let sigma = Sigma.to_evar_map sigma in let (sigma, c) = understand_ltac flags env sigma vars expected_type term in - let c = EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) end } diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index a1602088ab..825d73f1f1 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -76,10 +76,10 @@ val allow_anonymous_refs : bool ref evar_map is modified explicitly or by side-effect. *) val understand_tcc : ?flags:inference_flags -> env -> evar_map -> - ?expected_type:typing_constraint -> glob_constr -> open_constr + ?expected_type:typing_constraint -> glob_constr -> evar_map * EConstr.constr val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref -> - ?expected_type:typing_constraint -> glob_constr -> constr + ?expected_type:typing_constraint -> glob_constr -> EConstr.constr (** More general entry point with evars from ltac *) @@ -95,7 +95,7 @@ val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref -> val understand_ltac : inference_flags -> env -> evar_map -> ltac_var_map -> - typing_constraint -> glob_constr -> pure_open_constr + typing_constraint -> glob_constr -> evar_map * EConstr.constr (** Standard call to get a constr from a glob_constr, resolving implicit arguments and coercions, and compiling pattern-matching; diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 3fc01c86c6..2b496f9267 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1133,7 +1133,7 @@ let fold_commands cl env sigma c = (* call by value reduction functions *) let cbv_norm_flags flags env sigma t = - EConstr.of_constr (cbv_norm (create_cbv_infos flags env sigma) t) + cbv_norm (create_cbv_infos flags env sigma) t let cbv_beta = cbv_norm_flags beta empty_env let cbv_betaiota = cbv_norm_flags betaiota empty_env diff --git a/pretyping/typing.ml b/pretyping/typing.ml index d24160ea54..7baff421fb 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -376,7 +376,7 @@ let unsafe_type_of env evd c = let evdref = ref evd in let env = enrich_env env evdref in let j = execute env evdref c in - EConstr.Unsafe.to_constr j.uj_type + j.uj_type (* Sort of a type *) @@ -411,6 +411,6 @@ let e_solve_evars env evdref c = let env = enrich_env env evdref in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) - nf_evar !evdref (EConstr.Unsafe.to_constr c) + EConstr.of_constr (nf_evar !evdref (EConstr.Unsafe.to_constr c)) -let _ = Evarconv.set_solve_evars (fun env evdref c -> EConstr.of_constr (e_solve_evars env evdref c)) +let _ = Evarconv.set_solve_evars (fun env evdref c -> e_solve_evars env evdref c) diff --git a/pretyping/typing.mli b/pretyping/typing.mli index bf26358a22..91134b4999 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -9,46 +9,47 @@ open Names open Term open Environ +open EConstr open Evd (** This module provides the typing machine with existential variables and universes. *) (** Typecheck a term and return its type. May trigger an evarmap leak. *) -val unsafe_type_of : env -> evar_map -> EConstr.constr -> types +val unsafe_type_of : env -> evar_map -> constr -> types (** Typecheck a term and return its type + updated evars, optionally refreshing universes *) -val type_of : ?refresh:bool -> env -> evar_map -> EConstr.constr -> evar_map * EConstr.types +val type_of : ?refresh:bool -> env -> evar_map -> constr -> evar_map * types (** Variant of [type_of] using references instead of state-passing. *) -val e_type_of : ?refresh:bool -> env -> evar_map ref -> EConstr.constr -> EConstr.types +val e_type_of : ?refresh:bool -> env -> evar_map ref -> constr -> types (** Typecheck a type and return its sort *) -val e_sort_of : env -> evar_map ref -> EConstr.types -> sorts +val e_sort_of : env -> evar_map ref -> types -> sorts (** Typecheck a term has a given type (assuming the type is OK) *) -val e_check : env -> evar_map ref -> EConstr.constr -> EConstr.types -> unit +val e_check : env -> evar_map ref -> constr -> types -> unit (** Returns the instantiated type of a metavariable *) -val meta_type : evar_map -> metavariable -> EConstr.types +val meta_type : evar_map -> metavariable -> types (** Solve existential variables using typing *) -val e_solve_evars : env -> evar_map ref -> EConstr.constr -> constr +val e_solve_evars : env -> evar_map ref -> constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) -val check_allowed_sort : env -> evar_map -> pinductive -> EConstr.constr -> EConstr.constr -> +val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> unit (** Raise an error message if bodies have types not unifiable with the expected ones *) val check_type_fixpoint : Loc.t -> env -> evar_map ref -> - Names.Name.t array -> EConstr.types array -> EConstr.unsafe_judgment array -> unit + Names.Name.t array -> types array -> unsafe_judgment array -> unit -val judge_of_prop : EConstr.unsafe_judgment -val judge_of_set : EConstr.unsafe_judgment +val judge_of_prop : unsafe_judgment +val judge_of_set : unsafe_judgment val judge_of_abstraction : Environ.env -> Name.t -> - EConstr.unsafe_type_judgment -> EConstr.unsafe_judgment -> EConstr.unsafe_judgment + unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment val judge_of_product : Environ.env -> Name.t -> - EConstr.unsafe_type_judgment -> EConstr.unsafe_type_judgment -> EConstr.unsafe_judgment + unsafe_type_judgment -> unsafe_type_judgment -> unsafe_judgment diff --git a/pretyping/unification.ml b/pretyping/unification.ml index c6fad1a349..5bb865310c 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1228,7 +1228,7 @@ let applyHead env (type r) (evd : r Sigma.t) n c = apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' | _ -> error "Apply_Head_Then" in - apprec n c (EConstr.of_constr (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c)) Sigma.refl evd + apprec n c (Typing.unsafe_type_of env (Sigma.to_evar_map evd) c) Sigma.refl evd let is_mimick_head sigma ts f = match EConstr.kind sigma f with -- cgit v1.2.3 From 8beca748d992cd08e2dd7448c8b28dadbcea4a16 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 01:09:11 +0100 Subject: Cleaning up interfaces. We make mli files look to what they were looking before the move to EConstr by opening this module. --- pretyping/find_subterm.ml | 4 +- pretyping/find_subterm.mli | 15 ++++---- pretyping/pretype_errors.mli | 87 ++++++++++++++++++++++---------------------- pretyping/pretyping.ml | 2 +- pretyping/pretyping.mli | 31 ++++++++-------- pretyping/tacred.ml | 1 - pretyping/tacred.mli | 17 +++++---- pretyping/unification.ml | 3 +- 8 files changed, 81 insertions(+), 79 deletions(-) (limited to 'pretyping') diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index 15409f2b86..d09686f6e2 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -141,8 +141,8 @@ let replace_term_occ_gen_modulo sigma occs like_first test bywhat cl occ t = let replace_term_occ_modulo evd occs test bywhat t = let occs',like_first = match occs with AtOccs occs -> occs,false | LikeFirst -> AllOccurrences,true in - EConstr.Unsafe.to_constr (proceed_with_occurrences - (replace_term_occ_gen_modulo evd occs' like_first test bywhat None) occs' t) + proceed_with_occurrences + (replace_term_occ_gen_modulo evd occs' like_first test bywhat None) occs' t let replace_term_occ_decl_modulo evd occs test bywhat d = let (plocs,hyploc),like_first = diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index c7db84e3c7..3d2ebb72df 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -11,11 +11,12 @@ open Term open Evd open Pretype_errors open Environ +open EConstr (** Finding subterms, possibly up to some unification function, possibly at some given occurrences *) -exception NotUnifiable of (EConstr.constr * EConstr.constr * unification_error) option +exception NotUnifiable of (constr * constr * unification_error) option exception SubtermUnificationError of subterm_unification_error @@ -26,7 +27,7 @@ exception SubtermUnificationError of subterm_unification_error with None. *) type 'a testing_function = { - match_fun : 'a -> EConstr.constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : position_reporting option @@ -34,7 +35,7 @@ type 'a testing_function = { (** This is the basic testing function, looking for exact matches of a closed term *) -val make_eq_univs_test : env -> evar_map -> EConstr.constr -> evar_map testing_function +val make_eq_univs_test : env -> evar_map -> constr -> evar_map testing_function (** [replace_term_occ_modulo occl test mk c] looks in [c] for subterm modulo a testing function [test] and replaces successfully @@ -42,27 +43,27 @@ val make_eq_univs_test : env -> evar_map -> EConstr.constr -> evar_map testing_f ()]; it turns a NotUnifiable exception raised by the testing function into a SubtermUnificationError. *) val replace_term_occ_modulo : evar_map -> occurrences or_like_first -> - 'a testing_function -> (unit -> EConstr.constr) -> EConstr.constr -> constr + 'a testing_function -> (unit -> constr) -> constr -> constr (** [replace_term_occ_decl_modulo] is similar to [replace_term_occ_modulo] but for a named_declaration. *) val replace_term_occ_decl_modulo : evar_map -> (occurrences * hyp_location_flag) or_like_first -> - 'a testing_function -> (unit -> EConstr.constr) -> + 'a testing_function -> (unit -> constr) -> Context.Named.Declaration.t -> Context.Named.Declaration.t (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), unifying universes which results in a set of constraints. *) val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> - EConstr.constr -> EConstr.constr -> constr * evar_map + constr -> constr -> constr * evar_map (** [subst_closed_term_occ_decl evd occl c decl] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [decl]. *) val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> - EConstr.constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map + constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map (** Miscellaneous *) val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 0ebe4817ca..7cef14339b 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -9,52 +9,53 @@ open Names open Term open Environ +open EConstr open Type_errors (** {6 The type of errors raised by the pretyper } *) type unification_error = - | OccurCheck of existential_key * EConstr.constr - | NotClean of EConstr.existential * env * EConstr.constr + | OccurCheck of existential_key * constr + | NotClean of existential * env * constr | NotSameArgSize | NotSameHead | NoCanonicalStructure - | ConversionFailed of env * EConstr.constr * EConstr.constr + | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key - | InstanceNotSameType of existential_key * env * EConstr.types * EConstr.types + | InstanceNotSameType of existential_key * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error | ProblemBeyondCapabilities type position = (Id.t * Locus.hyp_location_flag) option -type position_reporting = (position * int) * EConstr.t +type position_reporting = (position * int) * constr -type subterm_unification_error = bool * position_reporting * position_reporting * (EConstr.constr * EConstr.constr * unification_error) option +type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option -type type_error = (EConstr.constr, EConstr.types) ptype_error +type type_error = (constr, types) ptype_error type pretype_error = (** Old Case *) - | CantFindCaseType of EConstr.constr + | CantFindCaseType of constr (** Type inference unification *) - | ActualTypeNotCoercible of EConstr.unsafe_judgment * EConstr.types * unification_error + | ActualTypeNotCoercible of unsafe_judgment * types * unification_error (** Tactic Unification *) - | UnifOccurCheck of existential_key * EConstr.constr + | UnifOccurCheck of existential_key * constr | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option - | CannotUnify of EConstr.constr * EConstr.constr * unification_error option - | CannotUnifyLocal of EConstr.constr * EConstr.constr * EConstr.constr - | CannotUnifyBindingType of constr * constr - | CannotGeneralize of constr - | NoOccurrenceFound of EConstr.constr * Id.t option - | CannotFindWellTypedAbstraction of EConstr.constr * EConstr.constr list * (env * type_error) option - | WrongAbstractionType of Name.t * EConstr.constr * EConstr.types * EConstr.types + | CannotUnify of constr * constr * unification_error option + | CannotUnifyLocal of constr * constr * constr + | CannotUnifyBindingType of Constr.constr * Constr.constr + | CannotGeneralize of Constr.constr + | NoOccurrenceFound of constr * Id.t option + | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option + | WrongAbstractionType of Name.t * constr * types * types | AbstractionOverMeta of Name.t * Name.t - | NonLinearUnification of Name.t * EConstr.constr + | NonLinearUnification of Name.t * constr (** Pretyping *) | VarNotFound of Id.t - | UnexpectedType of EConstr.constr * EConstr.constr - | NotProduct of EConstr.constr + | UnexpectedType of constr * constr + | NotProduct of constr | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of @@ -67,85 +68,85 @@ val precatchable_exception : exn -> bool (** Raising errors *) val error_actual_type : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> EConstr.constr -> + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> unification_error -> 'b val error_actual_type_core : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> EConstr.constr -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> constr -> 'b val error_cant_apply_not_functional : ?loc:Loc.t -> env -> Evd.evar_map -> - EConstr.unsafe_judgment -> EConstr.unsafe_judgment array -> 'b + unsafe_judgment -> unsafe_judgment array -> 'b val error_cant_apply_bad_type : - ?loc:Loc.t -> env -> Evd.evar_map -> int * EConstr.constr * EConstr.constr -> - EConstr.unsafe_judgment -> EConstr.unsafe_judgment array -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> int * constr * constr -> + unsafe_judgment -> unsafe_judgment array -> 'b val error_case_not_inductive : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b val error_ill_formed_branch : ?loc:Loc.t -> env -> Evd.evar_map -> - EConstr.constr -> pconstructor -> EConstr.constr -> EConstr.constr -> 'b + constr -> pconstructor -> constr -> constr -> 'b val error_number_branches : ?loc:Loc.t -> env -> Evd.evar_map -> - EConstr.unsafe_judgment -> int -> 'b + unsafe_judgment -> int -> 'b val error_ill_typed_rec_body : ?loc:Loc.t -> env -> Evd.evar_map -> - int -> Name.t array -> EConstr.unsafe_judgment array -> EConstr.types array -> 'b + int -> Name.t array -> unsafe_judgment array -> types array -> 'b val error_elim_arity : ?loc:Loc.t -> env -> Evd.evar_map -> - pinductive -> sorts_family list -> EConstr.constr -> - EConstr.unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'b + pinductive -> sorts_family list -> constr -> + unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'b val error_not_a_type : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b val error_assumption : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.unsafe_judgment -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> unsafe_judgment -> 'b -val error_cannot_coerce : env -> Evd.evar_map -> EConstr.constr * EConstr.constr -> 'b +val error_cannot_coerce : env -> Evd.evar_map -> constr * constr -> 'b (** {6 Implicit arguments synthesis errors } *) -val error_occur_check : env -> Evd.evar_map -> existential_key -> EConstr.constr -> 'b +val error_occur_check : env -> Evd.evar_map -> existential_key -> constr -> 'b val error_unsolvable_implicit : ?loc:Loc.t -> env -> Evd.evar_map -> existential_key -> Evd.unsolvability_explanation option -> 'b val error_cannot_unify : ?loc:Loc.t -> env -> Evd.evar_map -> - ?reason:unification_error -> EConstr.constr * EConstr.constr -> 'b + ?reason:unification_error -> constr * constr -> 'b -val error_cannot_unify_local : env -> Evd.evar_map -> EConstr.constr * EConstr.constr * EConstr.constr -> 'b +val error_cannot_unify_local : env -> Evd.evar_map -> constr * constr * constr -> 'b val error_cannot_find_well_typed_abstraction : env -> Evd.evar_map -> - EConstr.constr -> EConstr.constr list -> (env * type_error) option -> 'b + constr -> constr list -> (env * type_error) option -> 'b val error_wrong_abstraction_type : env -> Evd.evar_map -> - Name.t -> EConstr.constr -> EConstr.types -> EConstr.types -> 'b + Name.t -> constr -> types -> types -> 'b val error_abstraction_over_meta : env -> Evd.evar_map -> metavariable -> metavariable -> 'b val error_non_linear_unification : env -> Evd.evar_map -> - metavariable -> EConstr.constr -> 'b + metavariable -> constr -> 'b (** {6 Ml Case errors } *) val error_cant_find_case_type : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.constr -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Pretyping errors } *) val error_unexpected_type : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> constr -> 'b val error_not_product : - ?loc:Loc.t -> env -> Evd.evar_map -> EConstr.constr -> 'b + ?loc:Loc.t -> env -> Evd.evar_map -> constr -> 'b (** {6 Error in conversion from AST to glob_constr } *) diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index f76f608d0d..6b6800ac6a 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -61,7 +61,7 @@ type ltac_var_map = { ltac_genargs : unbound_ltac_var_map; } type glob_constr_ltac_closure = ltac_var_map * glob_constr -type pure_open_constr = evar_map * Constr.constr +type pure_open_constr = evar_map * EConstr.constr (************************************************************************) (* This concerns Cases *) diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index 825d73f1f1..47ad93d7e0 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -16,6 +16,7 @@ open Names open Term open Environ open Evd +open EConstr open Glob_term open Evarutil open Misctypes @@ -25,7 +26,7 @@ open Misctypes val search_guard : Loc.t -> env -> int list list -> rec_declaration -> int array -type typing_constraint = OfType of EConstr.types | IsType | WithoutTypeConstraint +type typing_constraint = OfType of types | IsType | WithoutTypeConstraint type var_map = Pattern.constr_under_binders Id.Map.t type uconstr_var_map = Glob_term.closed_glob_constr Id.Map.t @@ -47,7 +48,7 @@ val empty_lvar : ltac_var_map type glob_constr_ltac_closure = ltac_var_map * glob_constr type pure_open_constr = evar_map * constr -type inference_hook = env -> evar_map -> evar -> evar_map * EConstr.constr +type inference_hook = env -> evar_map -> evar -> evar_map * constr type inference_flags = { use_typeclasses : bool; @@ -76,10 +77,10 @@ val allow_anonymous_refs : bool ref evar_map is modified explicitly or by side-effect. *) val understand_tcc : ?flags:inference_flags -> env -> evar_map -> - ?expected_type:typing_constraint -> glob_constr -> evar_map * EConstr.constr + ?expected_type:typing_constraint -> glob_constr -> evar_map * constr val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref -> - ?expected_type:typing_constraint -> glob_constr -> EConstr.constr + ?expected_type:typing_constraint -> glob_constr -> constr (** More general entry point with evars from ltac *) @@ -95,7 +96,7 @@ val understand_tcc_evars : ?flags:inference_flags -> env -> evar_map ref -> val understand_ltac : inference_flags -> env -> evar_map -> ltac_var_map -> - typing_constraint -> glob_constr -> evar_map * EConstr.constr + typing_constraint -> glob_constr -> pure_open_constr (** Standard call to get a constr from a glob_constr, resolving implicit arguments and coercions, and compiling pattern-matching; @@ -105,21 +106,21 @@ val understand_ltac : inference_flags -> unresolved evar remains, expanding evars. *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> - env -> evar_map -> glob_constr -> constr Evd.in_evar_universe_context + env -> evar_map -> glob_constr -> Constr.constr Evd.in_evar_universe_context (** Idem but returns the judgment of the understood term *) val understand_judgment : env -> evar_map -> - glob_constr -> EConstr.unsafe_judgment Evd.in_evar_universe_context + glob_constr -> unsafe_judgment Evd.in_evar_universe_context (** Idem but do not fail on unresolved evars (type cl*) val understand_judgment_tcc : env -> evar_map ref -> - glob_constr -> EConstr.unsafe_judgment + glob_constr -> unsafe_judgment val type_uconstr : ?flags:inference_flags -> ?expected_type:typing_constraint -> - Geninterp.interp_sign -> Glob_term.closed_glob_constr -> EConstr.constr Tactypes.delayed_open + Geninterp.interp_sign -> Glob_term.closed_glob_constr -> constr Tactypes.delayed_open (** Trying to solve remaining evars and remaining conversion problems possibly using type classes, heuristics, external tactic solver @@ -139,21 +140,21 @@ val check_evars_are_solved : (** [check_evars env initial_sigma extended_sigma c] fails if some new unresolved evar remains in [c] *) -val check_evars : env -> evar_map -> evar_map -> EConstr.constr -> unit +val check_evars : env -> evar_map -> evar_map -> constr -> unit (**/**) (** Internal of Pretyping... *) val pretype : int -> bool -> type_constraint -> env -> evar_map ref -> - ltac_var_map -> glob_constr -> EConstr.unsafe_judgment + ltac_var_map -> glob_constr -> unsafe_judgment val pretype_type : int -> bool -> val_constraint -> env -> evar_map ref -> - ltac_var_map -> glob_constr -> EConstr.unsafe_type_judgment + ltac_var_map -> glob_constr -> unsafe_type_judgment val ise_pretype_gen : inference_flags -> env -> evar_map -> - ltac_var_map -> typing_constraint -> glob_constr -> evar_map * EConstr.constr + ltac_var_map -> typing_constraint -> glob_constr -> evar_map * constr (**/**) @@ -163,5 +164,5 @@ val interp_sort : ?loc:Loc.t -> evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : - (EConstr.types -> env -> evar_map -> unbound_ltac_var_map -> - Genarg.glob_generic_argument -> EConstr.constr * evar_map) Hook.t + (types -> env -> evar_map -> unbound_ltac_var_map -> + Genarg.glob_generic_argument -> constr * evar_map) Hook.t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 2b496f9267..4abfc26fc5 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1154,7 +1154,6 @@ let abstract_scheme env sigma (locc,a) (c, sigma) = mkLambda (na,ta,c), sigma else let c', sigma' = subst_closed_term_occ env sigma (AtOccs locc) a c in - let c' = EConstr.of_constr c' in mkLambda (na,ta,c'), sigma' let pattern_occs loccs_trm = { e_redfun = begin fun env sigma c -> diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 15b4e990d8..a4499015d2 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -10,6 +10,7 @@ open Names open Term open Environ open Evd +open EConstr open Reductionops open Pattern open Globnames @@ -17,7 +18,7 @@ open Locus open Univ type reduction_tactic_error = - InvalidAbstraction of env * evar_map * EConstr.constr * (env * Type_errors.type_error) + InvalidAbstraction of env * evar_map * constr * (env * Type_errors.type_error) exception ReductionTacticError of reduction_tactic_error @@ -58,10 +59,10 @@ val unfoldn : (occurrences * evaluable_global_reference) list -> reduction_function (** Fold *) -val fold_commands : EConstr.constr list -> reduction_function +val fold_commands : constr list -> reduction_function (** Pattern *) -val pattern_occs : (occurrences * EConstr.constr) list -> e_reduction_function +val pattern_occs : (occurrences * constr) list -> e_reduction_function (** Rem: Lazy strategies are defined in Reduction *) @@ -75,23 +76,23 @@ val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> EConstr.types -> pinductive * EConstr.types +val reduce_to_atomic_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> EConstr.types -> pinductive * EConstr.types +val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) val reduce_to_quantified_ref : - env -> evar_map -> global_reference -> EConstr.types -> EConstr.types + env -> evar_map -> global_reference -> types -> types val reduce_to_atomic_ref : - env -> evar_map -> global_reference -> EConstr.types -> EConstr.types + env -> evar_map -> global_reference -> types -> types val find_hnf_rectype : - env -> evar_map -> EConstr.types -> pinductive * EConstr.constr list + env -> evar_map -> types -> pinductive * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 5bb865310c..20f27a15a2 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -100,7 +100,6 @@ let abstract_scheme env evd c l lname_typ = if occur_meta evd a then mkLambda_name env (na,ta,t), evd else let t', evd' = Find_subterm.subst_closed_term_occ env evd locc a t in - let t' = EConstr.of_constr t' in mkLambda_name env (na,ta,t'), evd') (c,evd) (List.rev l) @@ -1656,7 +1655,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | NoOccurrences -> concl | occ -> let occ = if likefirst then LikeFirst else AtOccs occ in - EConstr.of_constr (replace_term_occ_modulo sigma occ test mkvarid concl) + replace_term_occ_modulo sigma occ test mkvarid concl in let lastlhyp = if List.is_empty depdecls then None else Some (NamedDecl.get_id (List.last depdecls)) in -- cgit v1.2.3 From c8c8ccdaaffefdbd3d78c844552a08bcb7b4f915 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 02:12:40 +0100 Subject: Evar-normalizing functions now act on EConstrs. --- pretyping/cases.ml | 8 ++++---- pretyping/coercion.ml | 1 - pretyping/evarconv.ml | 6 +++--- pretyping/evardefine.ml | 5 +++-- pretyping/evarsolve.ml | 4 ++-- pretyping/pretype_errors.ml | 37 +++++++++++++++++++------------------ pretyping/pretype_errors.mli | 4 ++-- pretyping/pretyping.ml | 3 --- pretyping/reductionops.mli | 4 ++-- pretyping/typing.ml | 4 ++-- pretyping/unification.ml | 12 +++++------- 11 files changed, 42 insertions(+), 46 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index eea94f021e..0e4c6619b5 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -362,7 +362,7 @@ let coerce_row typing_fun evdref env pats (tomatch,(_,indopt)) = let j = typing_fun tycon env evdref tomatch in let evd, j = Coercion.inh_coerce_to_base (loc_of_glob_constr tomatch) env !evdref j in evdref := evd; - let typ = EConstr.of_constr (nf_evar !evdref (EConstr.Unsafe.to_constr j.uj_type)) in + let typ = nf_evar !evdref j.uj_type in let t = try try_find_ind env !evdref typ realnames with Not_found -> @@ -1145,7 +1145,7 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with | [], _ -> brs,tomatch,pred,[] | n::deps, Abstract (i,d) :: tomatch -> - let d = map_constr (nf_evar evd) d in + let d = map_constr (fun c -> EConstr.Unsafe.to_constr (nf_evar evd (EConstr.of_constr c))) d in let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in if is_d || List.exists (fun c -> dependent_decl evd (lift k c) d) tocheck && Array.exists (is_dependent_branch evd k) brs then @@ -2008,9 +2008,9 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let envar = List.fold_right push_rel_context arsign env in let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in - let predcclj = typing_fun (mk_tycon (EConstr.mkSort newt)) envar evdref rtntyp in + let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = !evdref in - let predccl = EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr predcclj.uj_val)) in + let predccl = nf_evar sigma predcclj.uj_val in [sigma, predccl] in List.map diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index ead44cee2f..91f53a886d 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -417,7 +417,6 @@ let inh_tosort_force loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in let evd,j1 = apply_coercion env evd p j t in - let whd_evar evd c = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr c)) in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env evd j2) with Not_found | NoCoercion -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 87267d5389..3ae2e35e6d 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -526,7 +526,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | None, Success i' -> (* We do have sk1[] = sk2[]: we now unify ?ev1 and ?ev2 *) (* Note that ?ev1 and ?ev2, may have been instantiated in the meantime *) - let ev1' = EConstr.of_constr (whd_evar i' (EConstr.Unsafe.to_constr (mkEvar ev1))) in + let ev1' = whd_evar i' (mkEvar ev1) in if isEvar i' ev1' then solve_simple_eqn (evar_conv_x ts) env i' (position_problem true pbty,destEvar i' ev1', term2) @@ -536,7 +536,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Some (r,[]), Success i' -> (* We have sk1'[] = sk2[] for some sk1' s.t. sk1[]=sk1'[r[]] *) (* we now unify r[?ev1] and ?ev2 *) - let ev2' = EConstr.of_constr (whd_evar i' (EConstr.Unsafe.to_constr (mkEvar ev2))) in + let ev2' = whd_evar i' (mkEvar ev2) in if isEvar i' ev2' then solve_simple_eqn (evar_conv_x ts) env i' (position_problem false pbty,destEvar i' ev2',Stack.zip evd (term1,r)) @@ -547,7 +547,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* Symmetrically *) (* We have sk1[] = sk2'[] for some sk2' s.t. sk2[]=sk2'[r[]] *) (* we now unify ?ev1 and r[?ev2] *) - let ev1' = EConstr.of_constr (whd_evar i' (EConstr.Unsafe.to_constr (mkEvar ev1))) in + let ev1' = whd_evar i' (mkEvar ev1) in if isEvar i' ev1' then solve_simple_eqn (evar_conv_x ts) env i' (position_problem true pbty,destEvar i' ev1',Stack.zip evd (term2,r)) diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 875e4a1189..5831d31913 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -33,8 +33,9 @@ let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal t (Sigma.to_evar_map evd, evk) let env_nf_evar sigma env = + let nf_evar c = EConstr.Unsafe.to_constr (nf_evar sigma (EConstr.of_constr c)) in process_rel_context - (fun d e -> push_rel (RelDecl.map_constr (nf_evar sigma) d) e) env + (fun d e -> push_rel (RelDecl.map_constr nf_evar d) e) env let env_nf_betaiotaevar sigma env = process_rel_context @@ -144,7 +145,7 @@ let define_pure_evar_as_lambda env evd evk = | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in let id = - next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd (EConstr.Unsafe.to_constr dom)) in + next_name_away_with_default_using_types "x" na avoid (EConstr.Unsafe.to_constr (Reductionops.whd_evar evd dom)) in let newenv = push_named (nlocal_assum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index de2e46a781..3235c2505b 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -601,13 +601,13 @@ let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_si let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd ty_t_in_sign ~filter ~src inst_in_env in let evd = Sigma.to_evar_map evd in - let t_in_env = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr t_in_env)) in + let t_in_env = whd_evar evd t_in_env in let (evk, _) = destEvar evd evar_in_env in let evd = define_fun env evd None (destEvar evd evar_in_env) t_in_env in let ctxt = named_context_of_val sign in let inst_in_sign = inst_of_vars (Filter.filter_list filter ctxt) in let evar_in_sign = mkEvar (evk, inst_in_sign) in - (evd,EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr evar_in_sign))) + (evd,whd_evar evd evar_in_sign) (* We have x1..xq |- ?e1 : τ and had to solve something like * Σ; Γ |- ?e1[u1..uq] = (...\y1 ... \yk ... c), where c is typically some diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 6735540059..24f6d16899 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -10,50 +10,51 @@ open Util open Names open Term open Environ +open EConstr open Type_errors type unification_error = - | OccurCheck of existential_key * EConstr.constr - | NotClean of EConstr.existential * env * EConstr.constr (* Constr is a variable not in scope *) + | OccurCheck of existential_key * constr + | NotClean of existential * env * constr (* Constr is a variable not in scope *) | NotSameArgSize | NotSameHead | NoCanonicalStructure - | ConversionFailed of env * EConstr.constr * EConstr.constr (* Non convertible closed terms *) + | ConversionFailed of env * constr * constr (* Non convertible closed terms *) | MetaOccurInBody of existential_key - | InstanceNotSameType of existential_key * env * EConstr.types * EConstr.types + | InstanceNotSameType of existential_key * env * types * types | UnifUnivInconsistency of Univ.univ_inconsistency | CannotSolveConstraint of Evd.evar_constraint * unification_error | ProblemBeyondCapabilities type position = (Id.t * Locus.hyp_location_flag) option -type position_reporting = (position * int) * EConstr.t +type position_reporting = (position * int) * constr -type subterm_unification_error = bool * position_reporting * position_reporting * (EConstr.constr * EConstr.constr * unification_error) option +type subterm_unification_error = bool * position_reporting * position_reporting * (constr * constr * unification_error) option -type type_error = (EConstr.constr, EConstr.types) ptype_error +type type_error = (constr, types) ptype_error type pretype_error = (* Old Case *) - | CantFindCaseType of EConstr.constr + | CantFindCaseType of constr (* Type inference unification *) - | ActualTypeNotCoercible of EConstr.unsafe_judgment * EConstr.types * unification_error + | ActualTypeNotCoercible of unsafe_judgment * types * unification_error (* Tactic unification *) - | UnifOccurCheck of existential_key * EConstr.constr + | UnifOccurCheck of existential_key * constr | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option - | CannotUnify of EConstr.constr * EConstr.constr * unification_error option - | CannotUnifyLocal of EConstr.constr * EConstr.constr * EConstr.constr + | CannotUnify of constr * constr * unification_error option + | CannotUnifyLocal of constr * constr * constr | CannotUnifyBindingType of constr * constr | CannotGeneralize of constr - | NoOccurrenceFound of EConstr.constr * Id.t option - | CannotFindWellTypedAbstraction of EConstr.constr * EConstr.constr list * (env * type_error) option - | WrongAbstractionType of Name.t * EConstr.constr * EConstr.types * EConstr.types + | NoOccurrenceFound of constr * Id.t option + | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option + | WrongAbstractionType of Name.t * constr * types * types | AbstractionOverMeta of Name.t * Name.t - | NonLinearUnification of Name.t * EConstr.constr + | NonLinearUnification of Name.t * constr (* Pretyping *) | VarNotFound of Id.t - | UnexpectedType of EConstr.constr * EConstr.constr - | NotProduct of EConstr.constr + | UnexpectedType of constr * constr + | NotProduct of constr | TypingError of type_error | CannotUnifyOccurrences of subterm_unification_error | UnsatisfiableConstraints of diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 7cef14339b..c303d5d949 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -45,8 +45,8 @@ type pretype_error = | UnsolvableImplicit of existential_key * Evd.unsolvability_explanation option | CannotUnify of constr * constr * unification_error option | CannotUnifyLocal of constr * constr * constr - | CannotUnifyBindingType of Constr.constr * Constr.constr - | CannotGeneralize of Constr.constr + | CannotUnifyBindingType of constr * constr + | CannotGeneralize of constr | NoOccurrenceFound of constr * Id.t option | CannotFindWellTypedAbstraction of constr * constr list * (env * type_error) option | WrongAbstractionType of Name.t * constr * types * types diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 6b6800ac6a..4660978df3 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -143,9 +143,6 @@ let nf_fix sigma (nas, cs, ts) = let inj c = EConstr.to_constr sigma c in (nas, Array.map inj cs, Array.map inj ts) -let nf_evar sigma c = - EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr c)) - let search_guard loc env possible_indexes fixdefs = (* Standard situation with only one possibility for each fix. *) (* We treat it separately in order to get proper error msg. *) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 8aaeeb2c21..dcc11cfcf3 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -156,11 +156,11 @@ val nf_beta : local_reduction_function val nf_betaiota : local_reduction_function val nf_betaiotazeta : local_reduction_function val nf_all : reduction_function -val nf_evar : evar_map -> Constr.constr -> Constr.constr +val nf_evar : evar_map -> constr -> constr (** Lazy strategy, weak head reduction *) -val whd_evar : evar_map -> Constr.constr -> Constr.constr +val whd_evar : evar_map -> constr -> constr val whd_nored : local_reduction_function val whd_beta : local_reduction_function val whd_betaiota : local_reduction_function diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 7baff421fb..e6f1e46b6d 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -252,7 +252,7 @@ let judge_of_letin env name defj typj j = (* cstr must be in n.f. w.r.t. evars and execute returns a judgement where both the term and type are in n.f. *) let rec execute env evdref cstr = - let cstr = EConstr.of_constr (whd_evar !evdref (EConstr.Unsafe.to_constr cstr)) in + let cstr = whd_evar !evdref cstr in match EConstr.kind !evdref cstr with | Meta n -> { uj_val = cstr; uj_type = meta_type !evdref n } @@ -411,6 +411,6 @@ let e_solve_evars env evdref c = let env = enrich_env env evdref in let c = (execute env evdref c).uj_val in (* side-effect on evdref *) - EConstr.of_constr (nf_evar !evdref (EConstr.Unsafe.to_constr c)) + nf_evar !evdref c let _ = Evarconv.set_solve_evars (fun env evdref c -> e_solve_evars env evdref c) diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 20f27a15a2..1dc3ccdc07 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -137,7 +137,7 @@ let abstract_list_all_with_dependencies env evd typ c l = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in if b then - let p = nf_evar evd (EConstr.Unsafe.to_constr ev) in + let p = nf_evar evd ev in evd, p else error_cannot_find_well_typed_abstraction env evd c l None @@ -1240,7 +1240,7 @@ let try_to_coerce env evd c cty tycon = let j = make_judge c cty in let (evd',j') = inh_conv_coerce_rigid_to true Loc.ghost env evd j tycon in let evd' = Evarconv.consider_remaining_unif_problems env evd' in - let evd' = Evd.map_metas_fvalue (nf_evar evd') evd' in + let evd' = Evd.map_metas_fvalue (fun c -> EConstr.Unsafe.to_constr (nf_evar evd' (EConstr.of_constr c))) evd' in (evd',j'.uj_val) let w_coerce_to_type env evd c cty mvty = @@ -1397,7 +1397,7 @@ let w_merge env with_types flags (evd,metas,evars : subst0) = let evd''' = w_merge_rec evd'' mc ec [] in if evd' == evd''' then Evd.define sp (EConstr.Unsafe.to_constr c) evd''' - else Evd.define sp (Evarutil.nf_evar evd''' (EConstr.Unsafe.to_constr c)) evd''' in + else Evd.define sp (EConstr.Unsafe.to_constr (Evarutil.nf_evar evd''' c)) evd''' in let check_types evd = let metas = Evd.meta_list evd in @@ -1513,8 +1513,7 @@ let finish_evar_resolution ?(flags=Pretyping.all_and_fail_flags) env current_sig let current_sigma = Sigma.to_evar_map current_sigma in let sigma = Pretyping.solve_remaining_evars flags env current_sigma pending in let sigma, subst = nf_univ_variables sigma in - let c = EConstr.Unsafe.to_constr c in - Sigma.Unsafe.of_pair (EConstr.of_constr (CVars.subst_univs_constr subst (nf_evar sigma c)), sigma) + Sigma.Unsafe.of_pair (EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr (nf_evar sigma c))), sigma) let default_matching_core_flags sigma = let ts = Names.full_transparent_state in { @@ -1602,7 +1601,7 @@ let make_pattern_test from_prefix_of_ind is_correct_type env sigma (pending,c) = (fun test -> match test.testing_state with | None -> None | Some (sigma,_,l) -> - let c = applist (EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr (local_strong whd_meta sigma c))), l) in + let c = applist (nf_evar sigma (local_strong whd_meta sigma c), l) in let univs, subst = nf_univ_variables sigma in Some (sigma,EConstr.of_constr (CVars.subst_univs_constr subst (EConstr.Unsafe.to_constr c)))) @@ -1926,7 +1925,6 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in - let pred = EConstr.of_constr pred in w_merge env false flags.merge_unify_flags (evd,[p,pred,(Conv,TypeProcessed)],[]) -- cgit v1.2.3 From 78a8d59b39dfcb07b94721fdcfd9241d404905d2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 15:30:02 +0100 Subject: Introducing contexts parameterized by the inner term type. This allows the decoupling of the notions of context containing kernel terms and context containing tactic-level terms. --- pretyping/cases.ml | 2 +- pretyping/indrec.ml | 32 ++++++++++++++++---------------- pretyping/inductiveops.ml | 4 ++-- pretyping/typeclasses.ml | 2 +- pretyping/unification.ml | 2 +- 5 files changed, 21 insertions(+), 21 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 0e4c6619b5..3b5662a24e 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -943,7 +943,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = let tms = List.fold_right2 (fun par arg tomatch -> match EConstr.kind sigma par with | Rel i -> relocate_index_tomatch sigma (i+n) (destRel sigma arg) tomatch - | _ -> tomatch) (realargs@[cur]) (List.map EConstr.of_constr (Context.Rel.to_extended_list 0 sign)) + | _ -> tomatch) (realargs@[cur]) (Context.Rel.to_extended_list EConstr.mkRel 0 sign) (lift_tomatch_stack n tms) in (* Pred is already dependent in the current term to match (if *) (* (na<>Anonymous) and its realargs; we just need to adjust it to *) diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 1adeb4db2f..431d1ff166 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -63,7 +63,7 @@ let check_privacy_block mib = let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let lnamespar = Vars.subst_instance_context u mib.mind_params_ctxt in - let indf = make_ind_family(pind, Context.Rel.to_extended_list 0 lnamespar) in + let indf = make_ind_family(pind, Context.Rel.to_extended_list mkRel 0 lnamespar) in let constrs = get_constructors env indf in let projs = get_projections env indf in @@ -93,8 +93,8 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = let pbody = appvect (mkRel (ndepar + nbprod), - if dep then Context.Rel.to_extended_vect 0 deparsign - else Context.Rel.to_extended_vect 1 arsign) in + if dep then Context.Rel.to_extended_vect mkRel 0 deparsign + else Context.Rel.to_extended_vect mkRel 1 arsign) in let p = it_mkLambda_or_LetIn_name env' ((if dep then mkLambda_name env' else mkLambda) @@ -168,7 +168,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = let base = applist (lift i pk,realargs) in if depK then Reduction.beta_appvect - base [|applist (mkRel (i+1), Context.Rel.to_extended_list 0 sign)|] + base [|applist (mkRel (i+1), Context.Rel.to_extended_list mkRel 0 sign)|] else base | _ -> @@ -244,7 +244,7 @@ let make_rec_branch_arg env sigma (nparrec,fvect,decF) f cstr recargs = mkLetIn (n,b,t,prec (push_rel d env) (i+1) (d::hyps) c) | Ind _ -> let realargs = List.skipn nparrec largs - and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect 0 hyps) in + and arg = appvect (mkRel (i+1), Context.Rel.to_extended_vect mkRel 0 hyps) in applist(lift i fk,realargs@[arg]) | _ -> let t' = whd_all env sigma (EConstr.of_constr p) in @@ -323,7 +323,7 @@ let mis_make_indrec env sigma listdepkind mib u = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) - let args = Context.Rel.to_extended_list (nrec+nbconstruct) lnamesparrec in + let args = Context.Rel.to_extended_list mkRel (nrec+nbconstruct) lnamesparrec in let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in @@ -337,15 +337,15 @@ let mis_make_indrec env sigma listdepkind mib u = (* constructors in context of the Cases expr, i.e. P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) - let args' = Context.Rel.to_extended_list (dect+nrec) lnamesparrec in - let args'' = Context.Rel.to_extended_list ndepar lnonparrec in + let args' = Context.Rel.to_extended_list mkRel (dect+nrec) lnamesparrec in + let args'' = Context.Rel.to_extended_list mkRel ndepar lnonparrec in let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in let fi = Termops.rel_vect (dect-i-nctyi) nctyi in let vecfi = Array.map - (fun f -> appvect (f, Context.Rel.to_extended_vect ndepar lnonparrec)) + (fun f -> appvect (f, Context.Rel.to_extended_vect mkRel ndepar lnonparrec)) fi in Array.map3 @@ -366,9 +366,9 @@ let mis_make_indrec env sigma listdepkind mib u = let deparsign' = LocalAssum (Anonymous,depind')::arsign' in let pargs = - let nrpar = Context.Rel.to_extended_list (2*ndepar) lnonparrec - and nrar = if dep then Context.Rel.to_extended_list 0 deparsign' - else Context.Rel.to_extended_list 1 arsign' + let nrpar = Context.Rel.to_extended_list mkRel (2*ndepar) lnonparrec + and nrar = if dep then Context.Rel.to_extended_list mkRel 0 deparsign' + else Context.Rel.to_extended_list mkRel 1 arsign' in nrpar@nrar in @@ -396,8 +396,8 @@ let mis_make_indrec env sigma listdepkind mib u = let typtyi = let concl = - let pargs = if dep then Context.Rel.to_extended_vect 0 deparsign - else Context.Rel.to_extended_vect 1 arsign + let pargs = if dep then Context.Rel.to_extended_vect mkRel 0 deparsign + else Context.Rel.to_extended_vect mkRel 1 arsign in appvect (mkRel (nbconstruct+ndepar+nonrecpar+j),pargs) in it_mkProd_or_LetIn_name env concl @@ -424,7 +424,7 @@ let mis_make_indrec env sigma listdepkind mib u = else let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in - let vargs = Context.Rel.to_extended_list (nrec+i+j) lnamesparrec in + let vargs = Context.Rel.to_extended_list mkRel (nrec+i+j) lnamesparrec in let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch @@ -438,7 +438,7 @@ let mis_make_indrec env sigma listdepkind mib u = in let rec put_arity env i = function | ((indi,u),_,_,dep,kinds)::rest -> - let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list i lnamesparrec) in + let indf = make_ind_family ((indi,u), Context.Rel.to_extended_list mkRel i lnamesparrec) in let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) evdref kinds diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 1dcd6399e7..c00ceb02e2 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -411,14 +411,14 @@ let build_dependent_constructor cs = applist (mkConstructU cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) - @(Context.Rel.to_extended_list 0 cs.cs_args)) + @(Context.Rel.to_extended_list mkRel 0 cs.cs_args)) let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist (mkIndU ind, - (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list 0 arsign)) + (List.map (lift nrealargs) params)@(Context.Rel.to_extended_list mkRel 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 9da7005e09..50ae66eb0e 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -289,7 +289,7 @@ let build_subclasses ~check env sigma glob pri = | None -> [] | Some (rels, ((tc,u), args)) -> let instapp = - Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect 0 rels))) + Reductionops.whd_beta sigma (EConstr.of_constr (appvectc c (Context.Rel.to_extended_vect mkRel 0 rels))) in let instapp = EConstr.Unsafe.to_constr instapp in let projargs = Array.of_list (args @ [instapp]) in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 1dc3ccdc07..04cc4253e0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1634,7 +1634,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | AllOccurrences, InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in - if Context.Named.Declaration.equal d newdecl + if Context.Named.Declaration.equal Constr.equal d newdecl && not (indirectly_dependent sigma c d depdecls) then if check_occs && not (in_every_hyp occs) -- cgit v1.2.3 From b4b90c5d2e8c413e1981c456c933f35679386f09 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 16:18:47 +0100 Subject: Definining EConstr-based contexts. This removes quite a few unsafe casts. Unluckily, I had to reintroduce the old non-module based names for these data structures, because I could not reproduce easily the same hierarchy in EConstr. --- pretyping/cases.ml | 100 ++++++++++++++++++++----------------------- pretyping/cases.mli | 8 ++-- pretyping/coercion.ml | 14 +++--- pretyping/constr_matching.ml | 26 ++++------- pretyping/evarconv.ml | 16 +++---- pretyping/evardefine.ml | 15 +++---- pretyping/evarsolve.ml | 27 ++++-------- pretyping/find_subterm.ml | 4 +- pretyping/find_subterm.mli | 4 +- pretyping/inductiveops.ml | 2 +- pretyping/patternops.ml | 17 ++------ pretyping/pretyping.ml | 52 ++++++++++------------ pretyping/reductionops.ml | 40 +++++++---------- pretyping/reductionops.mli | 6 +-- pretyping/retyping.ml | 24 ++++------- pretyping/retyping.mli | 2 +- pretyping/tacred.ml | 55 +++++++++++------------- pretyping/typeclasses.ml | 1 + pretyping/typeclasses.mli | 2 +- pretyping/typing.ml | 21 +++------ pretyping/unification.ml | 8 ++-- pretyping/unification.mli | 2 +- 22 files changed, 183 insertions(+), 263 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 3b5662a24e..a5a5fe6d2e 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -15,12 +15,12 @@ open Names open Nameops open Term open Termops +open Environ open EConstr open Vars open Namegen open Declarations open Inductiveops -open Environ open Reductionops open Type_errors open Glob_term @@ -38,14 +38,6 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let local_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - RelDecl.LocalAssum (na, inj t) - -let local_def (na, b, t) = - let inj = EConstr.Unsafe.to_constr in - RelDecl.LocalDef (na, inj b, inj t) - (* Pattern-matching errors *) type pattern_matching_error = @@ -150,7 +142,7 @@ type tomatch_status = | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) | Alias of (bool*(Name.t * constr * (constr * types))) | NonDepAlias - | Abstract of int * Context.Rel.Declaration.t + | Abstract of int * rel_declaration type tomatch_stack = tomatch_status list @@ -261,7 +253,7 @@ type 'a pattern_matching_problem = mat : 'a matrix; caseloc : Loc.t; casestyle : case_style; - typing_function: type_constraint -> env -> evar_map ref -> 'a option -> EConstr.unsafe_judgment } + typing_function: type_constraint -> env -> evar_map ref -> 'a option -> unsafe_judgment } (*--------------------------------------------------------------------------* * A few functions to infer the inductive type from the patterns instead of * @@ -331,14 +323,12 @@ let binding_vars_of_inductive sigma = function let extract_inductive_data env sigma decl = match decl with | LocalAssum (_,t) -> - let t = EConstr.of_constr t in let tmtyp = try try_find_ind env sigma t None with Not_found -> NotInd (None,t) in let tmtypvars = binding_vars_of_inductive sigma tmtyp in (tmtyp,tmtypvars) | LocalDef (_,_,t) -> - let t = EConstr.of_constr t in (NotInd (None, t), []) let unify_tomatch_with_patterns evdref env loc typ pats realnames = @@ -451,7 +441,7 @@ let remove_current_pattern eqn = let push_current_pattern (cur,ty) eqn = match eqn.patterns with | pat::pats -> - let rhs_env = push_rel (local_def (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in + let rhs_env = push_rel (LocalDef (alias_of_pat pat,cur,ty)) eqn.rhs.rhs_env in { eqn with rhs = { eqn.rhs with rhs_env = rhs_env }; patterns = pats } @@ -553,8 +543,8 @@ let dependencies_in_pure_rhs nargs eqns = let dependent_decl sigma a = function - | LocalAssum (na,t) -> dependent sigma a (EConstr.of_constr t) - | LocalDef (na,c,t) -> dependent sigma a (EConstr.of_constr t) || dependent sigma a (EConstr.of_constr c) + | LocalAssum (na,t) -> dependent sigma a t + | LocalDef (na,c,t) -> dependent sigma a t || dependent sigma a c let rec dep_in_tomatch sigma n = function | (Pushed _ | Alias _ | NonDepAlias) :: l -> dep_in_tomatch sigma n l @@ -625,7 +615,7 @@ let relocate_index_tomatch sigma n1 n2 = NonDepAlias :: genrec depth rest | Abstract (i,d) :: rest -> let i = relocate_rel n1 n2 depth i in - Abstract (i, RelDecl.map_constr (fun c -> EConstr.Unsafe.to_constr (relocate_index sigma n1 n2 depth (EConstr.of_constr c))) d) + Abstract (i, RelDecl.map_constr (fun c -> relocate_index sigma n1 n2 depth c) d) :: genrec (depth+1) rest in genrec 0 @@ -658,7 +648,7 @@ let replace_tomatch sigma n c = | NonDepAlias :: rest -> NonDepAlias :: replrec depth rest | Abstract (i,d) :: rest -> - Abstract (i, RelDecl.map_constr (fun t -> EConstr.Unsafe.to_constr (replace_term sigma n c depth (EConstr.of_constr t))) d) + Abstract (i, RelDecl.map_constr (fun t -> replace_term sigma n c depth t) d) :: replrec (depth+1) rest in replrec 0 @@ -683,7 +673,7 @@ let rec liftn_tomatch_stack n depth = function NonDepAlias :: liftn_tomatch_stack n depth rest | Abstract (i,d)::rest -> let i = if i let na = merge_name - (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env t na) avoid)) + (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env (EConstr.Unsafe.to_constr t) na) avoid)) d na in (na::l,(out_name na)::avoid)) @@ -1145,7 +1135,7 @@ let postprocess_dependencies evd tocheck brs tomatch pred deps cs = let rec aux k brs tomatch pred tocheck deps = match deps, tomatch with | [], _ -> brs,tomatch,pred,[] | n::deps, Abstract (i,d) :: tomatch -> - let d = map_constr (fun c -> EConstr.Unsafe.to_constr (nf_evar evd (EConstr.of_constr c))) d in + let d = map_constr (fun c -> nf_evar evd c) d in let is_d = match d with LocalAssum _ -> false | LocalDef _ -> true in if is_d || List.exists (fun c -> dependent_decl evd (lift k c) d) tocheck && Array.exists (is_dependent_branch evd k) brs then @@ -1215,12 +1205,12 @@ let rec generalize_problem names pb = function | [] -> pb, [] | i::l -> let pb',deps = generalize_problem names pb l in - let d = map_constr (CVars.lift i) (Environ.lookup_rel i pb.env) in + let d = map_constr (lift i) (lookup_rel i pb.env) in begin match d with | LocalDef (Anonymous,_,_) -> pb', deps | _ -> (* for better rendering *) - let d = RelDecl.map_type (fun c -> EConstr.Unsafe.to_constr (whd_betaiota !(pb.evdref) (EConstr.of_constr c))) d in + let d = RelDecl.map_type (fun c -> whd_betaiota !(pb.evdref) c) d in let tomatch = lift_tomatch_stack 1 pb'.tomatch in let tomatch = relocate_index_tomatch !(pb.evdref) (i+1) 1 tomatch in { pb' with @@ -1247,6 +1237,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* build the name x1..xn from the names present in the equations *) (* that had matched constructor C *) let cs_args = const_info.cs_args in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs_args in let names,aliasname = get_names pb.env cs_args eqns in let typs = List.map2 RelDecl.set_name names cs_args in @@ -1259,7 +1250,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* We adjust the terms to match in the context they will be once the *) (* context [x1:T1,..,xn:Tn] will have been pushed on the current env *) let typs' = - List.map_i (fun i d -> (mkRel i, map_constr (CVars.lift i) d)) 1 typs in + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 typs in let extenv = push_rel_context typs pb.env in @@ -1415,7 +1406,7 @@ and shift_problem ((current,t),_,na) pb = let pred = specialize_predicate_var (current,t,na) pb.tomatch pb.pred in let pb = { pb with - env = push_rel (local_def (na,current,ty)) pb.env; + env = push_rel (LocalDef (na,current,ty)) pb.env; tomatch = tomatch; pred = lift_predicate 1 pred tomatch; history = pop_history pb.history; @@ -1463,7 +1454,7 @@ and compile_generalization pb i d rest = ([false]). *) and compile_alias initial pb (na,orig,(expanded,expanded_typ)) rest = let f c t = - let alias = local_def (na,c,t) in + let alias = LocalDef (na,c,t) in let pb = { pb with env = push_rel alias pb.env; @@ -1601,7 +1592,7 @@ let adjust_to_extended_env_and_remove_deps env extenv sigma subst t = let (p, _, _) = lookup_rel_id x (rel_context extenv) in let rec traverse_local_defs p = match lookup_rel p extenv with - | LocalDef (_,c,_) -> assert (isRel sigma (EConstr.of_constr c)); traverse_local_defs (p + destRel sigma (EConstr.of_constr c)) + | LocalDef (_,c,_) -> assert (isRel sigma c); traverse_local_defs (p + destRel sigma c) | LocalAssum _ -> p in let p = traverse_local_defs p in let u = lift (n' - n) u in @@ -1743,6 +1734,7 @@ let build_inversion_problem loc env sigma tms t = let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in let sign = make_arity_signature env true indf' in + let sign = List.map (fun d -> map_rel_decl EConstr.of_constr d) sign in let patl = pat :: List.rev patl in let patl,sign = recover_and_adjust_alias_names patl sign in let p = List.length patl in @@ -1751,7 +1743,7 @@ let build_inversion_problem loc env sigma tms t = List.rev_append patl patl',acc_sign,acc | (t, NotInd (bo,typ)) :: tms -> let pat,acc = make_patvar t acc in - let d = local_assum (alias_of_pat pat,typ) in + let d = LocalAssum (alias_of_pat pat,typ) in let patl,acc_sign,acc = aux (n+1) (push_rel d env) (d::acc_sign) tms acc in pat::patl,acc_sign,acc in let avoid0 = ids_of_context env in @@ -1768,7 +1760,7 @@ let build_inversion_problem loc env sigma tms t = let n = List.length sign in let decls = - List.map_i (fun i d -> (mkRel i, map_constr (CVars.lift i) d)) 1 sign in + List.map_i (fun i d -> (mkRel i, map_constr (lift i) d)) 1 sign in let pb_env = push_rel_context sign env in let decls = @@ -1855,8 +1847,8 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = | NotInd (bo,typ) -> (match t with | None -> (match bo with - | None -> [local_assum (na, lift n typ)] - | Some b -> [local_def (na, lift n b, lift n typ)]) + | None -> [LocalAssum (na, lift n typ)] + | Some b -> [LocalDef (na, lift n b, lift n typ)]) | Some (loc,_,_) -> user_err ~loc (str"Unexpected type annotation for a term of non inductive type.")) @@ -1865,6 +1857,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = let ((ind,u),_) = dest_ind_family indf' in let nrealargs_ctxt = inductive_nrealdecls_env env0 ind in let arsign = fst (get_arity env0 indf') in + let arsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) arsign in let realnal = match t with | Some (loc,ind',realnal) -> @@ -1874,7 +1867,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = anomaly (Pp.str "Ill-formed 'in' clause in cases"); List.rev realnal | None -> List.make nrealargs_ctxt Anonymous in - LocalAssum (na, build_dependent_inductive env0 indf') + LocalAssum (na, EConstr.of_constr (build_dependent_inductive env0 indf')) ::(List.map2 RelDecl.set_name realnal arsign) in let rec buildrec n = function | [],[] -> [] @@ -2069,7 +2062,7 @@ let constr_of_pat env evdref arsign pat avoid = let previd, id = prime avoid (Name (Id.of_string "wildcard")) in Name id, id :: avoid in - (PatVar (l, name), [local_assum (name, ty)] @ realargs, mkRel 1, ty, + (PatVar (l, name), [LocalAssum (name, ty)] @ realargs, mkRel 1, ty, (List.map (fun x -> mkRel 1) realargs), 1, avoid) | PatCstr (l,((_, i) as cstr),args,alias) -> let cind = inductive_of_constructor cstr in @@ -2110,7 +2103,7 @@ let constr_of_pat env evdref arsign pat avoid = Anonymous -> pat', sign, app, apptype, realargs, n, avoid | Name id -> - let sign = local_assum (alias, lift m ty) :: sign in + let sign = LocalAssum (alias, lift m ty) :: sign in let avoid = id :: avoid in let sign, i, avoid = try @@ -2122,14 +2115,14 @@ let constr_of_pat env evdref arsign pat avoid = (lift 1 app) (* aliased term *) in let neq = eq_id avoid id in - local_def (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid + LocalDef (Name neq, mkRel 0, eq_t) :: sign, 2, neq :: avoid with Reduction.NotConvertible -> sign, 1, avoid in (* Mark the equality as a hole *) pat', sign, lift i app, lift i apptype, realargs, n + i, avoid in - let pat', sign, patc, patty, args, z, avoid = typ env (EConstr.of_constr (RelDecl.get_type (List.hd arsign)), List.tl arsign) pat avoid in - pat', (sign, patc, (EConstr.of_constr (RelDecl.get_type (List.hd arsign)), args), pat'), avoid + let pat', sign, patc, patty, args, z, avoid = typ env (RelDecl.get_type (List.hd arsign), List.tl arsign) pat avoid in + pat', (sign, patc, (RelDecl.get_type (List.hd arsign), args), pat'), avoid (* shadows functional version *) @@ -2147,14 +2140,14 @@ match EConstr.kind sigma t with let rels_of_patsign sigma = List.map (fun decl -> match decl with - | LocalDef (na,t',t) when is_topvar sigma (EConstr.of_constr t') -> LocalAssum (na,t) + | LocalDef (na,t',t) when is_topvar sigma t' -> LocalAssum (na,t) | _ -> decl) let vars_of_ctx sigma ctx = let _, y = List.fold_right (fun decl (prev, vars) -> match decl with - | LocalDef (na,t',t) when is_topvar sigma (EConstr.of_constr t') -> + | LocalDef (na,t',t) when is_topvar sigma t' -> prev, (GApp (Loc.ghost, (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), @@ -2174,6 +2167,9 @@ let rec is_included x y = if Int.equal i i' then List.for_all2 is_included args args' else false +let lift_rel_context n l = + map_rel_context_with_binders (liftn n) l + (* liftsign is the current pattern's complete signature length. Hence pats is already typed in its full signature. However prevpatterns are in the original one signature per pattern form. @@ -2269,7 +2265,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = match ineqs with | None -> [], arity | Some ineqs -> - [local_assum (Anonymous, ineqs)], lift 1 arity + [LocalAssum (Anonymous, ineqs)], lift 1 arity in let eqs_rels, arity = decompose_prod_n_assum !evdref neqs arity in eqs_rels @ neqs_rels @ rhs_rels', arity @@ -2280,7 +2276,7 @@ let constrs_of_pats typing_fun env evdref eqns tomatchs sign neqs arity = and btype = it_mkProd_or_LetIn j.uj_type rhs_rels' in let _btype = evd_comb1 (Typing.type_of env) evdref bbody in let branch_name = Id.of_string ("program_branch_" ^ (string_of_int !i)) in - let branch_decl = local_def (Name branch_name, lift !i bbody, lift !i btype) in + let branch_decl = LocalDef (Name branch_name, lift !i bbody, lift !i btype) in let branch = let bref = GVar (Loc.ghost, branch_name) in match vars_of_ctx !evdref rhs_rels with @@ -2329,7 +2325,7 @@ let abstract_tomatch env sigma tomatchs tycon = (fun t -> subst_term sigma (lift 1 c) (lift 1 t)) tycon in let name = next_ident_away (Id.of_string "filtered_var") names in (mkRel 1, lift_tomatch_type (succ lenctx) t) :: lift_ctx 1 prev, - local_def (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, + LocalDef (Name name, lift lenctx c, lift lenctx $ type_of_tomatch t) :: ctx, name :: names, tycon) ([], [], [], tycon) tomatchs in List.rev prev, ctx, tycon @@ -2356,14 +2352,12 @@ let build_dependent_signature env evdref avoid tomatchs arsign = let app_decl = List.hd arsign in (* The matched argument *) let appn = RelDecl.get_name app_decl in let appt = RelDecl.get_type app_decl in - let appt = EConstr.of_constr appt in let argsign = List.rev argsign in (* arguments in application order *) let env', nargeqs, argeqs, refl_args, slift, argsign' = List.fold_left2 (fun (env, nargeqs, argeqs, refl_args, slift, argsign') arg decl -> let name = RelDecl.get_name decl in let t = RelDecl.get_type decl in - let t = EConstr.of_constr t in let argt = Retyping.get_type_of env !evdref arg in let eq, refl_arg = if Reductionops.is_conv env !evdref argt t then @@ -2387,7 +2381,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = make_prime avoid name in (env, succ nargeqs, - (local_assum (Name (eq_id avoid previd), eq)) :: argeqs, + (LocalAssum (Name (eq_id avoid previd), eq)) :: argeqs, refl_arg :: refl_args, pred slift, RelDecl.set_name (Name id) decl :: argsign')) @@ -2401,7 +2395,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = in let refl_eq = mk_JMeq_refl evdref ty tm in let previd, id = make_prime avoid appn in - ((local_assum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, + ((LocalAssum (Name (eq_id avoid previd), eq) :: argeqs) :: eqs, succ nargeqs, refl_eq :: refl_args, pred slift, @@ -2417,7 +2411,7 @@ let build_dependent_signature env evdref avoid tomatchs arsign = mk_eq evdref (lift nar tomatch_ty) (mkRel slift) (lift nar tm) in - ([local_assum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, + ([LocalAssum (Name (eq_id avoid previd), eq)] :: eqs, succ neqs, (mk_eq_refl evdref tomatch_ty tm) :: refl_args, pred slift, (arsign' :: []) :: arsigns)) ([], 0, [], nar, []) tomatchs arsign @@ -2491,9 +2485,9 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (* We push the initial terms to match and push their alias to rhs' envs *) (* names of aliases will be recovered from patterns (hence Anonymous here) *) - let out_tmt na = function NotInd (None,t) -> local_assum (na,t) - | NotInd (Some b, t) -> local_def (na,b,t) - | IsInd (typ,_,_) -> local_assum (na,typ) in + let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) + | NotInd (Some b, t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = @@ -2566,9 +2560,9 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* names of aliases will be recovered from patterns (hence Anonymous *) (* here) *) - let out_tmt na = function NotInd (None,t) -> local_assum (na,t) - | NotInd (Some b,t) -> local_def (na,b,t) - | IsInd (typ,_,_) -> local_assum (na,typ) in + let out_tmt na = function NotInd (None,t) -> LocalAssum (na,t) + | NotInd (Some b,t) -> LocalDef (na,b,t) + | IsInd (typ,_,_) -> LocalAssum (na,typ) in let typs = List.map2 (fun na (tm,tmt) -> (tm,out_tmt na tmt)) nal tomatchs in let typs = diff --git a/pretyping/cases.mli b/pretyping/cases.mli index 9f26ae9ce2..3df2d6873a 100644 --- a/pretyping/cases.mli +++ b/pretyping/cases.mli @@ -47,11 +47,11 @@ val compile_cases : val constr_of_pat : Environ.env -> Evd.evar_map ref -> - Context.Rel.Declaration.t list -> + rel_context -> Glob_term.cases_pattern -> Names.Id.t list -> Glob_term.cases_pattern * - (Context.Rel.Declaration.t list * constr * + (rel_context * constr * (types * constr list) * Glob_term.cases_pattern) * Names.Id.t list @@ -85,7 +85,7 @@ type tomatch_status = | Pushed of (bool*((constr * tomatch_type) * int list * Name.t)) | Alias of (bool * (Name.t * constr * (constr * types))) | NonDepAlias - | Abstract of int * Context.Rel.Declaration.t + | Abstract of int * rel_declaration type tomatch_stack = tomatch_status list @@ -119,6 +119,6 @@ val prepare_predicate : Loc.t -> Environ.env -> Evd.evar_map -> (types * tomatch_type) list -> - Context.Rel.t list -> + rel_context list -> constr option -> 'a option -> (Evd.evar_map * Names.name list * constr) list diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 91f53a886d..8794f238bc 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -18,10 +18,10 @@ open CErrors open Util open Names open Term +open Environ open EConstr open Vars open Reductionops -open Environ open Typeops open Pretype_errors open Classops @@ -127,10 +127,6 @@ let lift_args n sign = in liftrec (List.length sign) sign -let local_assum (na, t) = - let open Context.Rel.Declaration in - LocalAssum (na, EConstr.Unsafe.to_constr t) - let mu env evdref t = let rec aux v = let v' = hnf env !evdref v in @@ -159,7 +155,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) let subco () = subset_coerce env evdref x y in let dest_prod c = match Reductionops.splay_prod_n env (!evdref) 1 c with - | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na, EConstr.of_constr t), c + | [LocalAssum (na,t) | LocalDef (na,_,t)], c -> (na, t), c | _ -> raise NoSubtacCoercion in let coerce_application typ typ' c c' l l' = @@ -212,7 +208,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) let name' = Name (Namegen.next_ident_away Namegen.default_dependent_ident (Termops.ids_of_context env)) in - let env' = push_rel (local_assum (name', a')) env in + let env' = push_rel (LocalAssum (name', a')) env in let c1 = coerce_unify env' (lift 1 a') (lift 1 a) in (* env, x : a' |- c1 : lift 1 a' > lift 1 a *) let coec1 = app_opt env' evdref c1 (mkRel 1) in @@ -260,7 +256,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) | _ -> raise NoSubtacCoercion in let (pb, b), (pb', b') = remove_head a pb, remove_head a' pb' in - let env' = push_rel (local_assum (Name Namegen.default_dependent_ident, a)) env in + let env' = push_rel (LocalAssum (Name Namegen.default_dependent_ident, a)) env in let c2 = coerce_unify env' b b' in match c1, c2 with | None, None -> None @@ -489,7 +485,7 @@ let rec inh_conv_coerce_to_fail loc env evd rigidonly v t c1 = | Anonymous -> Name Namegen.default_dependent_ident | _ -> name in let open Context.Rel.Declaration in - let env1 = push_rel (local_assum (name,u1)) env in + let env1 = push_rel (LocalAssum (name,u1)) env in let (evd', v1) = inh_conv_coerce_to_fail loc env1 evd rigidonly (Some (mkRel 1)) (lift 1 u1) (lift 1 t1) in diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index 55612aa665..cad21543ba 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -136,14 +136,6 @@ let make_renaming ids = function end | _ -> dummy_constr -let local_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - let to_fix (idx, (nas, cs, ts)) = let inj = EConstr.of_constr in (idx, (nas, Array.map inj cs, Array.map inj ts)) @@ -273,15 +265,15 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels sorec ctx env subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (Environ.push_rel (local_assum (na2,c2)) env) + sorec ((na1,na2,c2)::ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLambda (na1,c1,d1), Lambda(na2,c2,d2) -> - sorec ((na1,na2,c2)::ctx) (Environ.push_rel (local_assum (na2,c2)) env) + sorec ((na1,na2,c2)::ctx) (EConstr.push_rel (LocalAssum (na2,c2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PLetIn (na1,c1,d1), LetIn(na2,c2,t2,d2) -> - sorec ((na1,na2,t2)::ctx) (Environ.push_rel (local_def (na2,c2,t2)) env) + sorec ((na1,na2,t2)::ctx) (EConstr.push_rel (LocalDef (na2,c2,t2)) env) (add_binders na1 na2 binding_vars (sorec ctx env subst c1 c2)) d1 d2 | PIf (a1,b1,b1'), Case (ci,_,a2,[|b2;b2'|]) -> @@ -290,12 +282,12 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels let n = Context.Rel.length ctx_b2 in let n' = Context.Rel.length ctx_b2' in if Vars.noccur_between sigma 1 n b2 && Vars.noccur_between sigma 1 n' b2' then - let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,EConstr.of_constr t)::l in + let f l (LocalAssum (na,t) | LocalDef (na,_,t)) = (Anonymous,na,t)::l in let ctx_br = List.fold_left f ctx ctx_b2 in let ctx_br' = List.fold_left f ctx ctx_b2' in let b1 = lift_pattern n b1 and b1' = lift_pattern n' b1' in - sorec ctx_br' (Environ.push_rel_context ctx_b2' env) - (sorec ctx_br (Environ.push_rel_context ctx_b2 env) + sorec ctx_br' (push_rel_context ctx_b2' env) + (sorec ctx_br (push_rel_context ctx_b2 env) (sorec ctx env subst a1 a2) b1 b2) b1' b2' else raise PatternMatchingFailure @@ -388,21 +380,21 @@ let sub_match ?(partial_app=false) ?(closed=true) env sigma pat c = | [c1; c2] -> mk_ctx (mkLambda (x, c1, c2)) | _ -> assert false in - let env' = Environ.push_rel (local_assum (x,c1)) env in + let env' = EConstr.push_rel (LocalAssum (x,c1)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | Prod (x,c1,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkProd (x, c1, c2)) | _ -> assert false in - let env' = Environ.push_rel (local_assum (x,c1)) env in + let env' = EConstr.push_rel (LocalAssum (x,c1)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | LetIn (x,c1,t,c2) -> let next_mk_ctx = function | [c1; c2] -> mk_ctx (mkLetIn (x, c1, t, c2)) | _ -> assert false in - let env' = Environ.push_rel (local_def (x,c1,t)) env in + let env' = EConstr.push_rel (LocalDef (x,c1,t)) env in try_aux [(env, c1); (env', c2)] next_mk_ctx next | App (c1,lc) -> let topdown = true in diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 3ae2e35e6d..f5cab070ed 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -11,12 +11,12 @@ open Util open Names open Term open Termops +open Environ open EConstr open Vars open CClosure open Reduction open Reductionops -open Environ open Recordops open Evarutil open Evardefine @@ -58,12 +58,12 @@ let eval_flexible_term ts env evd c = | Rel n -> (try match lookup_rel n env with | RelDecl.LocalAssum _ -> None - | RelDecl.LocalDef (_,v,_) -> Some (lift n (EConstr.of_constr v)) + | RelDecl.LocalDef (_,v,_) -> Some (lift n v) with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - Option.map EConstr.of_constr (env |> lookup_named id |> NamedDecl.get_value) + env |> lookup_named id |> NamedDecl.get_value else None with Not_found -> None) | LetIn (_,b,_,c) -> Some (subst1 b c) @@ -404,7 +404,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty let eta env evd onleft sk term sk' term' = assert (match sk with [] -> true | _ -> false); let (na,c1,c'1) = destLambda evd term in - let c = EConstr.to_constr evd c1 in + let c = nf_evar evd c1 in let env' = push_rel (RelDecl.LocalAssum (na,c)) env in let out1 = whd_betaiota_deltazeta_for_iota_state (fst ts) env' evd Cst_stack.empty (c'1, Stack.empty) in @@ -612,8 +612,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (fun i -> evar_conv_x ts env i CUMUL t2 t1)]); (fun i -> evar_conv_x ts env i CONV b1 b2); (fun i -> - let b = EConstr.to_constr i b1 in - let t = EConstr.to_constr i t1 in + let b = nf_evar i b1 in + let t = nf_evar i t1 in let na = Nameops.name_max na1 na2 in evar_conv_x ts (push_rel (RelDecl.LocalDef (na,b,t)) env) i pbty c'1 c'2); (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] @@ -730,7 +730,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_and evd [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> - let c = EConstr.to_constr i c1 in + let c = nf_evar i c1 in let na = Nameops.name_max na1 na2 in evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i CONV c'1 c'2)] @@ -789,7 +789,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty ise_and evd [(fun i -> evar_conv_x ts env i CONV c1 c2); (fun i -> - let c = EConstr.to_constr i c1 in + let c = nf_evar i c1 in let na = Nameops.name_max n1 n2 in evar_conv_x ts (push_rel (RelDecl.LocalAssum (na,c)) env) i pbty c'1 c'2)] diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 5831d31913..faf34baf75 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -11,10 +11,10 @@ open Pp open Names open Term open Termops +open Environ open EConstr open Vars open Namegen -open Environ open Evd open Evarutil open Pretype_errors @@ -22,25 +22,20 @@ open Sigma.Notations module RelDecl = Context.Rel.Declaration -let nlocal_assum (na, t) = - let open Context.Named.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in (Sigma.to_evar_map evd, evk) let env_nf_evar sigma env = - let nf_evar c = EConstr.Unsafe.to_constr (nf_evar sigma (EConstr.of_constr c)) in + let nf_evar c = nf_evar sigma c in process_rel_context (fun d e -> push_rel (RelDecl.map_constr nf_evar d) e) env let env_nf_betaiotaevar sigma env = process_rel_context (fun d e -> - push_rel (RelDecl.map_constr (fun c -> EConstr.Unsafe.to_constr (Reductionops.nf_betaiota sigma (EConstr.of_constr c))) d) e) env + push_rel (RelDecl.map_constr (fun c -> Reductionops.nf_betaiota sigma c) d) e) env (****************************************) (* Operations on value/type constraints *) @@ -93,7 +88,7 @@ let define_pure_evar_as_product evd evk = (Sigma.to_evar_map evd1, e) in let evd2,rng = - let newenv = push_named (nlocal_assum (id, dom)) evenv in + let newenv = push_named (LocalAssum (id, dom)) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in if is_prop_sort s then @@ -146,7 +141,7 @@ let define_pure_evar_as_lambda env evd evk = let avoid = ids_of_named_context (evar_context evi) in let id = next_name_away_with_default_using_types "x" na avoid (EConstr.Unsafe.to_constr (Reductionops.whd_evar evd dom)) in - let newenv = push_named (nlocal_assum (id, dom)) evenv in + let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 3235c2505b..ff47365286 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -23,14 +23,6 @@ open Evarutil open Pretype_errors open Sigma.Notations -let nlocal_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - Context.Named.Declaration.LocalAssum (na, inj t) - -let nlocal_def (na, b, t) = - let inj = EConstr.Unsafe.to_constr in - Context.Named.Declaration.LocalDef (na, inj b, inj t) - let normalize_evar evd ev = match EConstr.kind evd (mkEvar ev) with | Evar (evk,args) -> (evk,args) @@ -264,7 +256,6 @@ let compute_var_aliases sign sigma = let id = get_id decl in match decl with | LocalDef (_,t,_) -> - let t = EConstr.of_constr t in (match EConstr.kind sigma t with | Var id' -> let aliases_of_id = @@ -281,8 +272,6 @@ let compute_rel_aliases var_aliases rels sigma = (n-1, match decl with | LocalDef (_,t,u) -> - let t = EConstr.of_constr t in - let u = EConstr.of_constr u in (match EConstr.kind sigma t with | Var id' -> let aliases_of_n = @@ -338,7 +327,6 @@ let extend_alias sigma decl (var_aliases,rel_aliases) = let rel_aliases = match decl with | LocalDef(_,t,_) -> - let t = EConstr.of_constr t in (match EConstr.kind sigma t with | Var id' -> let aliases_of_binder = @@ -530,7 +518,7 @@ let solve_pattern_eqn env sigma l c = (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> let open Context.Rel.Declaration in - let d = map_constr (CVars.lift n) (lookup_rel n env) in + let d = map_constr (lift n) (lookup_rel n env) in mkLambda_or_LetIn d c' | Var id -> let d = lookup_named id env in mkNamedLambda_or_LetIn d c' @@ -556,6 +544,7 @@ let solve_pattern_eqn env sigma l c = let make_projectable_subst aliases sigma evi args = let sign = evar_filtered_context evi in + let sign = List.map (fun d -> map_named_decl EConstr.of_constr d) sign in let evar_aliases = compute_var_aliases sign sigma in let (_,full_subst,cstr_subst) = List.fold_right @@ -571,7 +560,7 @@ let make_projectable_subst aliases sigma evi args = | _ -> cstrs in (rest,Id.Map.add id [a,normalize_alias_opt sigma aliases a,id] all,cstrs) | LocalDef (id,c,_), a::rest -> - (match EConstr.kind sigma (EConstr.of_constr c) with + (match EConstr.kind sigma c with | Var id' -> let idc = normalize_alias_var sigma evar_aliases id' in let sub = try Id.Map.find idc all with Not_found -> [] in @@ -646,19 +635,17 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let LocalAssum (na,t_in_env) | LocalDef (na,_,t_in_env) = d in let id = next_name_away na avoid in let evd,t_in_sign = - let t_in_env = EConstr.of_constr t_in_env in let s = Retyping.get_sort_of env evd t_in_env in let evd,ty_t_in_sign = refresh_universes ~status:univ_flexible (Some false) env evd (mkSort s) in define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env in let evd,d' = match d with - | LocalAssum _ -> evd, nlocal_assum (id,t_in_sign) + | LocalAssum _ -> evd, Context.Named.Declaration.LocalAssum (id,t_in_sign) | LocalDef (_,b,_) -> - let b = EConstr.of_constr b in let evd,b = define_evar_from_virtual_equation define_fun env evd src b t_in_sign sign filter inst_in_env in - evd, nlocal_def (id,b,t_in_sign) in + evd, Context.Named.Declaration.LocalDef (id,b,t_in_sign) in (push_named_context_val d' sign, Filter.extend 1 filter, (mkRel 1)::(List.map (lift 1) inst_in_env), (mkRel 1)::(List.map (lift 1) inst_in_sign), @@ -1238,9 +1225,11 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar The body of ?X and ?Y just has to be of type Π Δ. Type k for some k <= i, j. *) let evienv = Evd.evar_env evi in let ctx1, i = Reduction.dest_arity evienv evi.evar_concl in + let ctx1 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx1 in let evi2 = Evd.find evd evk2 in let evi2env = Evd.evar_env evi2 in let ctx2, j = Reduction.dest_arity evi2env evi2.evar_concl in + let ctx2 = List.map (fun c -> map_rel_decl EConstr.of_constr c) ctx2 in let ui, uj = univ_of_sort i, univ_of_sort j in if i == j || Evd.check_eq evd ui uj then (* Shortcut, i = j *) @@ -1397,7 +1386,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* No unique projection but still restrict to where it is possible *) (* materializing is necessary, but is restricting useful? *) let ty = find_solution_type (evar_filtered_env evi) sols in - let ty' = instantiate_evar_array evi (EConstr.of_constr ty) argsv in + let ty' = instantiate_evar_array evi ty argsv in let (evd,evar,(evk',argsv' as ev')) = materialize_evar (evar_define conv_algo ~choose) env !evdref 0 ev ty' in let ts = expansions_of_var evd aliases t in diff --git a/pretyping/find_subterm.ml b/pretyping/find_subterm.ml index d09686f6e2..3fc569fc4a 100644 --- a/pretyping/find_subterm.ml +++ b/pretyping/find_subterm.ml @@ -64,8 +64,8 @@ let proceed_with_occurrences f occs x = let map_named_declaration_with_hyploc f hyploc acc decl = let open Context.Named.Declaration in let f acc typ = - let acc, typ = f (Some (NamedDecl.get_id decl, hyploc)) acc (EConstr.of_constr typ) in - acc, EConstr.Unsafe.to_constr typ + let acc, typ = f (Some (NamedDecl.get_id decl, hyploc)) acc typ in + acc, typ in match decl,hyploc with | LocalAssum (id,_), InHypValueOnly -> diff --git a/pretyping/find_subterm.mli b/pretyping/find_subterm.mli index 3d2ebb72df..e3d3b74f10 100644 --- a/pretyping/find_subterm.mli +++ b/pretyping/find_subterm.mli @@ -51,7 +51,7 @@ val replace_term_occ_decl_modulo : evar_map -> (occurrences * hyp_location_flag) or_like_first -> 'a testing_function -> (unit -> constr) -> - Context.Named.Declaration.t -> Context.Named.Declaration.t + named_declaration -> named_declaration (** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at positions [occl] by [Rel 1] in [d] (see also Note OCC), @@ -63,7 +63,7 @@ val subst_closed_term_occ : env -> evar_map -> occurrences or_like_first -> closed [c] at positions [occl] by [Rel 1] in [decl]. *) val subst_closed_term_occ_decl : env -> evar_map -> (occurrences * hyp_location_flag) or_like_first -> - constr -> Context.Named.Declaration.t -> Context.Named.Declaration.t * evar_map + constr -> named_declaration -> named_declaration * evar_map (** Miscellaneous *) val error_invalid_occurrence : int list -> 'a diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index c00ceb02e2..3191a58ff0 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -371,7 +371,7 @@ let make_case_or_project env sigma indf ci pred c branches = | LocalAssum (na, t) -> let t = mkProj (Projection.make ps.(i) true, c) in (i + 1, t :: subst) - | LocalDef (na, b, t) -> (i, Vars.substl subst (EConstr.of_constr b) :: subst)) + | LocalDef (na, b, t) -> (i, Vars.substl subst b :: subst)) ctx (0, []) in Vars.substl subst br diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 26e23be23c..954aa6a94c 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -121,19 +121,10 @@ let head_of_constr_reference sigma c = match EConstr.kind sigma c with | Var id -> VarRef id | _ -> anomaly (Pp.str "Not a rigid reference") -let local_assum (na, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - let pattern_of_constr env sigma t = let open EConstr in let rec pattern_of_constr env t = + let open Context.Rel.Declaration in match EConstr.kind sigma t with | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) @@ -143,11 +134,11 @@ let pattern_of_constr env sigma t = | Sort (Type _) -> PSort (GType []) | Cast (c,_,_) -> pattern_of_constr env c | LetIn (na,c,t,b) -> PLetIn (na,pattern_of_constr env c, - pattern_of_constr (push_rel (local_def (na,c,t)) env) b) + pattern_of_constr (push_rel (LocalDef (na,c,t)) env) b) | Prod (na,c,b) -> PProd (na,pattern_of_constr env c, - pattern_of_constr (push_rel (local_assum (na, c)) env) b) + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | Lambda (na,c,b) -> PLambda (na,pattern_of_constr env c, - pattern_of_constr (push_rel (local_assum (na, c)) env) b) + pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | App (f,a) -> (match match EConstr.kind sigma f with diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 4660978df3..2470decdda 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -28,10 +28,10 @@ open Names open Evd open Term open Termops +open Environ open EConstr open Vars open Reductionops -open Environ open Type_errors open Typeops open Typing @@ -70,16 +70,6 @@ open Inductiveops (************************************************************************) -let local_assum (na, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - module ExtraEnv = struct @@ -94,7 +84,7 @@ let get_extra env = let ids = List.map get_id (named_context env) in let avoid = List.fold_right Id.Set.add ids Id.Set.empty in Context.Rel.fold_outside push_rel_decl_to_named_context - (Environ.rel_context env) ~init:(empty_csubst, [], avoid, named_context env) + (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) let make_env env = { env = env; extra = lazy (get_extra env) } let rel_context env = rel_context env.env @@ -116,7 +106,7 @@ let lookup_named id env = lookup_named id env.env let e_new_evar env evdref ?src ?naming typ = let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in let open Context.Named.Declaration in - let inst_vars = List.map (get_id %> EConstr.mkVar) (named_context env.env) in + let inst_vars = List.map (get_id %> mkVar) (named_context env.env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in let (subst, vsubst, _, nc) = Lazy.force env.extra in let typ' = subst2 subst vsubst typ in @@ -128,7 +118,7 @@ let e_new_evar env evdref ?src ?naming typ = e let push_rec_types (lna,typarray,_) env = - let ctxt = Array.map2_i (fun i na t -> local_assum (na, lift i t)) lna typarray in + let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in Array.fold_left (fun e assum -> push_rel assum e) env ctxt end @@ -434,7 +424,6 @@ let pretype_id pretype k0 loc env evdref lvar id = (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in - let typ = EConstr.of_constr typ in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> let env = ltac_interp_name_env k0 lvar env in @@ -468,7 +457,7 @@ let pretype_id pretype k0 loc env evdref lvar id = end; (* Check if [id] is a section or goal variable *) try - { uj_val = mkVar id; uj_type = EConstr.of_constr (NamedDecl.get_type (lookup_named id env)) } + { uj_val = mkVar id; uj_type = NamedDecl.get_type (lookup_named id env) } with Not_found -> (* [id] not found, standard error message *) error_var_not_found ~loc id @@ -511,7 +500,7 @@ let pretype_ref loc evdref env ref us = match ref with | VarRef id -> (* Section variable *) - (try make_judge (mkVar id) (EConstr.of_constr (NamedDecl.get_type (lookup_named id env))) + (try make_judge (mkVar id) (NamedDecl.get_type (lookup_named id env)) with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal @@ -614,14 +603,14 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre [] -> ctxt | (na,bk,None,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = local_assum (na, ty'.utj_val) in - let dcl' = local_assum (ltac_interp_name lvar na,ty'.utj_val) in + let dcl = LocalAssum (na, ty'.utj_val) in + let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in - let dcl = local_def (na, bd'.uj_val, ty'.utj_val) in - let dcl' = local_def (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in + let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in + let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in let larj = @@ -793,7 +782,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let var = local_assum (name, j.utj_val) in + let var = LocalAssum (name, j.utj_val) in let j' = pretype rng (push_rel var env) evdref lvar c2 in let name = ltac_interp_name lvar name in let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in @@ -809,7 +798,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let j = pretype_type empty_valcon env evdref lvar c2 in { j with utj_val = lift 1 j.utj_val } | Name _ -> - let var = local_assum (name, j.utj_val) in + let var = LocalAssum (name, j.utj_val) in let env' = push_rel var env in pretype_type empty_valcon env' evdref lvar c2 in @@ -837,7 +826,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre (* The name specified by ltac is used also to create bindings. So the substitution must also be applied on variables before they are looked up in the rel context. *) - let var = local_def (name, j.uj_val, t) in + let var = LocalDef (name, j.uj_val, t) in let tycon = lift_tycon 1 tycon in let j' = pretype tycon (push_rel var env) evdref lvar c2 in let name = ltac_interp_name lvar name in @@ -861,6 +850,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre user_err ~loc:loc (str "Destructing let on this type expects " ++ int cs.cs_nargs ++ str " variables."); let fsign, record = + let set_name na d = set_name na (map_rel_decl EConstr.of_constr d) in match get_projections env.ExtraEnv.env indf with | None -> List.map2 set_name (List.rev nal) cs.cs_args, false @@ -870,7 +860,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | na :: names, (LocalAssum (_,t) :: l) -> let t = EConstr.of_constr t in let proj = Projection.make ps.(cs.cs_nargs - k) true in - local_def (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) + LocalDef (na, lift (cs.cs_nargs - n) (mkProj (proj, cj.uj_val)), t) :: aux (n+1) (k + 1) names l | na :: names, (decl :: l) -> set_name na decl :: aux (n+1) k names l @@ -896,6 +886,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre else arsgn in let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in + let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let nar = List.length arsgn in (match po with | Some p -> @@ -903,6 +894,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let psign = make_arity_signature env.ExtraEnv.env true indf in (* with names *) + let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let p = it_mkLambda_or_LetIn ccl psign in let inst = (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) @@ -956,6 +948,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre in let nar = List.length arsgn in let psign = LocalAssum (na, build_dependent_inductive env.ExtraEnv.env indf) :: arsgn in + let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let pred,p = match po with | Some p -> let env_p = push_rel_context psign env in @@ -978,17 +971,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let n = Context.Rel.length cs.cs_args in let pi = lift n pred in (* liftn n 2 pred ? *) let pi = beta_applist !evdref (pi, [EConstr.of_constr (build_dependent_constructor cs)]) in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs.cs_args in let csgn = if not !allow_anonymous_refs then - List.map (set_name Anonymous) cs.cs_args + List.map (set_name Anonymous) cs_args else List.map (map_name (function Name _ as n -> n | Anonymous -> Name Namegen.default_non_dependent_ident)) - cs.cs_args + cs_args in let env_c = push_rel_context csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in - it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + it_mkLambda_or_LetIn bj.uj_val cs_args in let b1 = f cstrs.(0) b1 in let b2 = f cstrs.(1) b2 in let v = @@ -1060,12 +1054,10 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = with Not_found -> try let (n,_,t') = lookup_rel_id id (rel_context env) in - let t' = EConstr.of_constr t' in if is_conv env.ExtraEnv.env !evdref t t' then mkRel n, update else raise Not_found with Not_found -> try let t' = env |> lookup_named id |> NamedDecl.get_type in - let t' = EConstr.of_constr t' in if is_conv env.ExtraEnv.env !evdref t t' then mkVar id, update else raise Not_found with Not_found -> user_err ~loc (str "Cannot interpret " ++ diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index bc5c629f4e..a1585ef52b 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -13,9 +13,9 @@ open Term open Termops open Univ open Evd +open Environ open EConstr open Vars -open Environ open Context.Rel.Declaration exception Elimconst @@ -609,14 +609,6 @@ let pr_state (tm,sk) = let pr c = Termops.print_constr c in h 0 (pr tm ++ str "|" ++ cut () ++ Stack.pr pr sk) -let local_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - (*************************************) (*** Reduction Functions Operators ***) (*************************************) @@ -851,12 +843,12 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = match c0 with | Rel n when CClosure.RedFlags.red_set flags CClosure.RedFlags.fDELTA -> (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n (EConstr.of_constr body), stack) + | LocalDef (_,body,_) -> whrec Cst_stack.empty (lift n body, stack) | _ -> fold ()) | Var id when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fVAR id) -> (match lookup_named id env with | LocalDef (_,body,_) -> - whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (EConstr.of_constr body, stack) + whrec (if refold then Cst_stack.add_cst (mkVar id) cst_l else cst_l) (body, stack) | _ -> fold ()) | Evar ev -> fold () | Meta ev -> @@ -958,7 +950,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some _ when CClosure.RedFlags.red_set flags CClosure.RedFlags.fBETA -> apply_subst (fun _ -> whrec) [] sigma refold cst_l x stack | None when CClosure.RedFlags.red_set flags CClosure.RedFlags.fETA -> - let env' = push_rel (local_assum (na, t)) env in + let env' = push_rel (LocalAssum (na, t)) env in let whrec' = whd_state_gen ~refold ~tactic_mode flags env' sigma in (match EConstr.kind sigma (Stack.zip ~refold sigma (fst (whrec' (c, Stack.empty)))) with | App (f,cl) -> @@ -1468,7 +1460,7 @@ let splay_prod env sigma = let t = whd_all env sigma c in match EConstr.kind sigma t with | Prod (n,a,c0) -> - decrec (push_rel (local_assum (n,a)) env) + decrec (push_rel (LocalAssum (n,a)) env) (bind_assum (n,a)::m) c0 | _ -> m,t in @@ -1479,7 +1471,7 @@ let splay_lam env sigma = let t = whd_all env sigma c in match EConstr.kind sigma t with | Lambda (n,a,c0) -> - decrec (push_rel (local_assum (n,a)) env) + decrec (push_rel (LocalAssum (n,a)) env) (bind_assum (n,a)::m) c0 | _ -> m,t in @@ -1490,11 +1482,11 @@ let splay_prod_assum env sigma = let t = whd_allnolet env sigma c in match EConstr.kind sigma t with | Prod (x,t,c) -> - prodec_rec (push_rel (local_assum (x,t)) env) - (Context.Rel.add (local_assum (x,t)) l) c + prodec_rec (push_rel (LocalAssum (x,t)) env) + (Context.Rel.add (LocalAssum (x,t)) l) c | LetIn (x,b,t,c) -> - prodec_rec (push_rel (local_def (x,b,t)) env) - (Context.Rel.add (local_def (x,b,t)) l) c + prodec_rec (push_rel (LocalDef (x,b,t)) env) + (Context.Rel.add (LocalDef (x,b,t)) l) c | Cast (c,_,_) -> prodec_rec env l c | _ -> let t' = whd_all env sigma t in @@ -1515,8 +1507,8 @@ let splay_prod_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match EConstr.kind sigma (whd_all env sigma c) with | Prod (n,a,c0) -> - decrec (push_rel (local_assum (n,a)) env) - (m-1) (Context.Rel.add (local_assum (n,a)) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_prod_n" in decrec env n Context.Rel.empty @@ -1525,8 +1517,8 @@ let splay_lam_n env sigma n = let rec decrec env m ln c = if Int.equal m 0 then (ln,c) else match EConstr.kind sigma (whd_all env sigma c) with | Lambda (n,a,c0) -> - decrec (push_rel (local_assum (n,a)) env) - (m-1) (Context.Rel.add (local_assum (n,a)) ln) c0 + decrec (push_rel (LocalAssum (n,a)) env) + (m-1) (Context.Rel.add (LocalAssum (n,a)) ln) c0 | _ -> invalid_arg "splay_lam_n" in decrec env n Context.Rel.empty @@ -1566,8 +1558,8 @@ let find_conclusion env sigma = let rec decrec env c = let t = whd_all env sigma c in match EConstr.kind sigma t with - | Prod (x,t,c0) -> decrec (push_rel (local_assum (x,t)) env) c0 - | Lambda (x,t,c0) -> decrec (push_rel (local_assum (x,t)) env) c0 + | Prod (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 + | Lambda (x,t,c0) -> decrec (push_rel (LocalAssum (x,t)) env) c0 | t -> t in decrec env diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index dcc11cfcf3..15ddeb15c0 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -217,10 +217,10 @@ val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts val sort_of_arity : env -> evar_map -> constr -> sorts -val splay_prod_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr -val splay_lam_n : env -> evar_map -> int -> constr -> Context.Rel.t * constr +val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr +val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : - env -> evar_map -> constr -> Context.Rel.t * constr + env -> evar_map -> constr -> rel_context * constr type 'a miota_args = { mP : constr; (** the result type *) diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index a9529d560c..bb1b2901e5 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -50,14 +50,6 @@ let anomaly_on_error f x = try f x with RetypeError e -> anomaly ~label:"retyping" (print_retype_error e) -let local_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - let get_type_from_constraints env sigma t = if isEvar sigma (fst (decompose_app_vect sigma t)) then match @@ -84,13 +76,13 @@ let rec subst_type env sigma typ = function let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = match EConstr.kind sigma (whd_all env sigma ar), args with - | Prod (na, t, b), h::l -> concl_of_arity (push_rel (local_def (na, lift n h, t)) env) (n + 1) b l + | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l | Sort s, [] -> s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) let type_of_var env id = - try EConstr.of_constr (NamedDecl.get_type (lookup_named id env)) + try NamedDecl.get_type (lookup_named id env) with Not_found -> retype_error (BadVariable id) let decomp_sort env sigma t = @@ -105,7 +97,7 @@ let retype ?(polyprop=true) sigma = (try strip_outer_cast sigma (EConstr.of_constr (Evd.meta_ftype sigma n).Evd.rebus) with Not_found -> retype_error (BadMeta n)) | Rel n -> - let ty = EConstr.of_constr (RelDecl.get_type (lookup_rel n env)) in + let ty = RelDecl.get_type (lookup_rel n env) in lift n ty | Var id -> type_of_var env id | Const cst -> EConstr.of_constr (rename_type_of_constant env cst) @@ -128,9 +120,9 @@ let retype ?(polyprop=true) sigma = | Prod _ -> whd_beta sigma (applist (t, [c])) | _ -> t) | Lambda (name,c1,c2) -> - mkProd (name, c1, type_of (push_rel (local_assum (name,c1)) env) c2) + mkProd (name, c1, type_of (push_rel (LocalAssum (name,c1)) env) c2) | LetIn (name,b,c1,c2) -> - subst1 b (type_of (push_rel (local_def (name,b,c1)) env) c2) + subst1 b (type_of (push_rel (LocalDef (name,b,c1)) env) c2) | Fix ((_,i),(_,tys,_)) -> tys.(i) | CoFix (i,(_,tys,_)) -> tys.(i) | App(f,args) when is_template_polymorphic env sigma f -> @@ -153,7 +145,7 @@ let retype ?(polyprop=true) sigma = | Sort (Prop c) -> type1_sort | Sort (Type u) -> Type (Univ.super u) | Prod (name,t,c2) -> - (match (sort_of env t, sort_of (push_rel (local_assum (name,t)) env) c2) with + (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s @@ -174,7 +166,7 @@ let retype ?(polyprop=true) sigma = | Sort (Prop c) -> InType | Sort (Type u) -> InType | Prod (name,t,c2) -> - let s2 = sort_family_of (push_rel (local_assum (name,t)) env) c2 in + let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && s2 == InSet && sort_family_of env t == InType then InType else s2 | App(f,args) when is_template_polymorphic env sigma f -> @@ -249,7 +241,7 @@ let sorts_of_context env evc ctxt = | [] -> env,[] | d :: ctxt -> let env,sorts = aux ctxt in - let s = get_sort_of env evc (EConstr.of_constr (RelDecl.get_type d)) in + let s = get_sort_of env evc (RelDecl.get_type d) in (push_rel d env,s::sorts) in snd (aux ctxt) diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index ce9e1635fc..25129db1c9 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -44,7 +44,7 @@ val type_of_global_reference_knowing_parameters : env -> evar_map -> constr -> val type_of_global_reference_knowing_conclusion : env -> evar_map -> constr -> types -> evar_map * types -val sorts_of_context : env -> evar_map -> Context.Rel.t -> sorts list +val sorts_of_context : env -> evar_map -> rel_context -> sorts list val expand_projection : env -> evar_map -> Names.projection -> constr -> constr list -> constr diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 4abfc26fc5..9f3f3c7e5e 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -14,11 +14,11 @@ open Term open Libnames open Globnames open Termops +open Environ open EConstr open Vars open Find_subterm open Namegen -open Environ open CClosure open Reductionops open Cbv @@ -60,7 +60,7 @@ let is_evaluable env = function let value_of_evaluable_ref env evref u = match evref with | EvalConstRef con -> - (try constant_value_in env (con,u) + EConstr.of_constr (try constant_value_in env (con,u) with NotEvaluableConst IsProj -> raise (Invalid_argument "value_of_evaluable_ref")) | EvalVarRef id -> env |> lookup_named id |> NamedDecl.get_value |> Option.get @@ -115,9 +115,9 @@ let unsafe_reference_opt_value env sigma eval = | Declarations.Def c -> Some (EConstr.of_constr (Mod_subst.force_constr c)) | _ -> None) | EvalVar id -> - env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr + env |> lookup_named id |> NamedDecl.get_value | EvalRel n -> - env |> lookup_rel n |> RelDecl.get_value |> Option.map (EConstr.of_constr %> lift n) + env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) | EvalEvar ev -> match EConstr.kind sigma (mkEvar ev) with | Evar _ -> None @@ -127,9 +127,9 @@ let reference_opt_value env sigma eval u = match eval with | EvalConst cst -> Option.map EConstr.of_constr (constant_opt_value_in env (cst,u)) | EvalVar id -> - env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr + env |> lookup_named id |> NamedDecl.get_value | EvalRel n -> - env |> lookup_rel n |> RelDecl.get_value |> Option.map (EConstr.of_constr %> lift n) + env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) | EvalEvar ev -> match EConstr.kind sigma (mkEvar ev) with | Evar _ -> None @@ -146,11 +146,11 @@ let reference_value env sigma c u = (* One reuses the name of the function after reduction of the fixpoint *) type constant_evaluation = - | EliminationFix of int * int * (int * (int * EConstr.t) list * int) + | EliminationFix of int * int * (int * (int * constr) list * int) | EliminationMutualFix of int * evaluable_reference * ((int*evaluable_reference) option array * - (int * (int * EConstr.t) list * int)) + (int * (int * constr) list * int)) | EliminationCases of int | EliminationProj of int | NotAnElimination @@ -261,22 +261,13 @@ let invert_name labs l na0 env sigma ref = function [compute_consteval_mutual_fix] only one by one, until finding the last one before the Fix if the latter is mutually defined *) -let local_assum (na, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - let compute_consteval_direct env sigma ref = let rec srec env n labs onlyproj c = let c',l = whd_betadeltazeta_stack env sigma c in match EConstr.kind sigma c' with | Lambda (id,t,g) when List.is_empty l && not onlyproj -> - srec (push_rel (local_assum (id,t)) env) (n+1) (t::labs) onlyproj g + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (id,t)) env) (n+1) (t::labs) onlyproj g | Fix fix when not onlyproj -> (try check_fix_reversibility sigma labs l fix with Elimconst -> NotAnElimination) @@ -295,7 +286,8 @@ let compute_consteval_mutual_fix env sigma ref = let nargs = List.length l in match EConstr.kind sigma c' with | Lambda (na,t,g) when List.is_empty l -> - srec (push_rel (local_assum (na,t)) env) (minarg+1) (t::labs) ref g + let open Context.Rel.Declaration in + srec (push_rel (LocalAssum (na,t)) env) (minarg+1) (t::labs) ref g | Fix ((lv,i),(names,_,_)) -> (* Last known constant wrapping Fix is ref = [labs](Fix l) *) (match compute_consteval_direct env sigma ref with @@ -386,7 +378,7 @@ let make_elim_fun (names,(nbfix,lv,n)) u largs = (* [f] is convertible to [Fix(recindices,bodynum),bodyvect)]: do so that the reduction uses this extra information *) -let dummy = Constr.mkProp +let dummy = mkProp let vfx = Id.of_string "_expanded_fix_" let vfun = Id.of_string "_eliminator_function_" let venv = let open Context.Named.Declaration in @@ -405,7 +397,7 @@ let substl_with_function subst sigma constr = match v.(i-k-1) with | (fx, Some (min, ref)) -> let sigma = Sigma.Unsafe.of_evar_map !evd in - let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma (EConstr.of_constr dummy) in + let Sigma (evk, sigma, _) = Evarutil.new_pure_evar venv sigma dummy in let sigma = Sigma.to_evar_map sigma in evd := sigma; minargs := Evar.Map.add evk min !minargs; @@ -466,7 +458,7 @@ let substl_checking_arity env subst sigma c = in nf_fix body -type fix_reduction_result = NotReducible | Reduced of (EConstr.t * EConstr.t list) +type fix_reduction_result = NotReducible | Reduced of (constr * constr list) let reduce_fix whdfun sigma fix stack = match fix_recarg fix (Stack.append_app_list stack Stack.empty) with @@ -557,9 +549,9 @@ let match_eval_ref_value env sigma constr = | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> Some (EConstr.of_constr (constant_value_in env (sp, u))) | Var id when is_evaluable env (EvalVarRef id) -> - env |> lookup_named id |> NamedDecl.get_value |> Option.map EConstr.of_constr + env |> lookup_named id |> NamedDecl.get_value | Rel n -> - env |> lookup_rel n |> RelDecl.get_value |> Option.map (EConstr.of_constr %> lift n) + env |> lookup_rel n |> RelDecl.get_value |> Option.map (lift n) | _ -> None let special_red_case env sigma whfun (ci, p, c, lf) = @@ -625,12 +617,12 @@ let whd_nothing_for_iota env sigma s = | Rel n -> let open Context.Rel.Declaration in (match lookup_rel n env with - | LocalDef (_,body,_) -> whrec (lift n (EConstr.of_constr body), stack) + | LocalDef (_,body,_) -> whrec (lift n body, stack) | _ -> s) | Var id -> let open Context.Named.Declaration in (match lookup_named id env with - | LocalDef (_,body,_) -> whrec (EConstr.of_constr body, stack) + | LocalDef (_,body,_) -> whrec (body, stack) | _ -> s) | Evar ev -> s | Meta ev -> @@ -834,7 +826,8 @@ let try_red_product env sigma c = | _ -> simpfun (mkApp (redrec env f, l))) | Cast (c,_,_) -> redrec env c | Prod (x,a,b) -> - mkProd (x, a, redrec (push_rel (local_assum (x, a)) env) b) + let open Context.Rel.Declaration in + mkProd (x, a, redrec (push_rel (LocalAssum (x, a)) env) b) | LetIn (x,a,b,t) -> redrec env (Vars.subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) | Proj (p, c) -> @@ -1053,7 +1046,7 @@ let substlin env sigma evalref n (nowhere_except_in,locs) c = let maxocc = List.fold_right max locs 0 in let pos = ref n in assert (List.for_all (fun x -> x >= 0) locs); - let value u = EConstr.of_constr (value_of_evaluable_ref env evalref u) in + let value u = value_of_evaluable_ref env evalref u in let rec substrec () c = if nowhere_except_in && !pos > maxocc then c else @@ -1192,7 +1185,7 @@ let reduce_to_ind_gen allow_product env sigma t = | Prod (n,ty,t') -> let open Context.Rel.Declaration in if allow_product then - elimrec (push_rel (local_assum (n,ty)) env) t' ((local_assum (n,ty))::l) + elimrec (push_rel (LocalAssum (n,ty)) env) t' ((LocalAssum (n,ty))::l) else user_err (str"Not an inductive definition.") | _ -> @@ -1270,7 +1263,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = | Prod (n,ty,t') -> if allow_product then let open Context.Rel.Declaration in - elimrec (push_rel (local_assum (n,t)) env) t' ((local_assum (n,ty))::l) + elimrec (push_rel (LocalAssum (n,t)) env) t' ((LocalAssum (n,ty))::l) else error_cannot_recognize ref | _ -> diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 50ae66eb0e..ce570ee127 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -300,6 +300,7 @@ let build_subclasses ~check env sigma glob pri = | Some (Backward, _) -> None | Some (Forward, pri') -> let proj = Option.get proj in + let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in if check && check_instance env sigma (EConstr.of_constr body) then None else diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index e95aba695d..0c30296d35 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -67,7 +67,7 @@ val dest_class_app : env -> evar_map -> EConstr.constr -> typeclass puniverses * val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : evar_map -> EConstr.constr -> (Context.Rel.t * (typeclass puniverses * constr list)) option +val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference diff --git a/pretyping/typing.ml b/pretyping/typing.ml index e6f1e46b6d..bdd3663d1a 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -12,9 +12,9 @@ open Pp open CErrors open Util open Term +open Environ open EConstr open Vars -open Environ open Reductionops open Inductive open Inductiveops @@ -23,14 +23,6 @@ open Arguments_renaming open Pretype_errors open Context.Rel.Declaration -let local_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - let push_rec_types pfix env = let (i, c, t) = pfix in let inj c = EConstr.Unsafe.to_constr c in @@ -101,14 +93,15 @@ let max_sort l = let e_is_correct_arity env evdref c pj ind specif params = let arsign = make_arity_signature env true (make_ind_family (ind,params)) in + let arsign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) arsign in let allowed_sorts = elim_sorts specif in let error () = Pretype_errors.error_elim_arity env !evdref ind allowed_sorts c pj None in let rec srec env pt ar = let pt' = whd_all env !evdref pt in match EConstr.kind !evdref pt', ar with | Prod (na1,a1,t), (LocalAssum (_,a1'))::ar' -> - if not (Evarconv.e_cumul env evdref a1 (EConstr.of_constr a1')) then error (); - srec (push_rel (local_assum (na1,a1)) env) t ar' + if not (Evarconv.e_cumul env evdref a1 a1') then error (); + srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Sort s, [] -> if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () @@ -326,14 +319,14 @@ let rec execute env evdref cstr = | Lambda (name,c1,c2) -> let j = execute env evdref c1 in let var = e_type_judgment env evdref j in - let env1 = push_rel (local_assum (name, var.utj_val)) env in + let env1 = push_rel (LocalAssum (name, var.utj_val)) env in let j' = execute env1 evdref c2 in judge_of_abstraction env1 name var j' | Prod (name,c1,c2) -> let j = execute env evdref c1 in let varj = e_type_judgment env evdref j in - let env1 = push_rel (local_assum (name, varj.utj_val)) env in + let env1 = push_rel (LocalAssum (name, varj.utj_val)) env in let j' = execute env1 evdref c2 in let varj' = e_type_judgment env1 evdref j' in judge_of_product env name varj varj' @@ -343,7 +336,7 @@ let rec execute env evdref cstr = let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in - let env1 = push_rel (local_def (name, j1.uj_val, j2.utj_val)) env in + let env1 = push_rel (LocalDef (name, j1.uj_val, j2.utj_val)) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 04cc4253e0..0d6dcffc10 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -14,10 +14,10 @@ open Util open Names open Term open Termops +open Environ open EConstr open Vars open Namegen -open Environ open Evd open Reduction open Reductionops @@ -91,7 +91,6 @@ let abstract_scheme env evd c l lname_typ = (fun (t,evd) (locc,a) decl -> let na = RelDecl.get_name decl in let ta = RelDecl.get_type decl in - let ta = EConstr.of_constr ta in let na = match EConstr.kind evd a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... @@ -1627,6 +1626,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let likefirst = clause_with_generic_occurrences occs in let mkvarid () = EConstr.mkVar id in let compute_dependency _ d (sign,depdecls) = + let d = map_named_decl EConstr.of_constr d in let hyp = NamedDecl.get_id d in match occurrences_of_hyp hyp occs with | NoOccurrences, InHyp -> @@ -1634,7 +1634,7 @@ let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = | AllOccurrences, InHyp as occ -> let occ = if likefirst then LikeFirst else AtOccs occ in let newdecl = replace_term_occ_decl_modulo sigma occ test mkvarid d in - if Context.Named.Declaration.equal Constr.equal d newdecl + if Context.Named.Declaration.equal (EConstr.eq_constr sigma) d newdecl && not (indirectly_dependent sigma c d depdecls) then if check_occs && not (in_every_hyp occs) @@ -1688,7 +1688,7 @@ type abstraction_request = type 'r abstraction_result = Names.Id.t * named_context_val * - Context.Named.Declaration.t list * Names.Id.t option * + named_declaration list * Names.Id.t option * types * (constr, 'r) Sigma.sigma option let make_abstraction env evd ccl abs = diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 41dcb8ed30..6760283d25 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -82,7 +82,7 @@ val finish_evar_resolution : ?flags:Pretyping.inference_flags -> type 'r abstraction_result = Names.Id.t * named_context_val * - Context.Named.Declaration.t list * Names.Id.t option * + named_declaration list * Names.Id.t option * types * (constr, 'r) Sigma.sigma option val make_abstraction : env -> 'r Sigma.t -> constr -> -- cgit v1.2.3 From 4e9cebb0641927f11a21cbb50828974f910cfe47 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Nov 2016 15:25:06 +0100 Subject: Putting back the subst_defined_metas_evars function in the old term API. It seems this is a performance-critical function for unification-heavy code. In particular, tactics relying on meta unification suffered an important penalty after this function was rewritten with the evar-insensitive API, as witnessed e.g. by Ncring_polynom whose compilation time increased by ~30%. I am not sure about the specification of this function, but it seems safer to revert the changes and just do it the old way. It may even disappear if we get rid of the old unification algorithm at some point. --- pretyping/unification.ml | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) (limited to 'pretyping') diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 0d6dcffc10..589201fe2e 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -601,16 +601,20 @@ let isAllowedEvar sigma flags c = match EConstr.kind sigma c with let subst_defined_metas_evars sigma (bl,el) c = - let rec substrec c = match EConstr.kind sigma c with + (** This seems to be performance-critical, and using the evar-insensitive + primitives blow up the time passed in this function. *) + let c = EConstr.Unsafe.to_constr c in + let rec substrec c = match kind_of_term c with | Meta i -> let select (j,_,_) = Int.equal i j in - substrec (pi2 (List.find select bl)) + substrec (EConstr.Unsafe.to_constr (pi2 (List.find select bl))) | Evar (evk,args) -> - let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.equal (EConstr.eq_constr sigma) args args' in - (try substrec (pi3 (List.find select el)) - with Not_found -> EConstr.map sigma substrec c) - | _ -> EConstr.map sigma substrec c - in try Some (substrec c) with Not_found -> None + let eq c1 c2 = Constr.equal c1 (EConstr.Unsafe.to_constr c2) in + let select (_,(evk',args'),_) = Evar.equal evk evk' && Array.for_all2 eq args args' in + (try substrec (EConstr.Unsafe.to_constr (pi3 (List.find select el))) + with Not_found -> Constr.map substrec c) + | _ -> Constr.map substrec c + in try Some (EConstr.of_constr (substrec c)) with Not_found -> None let check_compatibility env pbty flags (sigma,metasubst,evarsubst : subst0) tyM tyN = match subst_defined_metas_evars sigma (metasubst,[]) tyM with -- cgit v1.2.3 From 390fd4ac0a969103caeb5db3e5138e26f9a533de Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Nov 2016 17:49:11 +0100 Subject: Chasing a few unsafe constr coercions. --- pretyping/evarconv.ml | 8 +++++++- pretyping/evarsolve.ml | 8 +++++++- 2 files changed, 14 insertions(+), 2 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index f5cab070ed..1cbea68dda 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -973,7 +973,13 @@ let apply_on_subterm env evdref f c t = (* By using eq_constr, we make an approximation, for instance, we *) (* could also be interested in finding a term u convertible to t *) (* such that c occurs in u *) - if e_eq_constr_univs evdref (EConstr.Unsafe.to_constr c) (EConstr.Unsafe.to_constr t) then f k + let eq_constr c1 c2 = match EConstr.eq_constr_universes !evdref c1 c2 with + | None -> false + | Some cstr -> + try ignore (Evd.add_universe_constraints !evdref cstr); true + with UniversesDiffer -> false + in + if eq_constr c t then f k else match EConstr.kind !evdref t with | Evar (evk,args) -> diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index ff47365286..28e63d04b9 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -1263,7 +1263,13 @@ type conv_fun_bool = let solve_refl ?(can_drop=false) conv_algo env evd pbty evk argsv1 argsv2 = let evdref = ref evd in - if Array.equal (fun c1 c2 -> e_eq_constr_univs evdref (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) ) argsv1 argsv2 then !evdref else + let eq_constr c1 c2 = match EConstr.eq_constr_universes !evdref c1 c2 with + | None -> false + | Some cstr -> + try ignore (Evd.add_universe_constraints !evdref cstr); true + with UniversesDiffer -> false + in + if Array.equal eq_constr argsv1 argsv2 then !evdref else (* Filter and restrict if needed *) let args = Array.map2 (fun a1 a2 -> (a1, a2)) argsv1 argsv2 in let untypedfilter = -- cgit v1.2.3 From 27fbf069ccd846383bcfb35ba1ea5bd1d95090a0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Nov 2016 23:48:28 +0100 Subject: Moving printing code from Evd to Termops. --- pretyping/detyping.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'pretyping') diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index d4e156fa4b..c8d945c0b5 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -422,7 +422,7 @@ let detype_sort sigma = function | Type u -> GType (if !print_universes - then [dl, Pp.string_of_ppcmds (Univ.Universe.pr_with (Evd.pr_evd_level sigma) u)] + then [dl, Pp.string_of_ppcmds (Univ.Universe.pr_with (Termops.pr_evd_level sigma) u)] else []) type binder_kind = BProd | BLambda | BLetIn @@ -434,7 +434,7 @@ let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index let set_detype_anonymous f = detype_anonymous := f let detype_level sigma l = - GType (Some (dl, Pp.string_of_ppcmds (Evd.pr_evd_level sigma l))) + GType (Some (dl, Pp.string_of_ppcmds (Termops.pr_evd_level sigma l))) let detype_instance sigma l = if Univ.Instance.is_empty l then None @@ -533,7 +533,7 @@ let rec detype flags avoid env sigma t = let id,l = try let id = match Evd.evar_ident evk sigma with - | None -> Evd.pr_evar_suggested_name evk sigma + | None -> Termops.pr_evar_suggested_name evk sigma | Some id -> id in let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in -- cgit v1.2.3 From be51c33a6bf91a00fdd5f3638ddb5b3cc3a2c626 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 30 Nov 2016 00:41:31 +0100 Subject: Namegen primitives now apply on evar constrs. Incidentally, this fixes a printing bug in output/inference.v where the displayed name of an evar was the wrong one because its type was not evar-expanded enough. --- pretyping/cases.ml | 15 +++---- pretyping/detyping.ml | 104 ++++++++++++++++++++++----------------------- pretyping/detyping.mli | 7 +-- pretyping/evardefine.ml | 2 +- pretyping/indrec.ml | 20 +++++++-- pretyping/inductiveops.ml | 32 ++++++++------ pretyping/inductiveops.mli | 6 +-- pretyping/pretyping.ml | 75 ++++++++++++++++---------------- pretyping/tacred.ml | 2 +- pretyping/typing.ml | 3 +- pretyping/unification.ml | 5 +-- 11 files changed, 143 insertions(+), 128 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index a5a5fe6d2e..490bc2801f 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -708,7 +708,7 @@ let merge_name get_name obj = function let merge_names get_name = List.map2 (merge_name get_name) -let get_names env sign eqns = +let get_names env sigma sign eqns = let names1 = List.make (Context.Rel.length sign) Anonymous in (* If any, we prefer names used in pats, from top to bottom *) let names2,aliasname = @@ -727,7 +727,7 @@ let get_names env sign eqns = (fun (l,avoid) d na -> let na = merge_name - (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env (EConstr.Unsafe.to_constr t) na) avoid)) + (fun (LocalAssum (na,t) | LocalDef (na,_,t)) -> Name (next_name_away (named_hd env sigma t na) avoid)) d na in (na::l,(out_name na)::avoid)) @@ -924,7 +924,7 @@ let rec extract_predicate ccl = function ccl let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = - let sign = make_arity_signature env true indf in + let sign = make_arity_signature env sigma true indf in (* n is the number of real args + 1 (+ possible let-ins in sign) *) let n = List.length sign in (* Before abstracting we generalize over cur and on those realargs *) @@ -945,7 +945,7 @@ let abstract_predicate env sigma indf cur realargs (names,na) tms ccl = let pred = extract_predicate ccl tms in (* Build the predicate properly speaking *) let sign = List.map2 set_name (na::names) sign in - EConstr.of_constr (it_mkLambda_or_LetIn_name env (EConstr.Unsafe.to_constr pred) sign) + it_mkLambda_or_LetIn_name env sigma pred sign (* [expand_arg] is used by [specialize_predicate] if Yk denotes [Xk;xk] or [Xk], @@ -1238,7 +1238,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn (* that had matched constructor C *) let cs_args = const_info.cs_args in let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cs_args in - let names,aliasname = get_names pb.env cs_args eqns in + let names,aliasname = get_names pb.env !(pb.evdref) cs_args eqns in let typs = List.map2 RelDecl.set_name names cs_args in @@ -1714,7 +1714,7 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let build_inversion_problem loc env sigma tms t = let make_patvar t (subst,avoid) = - let id = next_name_away (named_hd env (EConstr.Unsafe.to_constr t) Anonymous) avoid in + let id = next_name_away (named_hd env sigma t Anonymous) avoid in PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match EConstr.kind sigma (whd_all env sigma t) with @@ -1733,8 +1733,7 @@ let build_inversion_problem loc env sigma tms t = let patl,acc = List.fold_map' reveal_pattern realargs acc in let pat,acc = make_patvar t acc in let indf' = lift_inductive_family n indf in - let sign = make_arity_signature env true indf' in - let sign = List.map (fun d -> map_rel_decl EConstr.of_constr d) sign in + let sign = make_arity_signature env sigma true indf' in let patl = pat :: List.rev patl in let patl,sign = recover_and_adjust_alias_names patl sign in let p = List.length patl in diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index c8d945c0b5..1adda14abe 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -6,14 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open Pp open CErrors open Util open Names open Term +open Environ +open EConstr open Vars open Inductiveops -open Environ open Glob_term open Glob_ops open Termops @@ -188,7 +191,7 @@ let _ = declare_bool_option (* Auxiliary function for MutCase printing *) (* [computable] tries to tell if the predicate typing the result is inferable*) -let computable p k = +let computable sigma p k = (* We first remove as many lambda as the arity, then we look if it remains a lambda for a dependent elimination. This function works for normal eta-expanded term. For non eta-expanded or @@ -205,31 +208,29 @@ let computable p k = sinon on perd la réciprocité de la synthèse (qui, lui, engendrera un prédicat non dépendant) *) - let sign,ccl = decompose_lam_assum p in + let sign,ccl = decompose_lam_assum sigma p in Int.equal (Context.Rel.length sign) (k + 1) && - noccur_between 1 (k+1) ccl + noccur_between sigma 1 (k+1) ccl -let pop t = Vars.lift (-1) t - -let lookup_name_as_displayed env t s = - let rec lookup avoid n c = match kind_of_term c with +let lookup_name_as_displayed env sigma t s = + let rec lookup avoid n c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in RenamingForGoal avoid name c' with + (match compute_displayed_name_in sigma RenamingForGoal avoid name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | LetIn (name,_,_,c') -> - (match compute_displayed_name_in RenamingForGoal avoid name c' with + (match compute_displayed_name_in sigma RenamingForGoal avoid name c' with | (Name id,avoid') -> if Id.equal id s then Some n else lookup avoid' (n+1) c' | (Anonymous,avoid') -> lookup avoid' (n+1) (pop c')) | Cast (c,_,_) -> lookup avoid n c | _ -> None in lookup (ids_of_named_context (named_context env)) 1 t -let lookup_index_as_renamed env t n = - let rec lookup n d c = match kind_of_term c with +let lookup_index_as_renamed env sigma t n = + let rec lookup n d c = match EConstr.kind sigma c with | Prod (name,_,c') -> - (match compute_displayed_name_in RenamingForGoal [] name c' with + (match compute_displayed_name_in sigma RenamingForGoal [] name c' with (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -239,7 +240,7 @@ let lookup_index_as_renamed env t n = else lookup (n-1) (d+1) c') | LetIn (name,_,_,c') -> - (match compute_displayed_name_in RenamingForGoal [] name c' with + (match compute_displayed_name_in sigma RenamingForGoal [] name c' with | (Name _,_) -> lookup n (d+1) c' | (Anonymous,_) -> if Int.equal n 0 then @@ -256,9 +257,9 @@ let lookup_index_as_renamed env t n = (**********************************************************************) (* Fragile algorithm to reverse pattern-matching compilation *) -let update_name na ((_,(e,_)),c) = +let update_name sigma na ((_,(e,_)),c) = match na with - | Name _ when force_wildcard () && noccurn (List.index Name.equal na e) c -> + | Name _ when force_wildcard () && noccurn sigma (List.index Name.equal na e) c -> Anonymous | _ -> na @@ -269,7 +270,7 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = | [] -> (List.rev nal,(e,c)) | b::tags -> let na,c,f,body,t = - match kind_of_term (EConstr.Unsafe.to_constr (strip_outer_cast sigma (EConstr.of_constr c))), b with + match EConstr.kind sigma (strip_outer_cast sigma c), b with | Lambda (na,t,c),false -> na,c,compute_displayed_let_name_in,None,Some t | LetIn (na,b,t,c),true -> na,c,compute_displayed_name_in,Some b,Some t @@ -279,12 +280,12 @@ let rec decomp_branch tags nal b (avoid,env as e) sigma c = | _, true -> Anonymous,lift 1 c,compute_displayed_name_in,None,None in - let na',avoid' = f flag avoid na c in + let na',avoid' = f sigma flag avoid na c in decomp_branch tags (na'::nal) b (avoid', add_name_opt na' body t env) sigma c let rec build_tree na isgoal e sigma ci cl = - let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name na rhs) in + let mkpat n rhs pl = PatCstr(dl,(ci.ci_ind,n+1),pl,update_name sigma na rhs) in let cnl = ci.ci_pp_info.cstr_tags in let cna = ci.ci_cstr_nargs in List.flatten @@ -294,12 +295,12 @@ let rec build_tree na isgoal e sigma ci cl = and align_tree nal isgoal (e,c as rhs) sigma = match nal with | [] -> [[],rhs] | na::nal -> - match kind_of_term c with + match EConstr.kind sigma c with | Case (ci,p,c,cl) when - eq_constr sigma (EConstr.of_constr c) (EConstr.mkRel (List.index Name.equal na (fst (snd e)))) + eq_constr sigma c (mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) - computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> + computable sigma p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> let clauses = build_tree na isgoal e sigma ci cl in List.flatten (List.map (fun (pat,rhs) -> @@ -307,7 +308,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with List.map (fun (hd,rest) -> pat::hd,rest) lines) clauses) | _ -> - let pat = PatVar(dl,update_name na rhs) in + let pat = PatVar(dl,update_name sigma na rhs) in let mat = align_tree nal isgoal rhs sigma in List.map (fun (hd,rest) -> pat::hd,rest) mat @@ -320,11 +321,11 @@ and contract_branch isgoal e sigma (cdn,can,mkpat,b) = (* Transform internal representation of pattern-matching into list of *) (* clauses *) -let is_nondep_branch c l = +let is_nondep_branch sigma c l = try (* FIXME: do better using tags from l *) - let sign,ccl = decompose_lam_n_decls (List.length l) c in - noccur_between 1 (Context.Rel.length sign) ccl + let sign,ccl = decompose_lam_n_decls sigma (List.length l) c in + noccur_between sigma 1 (Context.Rel.length sign) ccl with e when CErrors.noncritical e -> (* Not eta-expanded or not reduced *) false @@ -441,7 +442,7 @@ let detype_instance sigma l = else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) let rec detype flags avoid env sigma t = - match kind_of_term (EConstr.Unsafe.to_constr (collapse_appl sigma (EConstr.of_constr t))) with + match EConstr.kind sigma (collapse_appl sigma t) with | Rel n -> (try match lookup_name_of_rel n (fst env) with | Name id -> GVar (dl, id) @@ -503,11 +504,11 @@ let rec detype flags avoid env sigma t = try let pb = Environ.lookup_projection p (snd env) in let body = pb.Declarations.proj_body in - let ty = Retyping.get_type_of (snd env) sigma (EConstr.of_constr c) in + let ty = Retyping.get_type_of (snd env) sigma c in let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in - let args = List.map EConstr.Unsafe.to_constr args in let body' = strip_lam_assum body in - let body' = subst_instance_constr u body' in + let body' = CVars.subst_instance_constr u body' in + let body' = EConstr.of_constr body' in substl (c :: List.rev args) body' with Retyping.RetypeError _ | Not_found -> anomaly (str"Cannot detype an unfolded primitive projection.") @@ -515,8 +516,7 @@ let rec detype flags avoid env sigma t = else if print_primproj_params () then try - let c = Retyping.expand_projection (snd env) sigma p (EConstr.of_constr c) [] in - let c = EConstr.Unsafe.to_constr c in + let c = Retyping.expand_projection (snd env) sigma p c [] in detype flags avoid env sigma c with Retyping.RetypeError _ -> noparams () else noparams () @@ -527,8 +527,8 @@ let rec detype flags avoid env sigma t = | LocalDef _ -> true | LocalAssum (id,_) -> try let n = List.index Name.equal (Name id) (fst env) in - isRelN n c - with Not_found -> isVarId id c + isRelN sigma n c + with Not_found -> isVarId sigma id c in let id,l = try @@ -537,8 +537,8 @@ let rec detype flags avoid env sigma t = | Some id -> id in let l = Evd.evar_instance_array bound_to_itself_or_letin (Evd.find sigma evk) cl in - let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match kind_of_term c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in - let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel c && Int.Set.mem (destRel c) rels || isVar c && (Id.Set.mem (destVar c) fvs)))) (Evd.find sigma evk) cl in + let fvs,rels = List.fold_left (fun (fvs,rels) (_,c) -> match EConstr.kind sigma c with Rel n -> (fvs,Int.Set.add n rels) | Var id -> (Id.Set.add id fvs,rels) | _ -> (fvs,rels)) (Id.Set.empty,Int.Set.empty) l in + let l = Evd.evar_instance_array (fun d c -> not !print_evar_arguments && (bound_to_itself_or_letin d c && not (isRel sigma c && Int.Set.mem (destRel sigma c) rels || isVar sigma c && (Id.Set.mem (destVar sigma c) fvs)))) (Evd.find sigma evk) cl in id,l with Not_found -> Id.of_string ("X" ^ string_of_int (Evar.repr evk)), @@ -551,10 +551,10 @@ let rec detype flags avoid env sigma t = | Construct (cstr_sp,u) -> GRef (dl, ConstructRef cstr_sp, detype_instance sigma u) | Case (ci,p,c,bl) -> - let comp = computable p (List.length (ci.ci_pp_info.ind_tags)) in + let comp = computable sigma p (List.length (ci.ci_pp_info.ind_tags)) in detype_case comp (detype flags avoid env sigma) (detype_eqns flags avoid env sigma ci comp) - is_nondep_branch avoid + (is_nondep_branch sigma) avoid (ci.ci_ind,ci.ci_pp_info.style, ci.ci_pp_info.cstr_tags,ci.ci_pp_info.ind_tags) (Some p) c bl @@ -594,7 +594,7 @@ and detype_cofix flags avoid env sigma n (names,tys,bodies) = Array.map (fun (_,bd,_) -> bd) v) and share_names flags n l avoid env sigma c t = - match kind_of_term c, kind_of_term t with + match EConstr.kind sigma c, EConstr.kind sigma t with (* factorize even when not necessary to have better presentation *) | Lambda (na,t,c), Prod (na',t',c') -> let na = match (na,na') with @@ -641,15 +641,15 @@ and detype_eqns flags avoid env sigma ci computable constructs consnargsl bl = and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs branch = let make_pat x avoid env b body ty ids = - if force_wildcard () && noccurn 1 b then + if force_wildcard () && noccurn sigma 1 b then PatVar (dl,Anonymous),avoid,(add_name Anonymous body ty env),ids else let flag = if isgoal then RenamingForGoal else RenamingForCasesPattern (fst env,b) in - let na,avoid' = compute_displayed_name_in flag avoid x b in + let na,avoid' = compute_displayed_name_in sigma flag avoid x b in PatVar (dl,na),avoid',(add_name na body ty env),add_vname ids na in let rec buildrec ids patlist avoid env l b = - match kind_of_term b, l with + match EConstr.kind sigma b, l with | _, [] -> (dl, Id.Set.elements ids, [PatCstr(dl, constr, List.rev patlist,Anonymous)], @@ -684,8 +684,8 @@ and detype_eqn (lax,isgoal as flags) avoid env sigma constr construct_nargs bran and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = let flag = if isgoal then RenamingForGoal else RenamingElsewhereFor (fst env,c) in let na',avoid' = match bk with - | BLetIn -> compute_displayed_let_name_in flag avoid na c - | _ -> compute_displayed_name_in flag avoid na c in + | BLetIn -> compute_displayed_let_name_in sigma flag avoid na c + | _ -> compute_displayed_name_in sigma flag avoid na c in let r = detype flags avoid' (add_name na' body ty env) sigma c in match bk with | BProd -> GProd (dl, na',Explicit,detype (lax,false) avoid env sigma ty, r) @@ -693,13 +693,13 @@ and detype_binder (lax,isgoal as flags) bk avoid env sigma na body ty c = | BLetIn -> let c = detype (lax,false) avoid env sigma (Option.get body) in (* Heuristic: we display the type if in Prop *) - let s = try Retyping.get_sort_family_of (snd env) sigma (EConstr.of_constr ty) with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in + let s = try Retyping.get_sort_family_of (snd env) sigma ty with _ when !Flags.in_debugger || !Flags.in_toplevel -> InType (* Can fail because of sigma missing in debugger *) in let c = if s != InProp then c else GCast (dl, c, CastConv (detype (lax,false) avoid env sigma ty)) in GLetIn (dl, na', c, r) let detype_rel_context ?(lax=false) where avoid env sigma sign = - let where = Option.map (fun c -> it_mkLambda_or_LetIn c sign) where in + let where = Option.map (fun c -> EConstr.it_mkLambda_or_LetIn c sign) where in let rec aux avoid env = function | [] -> [] | decl::rest -> @@ -711,10 +711,10 @@ let detype_rel_context ?(lax=false) where avoid env sigma sign = | None -> na,avoid | Some c -> if is_local_def decl then - compute_displayed_let_name_in + compute_displayed_let_name_in sigma (RenamingElsewhereFor (fst env,c)) avoid na c else - compute_displayed_name_in + compute_displayed_name_in sigma (RenamingElsewhereFor (fst env,c)) avoid na c in let b = match decl with | LocalAssum _ -> None @@ -731,6 +731,7 @@ let detype ?(lax=false) isgoal avoid env sigma t = detype (lax,isgoal) avoid (names_of_rel_context env, env) sigma t let detype_closed_glob ?lax isgoal avoid env sigma t = + let open Context.Rel.Declaration in let convert_id cl id = try Id.Map.find id cl.idents with Not_found -> id @@ -748,12 +749,11 @@ let detype_closed_glob ?lax isgoal avoid env sigma t = with Not_found -> try (* assumes [detype] does not raise [Not_found] exceptions *) let (b,c) = Id.Map.find id cl.typed in - let c = EConstr.Unsafe.to_constr c in (* spiwack: I'm not sure it is the right thing to do, but I'm computing the detyping environment like [Printer.pr_constr_under_binders_env] does. *) - let assums = List.map (fun id -> (Name id,(* dummy *) mkProp)) b in - let env = Termops.push_rels_assum assums env in + let assums = List.map (fun id -> LocalAssum (Name id,(* dummy *) mkProp)) b in + let env = push_rel_context assums env in detype ?lax isgoal avoid env sigma c (* if [id] is bound to a [closed_glob_constr]. *) with Not_found -> try @@ -808,7 +808,7 @@ let rec subst_glob_constr subst raw = | GRef (loc,ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else - detype false [] (Global.env()) Evd.empty t + detype false [] (Global.env()) Evd.empty (EConstr.of_constr t) | GVar _ -> raw | GEvar _ -> raw diff --git a/pretyping/detyping.mli b/pretyping/detyping.mli index c51cb0f440..4c6f9129f6 100644 --- a/pretyping/detyping.mli +++ b/pretyping/detyping.mli @@ -9,6 +9,7 @@ open Names open Term open Environ +open EConstr open Glob_term open Termops open Mod_subst @@ -45,13 +46,13 @@ val detype_case : val detype_sort : evar_map -> sorts -> glob_sort val detype_rel_context : ?lax:bool -> constr option -> Id.t list -> (names_context * env) -> - evar_map -> Context.Rel.t -> glob_decl list + evar_map -> rel_context -> glob_decl list val detype_closed_glob : ?lax:bool -> bool -> Id.t list -> env -> evar_map -> closed_glob_constr -> glob_constr (** look for the index of a named var or a nondep var as it is renamed *) -val lookup_name_as_displayed : env -> constr -> Id.t -> int option -val lookup_index_as_renamed : env -> constr -> int -> int option +val lookup_name_as_displayed : env -> evar_map -> constr -> Id.t -> int option +val lookup_index_as_renamed : env -> evar_map -> constr -> int -> int option val set_detype_anonymous : (Loc.t -> int -> glob_constr) -> unit val force_wildcard : unit -> bool diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index faf34baf75..20d86f81b6 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -140,7 +140,7 @@ let define_pure_evar_as_lambda env evd evk = | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in let id = - next_name_away_with_default_using_types "x" na avoid (EConstr.Unsafe.to_constr (Reductionops.whd_evar evd dom)) in + next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in let newenv = push_named (LocalAssum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index 431d1ff166..c4a74d990b 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -40,6 +40,18 @@ type recursion_scheme_error = exception RecursionSchemeError of recursion_scheme_error +let named_hd env t na = named_hd env Evd.empty (EConstr.of_constr t) na +let name_assumption env = function +| LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) +| LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) + +let mkLambda_or_LetIn_name env d b = mkLambda_or_LetIn (name_assumption env d) b +let mkProd_or_LetIn_name env d b = mkProd_or_LetIn (name_assumption env d) b +let mkLambda_name env (n,a,b) = mkLambda_or_LetIn_name env (LocalAssum (n,a)) b +let mkProd_name env (n,a,b) = mkProd_or_LetIn_name env (LocalAssum (n,a)) b +let it_mkProd_or_LetIn_name env b l = List.fold_left (fun c d -> mkProd_or_LetIn_name env d c) b l +let it_mkLambda_or_LetIn_name env b l = List.fold_left (fun c d -> mkLambda_or_LetIn_name env d c) b l + let make_prod_dep dep env = if dep then mkProd_name env else mkProd let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) @@ -118,12 +130,13 @@ let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = it_mkLambda_or_LetIn_name env' obj deparsign else let cs = lift_constructor (k+1) constrs.(k) in - let t = build_branch_type env dep (mkRel (k+1)) cs in + let t = build_branch_type env (Sigma.to_evar_map sigma) dep (mkRel (k+1)) cs in mkLambda_string "f" t (add_branch (push_rel (LocalAssum (Anonymous, t)) env) (k+1)) in let Sigma (s, sigma, p) = Sigma.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env sigma kind in - let typP = make_arity env' dep indf s in + let typP = make_arity env' (Sigma.to_evar_map sigma) dep indf s in + let typP = EConstr.Unsafe.to_constr typP in let c = it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP @@ -443,7 +456,8 @@ let mis_make_indrec env sigma listdepkind mib u = Evarutil.evd_comb1 (Evd.fresh_sort_in_family ~rigid:Evd.univ_flexible_alg env) evdref kinds in - let typP = make_arity env dep indf s in + let typP = make_arity env !evdref dep indf s in + let typP = EConstr.Unsafe.to_constr typP in mkLambda_string "P" typP (put_arity (push_rel (LocalAssum (Anonymous,typP)) env) (i+1) rest) | [] -> diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 3191a58ff0..9e823ab4c5 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -422,26 +422,29 @@ let build_dependent_inductive env ((ind, params) as indf) = (* builds the arity of an elimination predicate in sort [s] *) -let make_arity_signature env dep indf = +let make_arity_signature env sigma dep indf = let (arsign,_) = get_arity env indf in + let arsign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) arsign in if dep then (* We need names everywhere *) - Namegen.name_context env - ((LocalAssum (Anonymous,build_dependent_inductive env indf))::arsign) + Namegen.name_context env sigma + ((LocalAssum (Anonymous,EConstr.of_constr (build_dependent_inductive env indf)))::arsign) (* Costly: would be better to name once for all at definition time *) else (* No need to enforce names *) arsign -let make_arity env dep indf s = mkArity (make_arity_signature env dep indf, s) +let make_arity env sigma dep indf s = + let open EConstr in + it_mkProd_or_LetIn (mkSort s) (make_arity_signature env sigma dep indf) (* [p] is the predicate and [cs] a constructor summary *) -let build_branch_type env dep p cs = +let build_branch_type env sigma dep p cs = let base = appvect (lift cs.cs_nargs p, cs.cs_concl_realargs) in if dep then - Namegen.it_mkProd_or_LetIn_name env - (applist (base,[build_dependent_constructor cs])) - cs.cs_args + EConstr.Unsafe.to_constr (Namegen.it_mkProd_or_LetIn_name env sigma + (EConstr.of_constr (applist (base,[build_dependent_constructor cs]))) + (List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) cs.cs_args)) else Term.it_mkProd_or_LetIn base cs.cs_args @@ -542,11 +545,12 @@ let is_elim_predicate_explicitly_dependent env sigma pred indf = let arsign,_ = get_arity env indf in is_predicate_explicitly_dep env sigma pred arsign -let set_names env n brty = - let (ctxt,cl) = decompose_prod_n_assum n brty in - Namegen.it_mkProd_or_LetIn_name env cl ctxt +let set_names env sigma n brty = + let open EConstr in + let (ctxt,cl) = decompose_prod_n_assum sigma n brty in + EConstr.Unsafe.to_constr (Namegen.it_mkProd_or_LetIn_name env sigma cl ctxt) -let set_pattern_names env ind brv = +let set_pattern_names env sigma ind brv = let (mib,mip) = Inductive.lookup_mind_specif env ind in let arities = Array.map @@ -554,7 +558,7 @@ let set_pattern_names env ind brv = Context.Rel.length ((prod_assum c)) - mib.mind_nparams) mip.mind_nf_lc in - Array.map2 (set_names env) arities brv + Array.map2 (set_names env sigma) arities brv let type_case_branches_with_names env sigma indspec p c = let (ind,args) = indspec in @@ -567,7 +571,7 @@ let type_case_branches_with_names env sigma indspec p c = let conclty = lambda_appvect_assum (mip.mind_nrealdecls+1) p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env sigma p (ind,params) then - (set_pattern_names env (fst ind) lbrty, conclty) + (set_pattern_names env sigma (fst ind) (Array.map EConstr.of_constr lbrty), conclty) else (lbrty, conclty) (* Type of Case predicates *) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 4bb4847591..ab470a540e 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -156,9 +156,9 @@ val get_arity : env -> inductive_family -> Context.Rel.t * sorts_family val build_dependent_constructor : constructor_summary -> constr val build_dependent_inductive : env -> inductive_family -> constr -val make_arity_signature : env -> bool -> inductive_family -> Context.Rel.t -val make_arity : env -> bool -> inductive_family -> sorts -> types -val build_branch_type : env -> bool -> constr -> constructor_summary -> types +val make_arity_signature : env -> evar_map -> bool -> inductive_family -> EConstr.rel_context +val make_arity : env -> evar_map -> bool -> inductive_family -> sorts -> EConstr.types +val build_branch_type : env -> evar_map -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given a valid inductive type *) val extract_mrectype : evar_map -> EConstr.t -> pinductive * EConstr.constr list diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 2470decdda..563769df54 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -79,26 +79,26 @@ type t = { (** Delay the computation of the evar extended environment *) } -let get_extra env = +let get_extra env sigma = let open Context.Named.Declaration in let ids = List.map get_id (named_context env) in let avoid = List.fold_right Id.Set.add ids Id.Set.empty in - Context.Rel.fold_outside push_rel_decl_to_named_context + Context.Rel.fold_outside (fun d acc -> push_rel_decl_to_named_context sigma d acc) (rel_context env) ~init:(empty_csubst, [], avoid, named_context env) -let make_env env = { env = env; extra = lazy (get_extra env) } +let make_env env sigma = { env = env; extra = lazy (get_extra env sigma) } let rel_context env = rel_context env.env -let push_rel d env = { +let push_rel sigma d env = { env = push_rel d env.env; - extra = lazy (push_rel_decl_to_named_context d (Lazy.force env.extra)); + extra = lazy (push_rel_decl_to_named_context sigma d (Lazy.force env.extra)); } -let pop_rel_context n env = make_env (pop_rel_context n env.env) +let pop_rel_context n env sigma = make_env (pop_rel_context n env.env) sigma -let push_rel_context ctx env = { +let push_rel_context sigma ctx env = { env = push_rel_context ctx env.env; - extra = lazy (List.fold_right push_rel_decl_to_named_context ctx (Lazy.force env.extra)); + extra = lazy (List.fold_right (fun d acc -> push_rel_decl_to_named_context sigma d acc) ctx (Lazy.force env.extra)); } let lookup_named id env = lookup_named id env.env @@ -117,9 +117,9 @@ let e_new_evar env evdref ?src ?naming typ = evdref := Sigma.to_evar_map sigma; e -let push_rec_types (lna,typarray,_) env = +let push_rec_types sigma (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> Context.Rel.Declaration.LocalAssum (na, lift i t)) lna typarray in - Array.fold_left (fun e assum -> push_rel assum e) env ctxt + Array.fold_left (fun e assum -> push_rel sigma assum e) env ctxt end @@ -391,7 +391,7 @@ let ltac_interp_name { ltac_idents ; ltac_genargs } = function str"It cannot be used in a binder.") else n -let ltac_interp_name_env k0 lvar env = +let ltac_interp_name_env k0 lvar env sigma = (* envhd is the initial part of the env when pretype was called first *) (* (in practice is is probably 0, but we have to grant the specification of pretype which accepts to start with a non empty @@ -402,7 +402,7 @@ let ltac_interp_name_env k0 lvar env = let open Context.Rel.Declaration in let ctxt' = List.smartmap (map_name (ltac_interp_name lvar)) ctxt in if List.equal (fun d1 d2 -> Name.equal (get_name d1) (get_name d2)) ctxt ctxt' then env - else push_rel_context ctxt' (pop_rel_context n env) + else push_rel_context sigma ctxt' (pop_rel_context n env sigma) let invert_ltac_bound_name lvar env id0 id = let id' = Id.Map.find id lvar.ltac_idents in @@ -426,7 +426,7 @@ let pretype_id pretype k0 loc env evdref lvar id = let (n,_,typ) = lookup_rel_id id (rel_context env) in { uj_val = mkRel n; uj_type = lift n typ } with Not_found -> - let env = ltac_interp_name_env k0 lvar env in + let env = ltac_interp_name_env k0 lvar env !evdref in (* Check if [id] is an ltac variable *) try let (ids,c) = Id.Map.find id lvar.ltac_constrs in @@ -569,7 +569,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> - let env = ltac_interp_name_env k0 lvar env in + let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty @@ -578,7 +578,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { uj_val = e_new_evar env evdref ~src:(loc,k) ty; uj_type = ty } | GHole (loc, k, naming, None) -> - let env = ltac_interp_name_env k0 lvar env in + let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty @@ -587,7 +587,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { uj_val = e_new_evar env evdref ~src:(loc,k) ~naming ty; uj_type = ty } | GHole (loc, k, _naming, Some arg) -> - let env = ltac_interp_name_env k0 lvar env in + let env = ltac_interp_name_env k0 lvar env !evdref in let ty = match tycon with | Some ty -> ty @@ -605,18 +605,18 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let ty' = pretype_type empty_valcon env evdref lvar ty in let dcl = LocalAssum (na, ty'.utj_val) in let dcl' = LocalAssum (ltac_interp_name lvar na,ty'.utj_val) in - type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl + type_bl (push_rel !evdref dcl env) (Context.Rel.add dcl' ctxt) bl | (na,bk,Some bd,ty)::bl -> let ty' = pretype_type empty_valcon env evdref lvar ty in let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar bd in let dcl = LocalDef (na, bd'.uj_val, ty'.utj_val) in let dcl' = LocalDef (ltac_interp_name lvar na, bd'.uj_val, ty'.utj_val) in - type_bl (push_rel dcl env) (Context.Rel.add dcl' ctxt) bl in + type_bl (push_rel !evdref dcl env) (Context.Rel.add dcl' ctxt) bl in let ctxtv = Array.map (type_bl env Context.Rel.empty) bl in let larj = Array.map2 (fun e ar -> - pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) + pretype_type empty_valcon (push_rel_context !evdref e env) evdref lvar ar) ctxtv lar in let lara = Array.map (fun a -> a.utj_val) larj in let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in @@ -632,7 +632,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | None -> true in (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = push_rec_types (names,ftys,[||]) env in + let newenv = push_rec_types !evdref (names,ftys,[||]) env in let vdefj = Array.map2_i (fun i ctxt def -> @@ -641,7 +641,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let (ctxt,ty) = decompose_prod_n_assum !evdref (Context.Rel.length ctxt) (lift nbfix ftys.(i)) in - let nenv = push_rel_context ctxt newenv in + let nenv = push_rel_context !evdref ctxt newenv in let j = pretype (mk_tycon ty) nenv evdref lvar def in { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) @@ -783,7 +783,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre the substitution must also be applied on variables before they are looked up in the rel context. *) let var = LocalAssum (name, j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in + let j' = pretype rng (push_rel !evdref var env) evdref lvar c2 in let name = ltac_interp_name lvar name in let resj = judge_of_abstraction env.ExtraEnv.env (orelse_name name name') j j' in inh_conv_coerce_to_tycon loc env evdref resj tycon @@ -799,7 +799,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre { j with utj_val = lift 1 j.utj_val } | Name _ -> let var = LocalAssum (name, j.utj_val) in - let env' = push_rel var env in + let env' = push_rel !evdref var env in pretype_type empty_valcon env' evdref lvar c2 in let name = ltac_interp_name lvar name in @@ -828,7 +828,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre looked up in the rel context. *) let var = LocalDef (name, j.uj_val, t) in let tycon = lift_tycon 1 tycon in - let j' = pretype tycon (push_rel var env) evdref lvar c2 in + let j' = pretype tycon (push_rel !evdref var env) evdref lvar c2 in let name = ltac_interp_name lvar name in { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; uj_type = subst1 j.uj_val j'.uj_type } @@ -877,7 +877,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre mkCase (ci, p, cj.uj_val,[|f|]) else it_mkLambda_or_LetIn f fsign in - let env_f = push_rel_context fsign env in + let env_f = push_rel_context !evdref fsign env in (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env.ExtraEnv.env indf in @@ -890,11 +890,10 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let nar = List.length arsgn in (match po with | Some p -> - let env_p = push_rel_context psign env in + let env_p = push_rel_context !evdref psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in - let psign = make_arity_signature env.ExtraEnv.env true indf in (* with names *) - let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in + let psign = make_arity_signature env.ExtraEnv.env !evdref true indf in (* with names *) let p = it_mkLambda_or_LetIn ccl psign in let inst = (Array.map_to_list EConstr.of_constr cs.cs_concl_realargs) @@ -951,7 +950,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let psign = List.map (fun d -> map_rel_decl EConstr.of_constr d) psign in let pred,p = match po with | Some p -> - let env_p = push_rel_context psign env in + let env_p = push_rel_context !evdref psign env in let pj = pretype_type empty_valcon env_p evdref lvar p in let ccl = nf_evar !evdref pj.utj_val in let pred = it_mkLambda_or_LetIn ccl psign in @@ -961,7 +960,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre let p = match tycon with | Some ty -> ty | None -> - let env = ltac_interp_name_env k0 lvar env in + let env = ltac_interp_name_env k0 lvar env !evdref in new_type_evar env evdref loc in it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in @@ -980,7 +979,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | Anonymous -> Name Namegen.default_non_dependent_ident)) cs_args in - let env_c = push_rel_context csgn env in + let env_c = push_rel_context !evdref csgn env in let bj = pretype (mk_tycon pi) env_c evdref lvar b in it_mkLambda_or_LetIn bj.uj_val cs_args in let b1 = f cstrs.(0) b1 in @@ -997,7 +996,7 @@ let rec pretype k0 resolve_tc (tycon : type_constraint) (env : ExtraEnv.t) evdre | GCases (loc,sty,po,tml,eqns) -> Cases.compile_cases loc sty - ((fun vtyc env evdref -> pretype vtyc (make_env env) evdref lvar),evdref) + ((fun vtyc env evdref -> pretype vtyc (make_env env !evdref) evdref lvar),evdref) tycon env.ExtraEnv.env (* loc *) (po,tml,eqns) | GCast (loc,c,k) -> @@ -1090,7 +1089,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function { utj_val = v; utj_type = s } | None -> - let env = ltac_interp_name_env k0 lvar env in + let env = ltac_interp_name_env k0 lvar env !evdref in let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar env evdref ~src:(loc, knd) ~naming (mkSort s); utj_type = s}) @@ -1107,7 +1106,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function ~loc:(loc_of_glob_constr c) env.ExtraEnv.env !evdref tj.utj_val v let ise_pretype_gen flags env sigma lvar kind c = - let env = make_env env in + let env = make_env env sigma in let evdref = ref sigma in let k0 = Context.Rel.length (rel_context env) in let c' = match kind with @@ -1150,7 +1149,7 @@ let on_judgment sigma f j = {uj_val = c; uj_type = t} let understand_judgment env sigma c = - let env = make_env env in + let env = make_env env sigma in let evdref = ref sigma in let k0 = Context.Rel.length (rel_context env) in let j = pretype k0 true empty_tycon env evdref empty_lvar c in @@ -1160,7 +1159,7 @@ let understand_judgment env sigma c = in j, Evd.evar_universe_context !evdref let understand_judgment_tcc env evdref c = - let env = make_env env in + let env = make_env env !evdref in let k0 = Context.Rel.length (rel_context env) in let j = pretype k0 true empty_tycon env evdref empty_lvar c in on_judgment !evdref (fun c -> @@ -1217,7 +1216,7 @@ let type_uconstr ?(flags = constr_flags) end } let pretype k0 resolve_tc typcon env evdref lvar t = - pretype k0 resolve_tc typcon (make_env env) evdref lvar t + pretype k0 resolve_tc typcon (make_env env !evdref) evdref lvar t let pretype_type k0 resolve_tc valcon env evdref lvar t = - pretype_type k0 resolve_tc valcon (make_env env) evdref lvar t + pretype_type k0 resolve_tc valcon (make_env env !evdref) evdref lvar t diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 9f3f3c7e5e..ef9f39d776 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1141,7 +1141,7 @@ let compute = cbv_betadeltaiota let abstract_scheme env sigma (locc,a) (c, sigma) = let ta = Retyping.get_type_of env sigma a in - let na = named_hd env (EConstr.to_constr sigma ta) Anonymous in + let na = named_hd env sigma ta Anonymous in if occur_meta sigma ta then error "Cannot find a type for the generalisation."; if occur_meta sigma a then mkLambda (na,ta,c), sigma diff --git a/pretyping/typing.ml b/pretyping/typing.ml index bdd3663d1a..dec22ecd00 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -92,8 +92,7 @@ let max_sort l = if Sorts.List.mem InSet l then InSet else InProp let e_is_correct_arity env evdref c pj ind specif params = - let arsign = make_arity_signature env true (make_ind_family (ind,params)) in - let arsign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) arsign in + let arsign = make_arity_signature env !evdref true (make_ind_family (ind,params)) in let allowed_sorts = elim_sorts specif in let error () = Pretype_errors.error_elim_arity env !evdref ind allowed_sorts c pj None in let rec srec env pt ar = diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 589201fe2e..baa12db08a 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -85,7 +85,7 @@ let occur_meta_evd sigma mv c = let abstract_scheme env evd c l lname_typ = let mkLambda_name env (n,a,b) = - mkLambda (named_hd env (EConstr.Unsafe.to_constr a) n, a, b) + mkLambda (named_hd env evd a n, a, b) in List.fold_left2 (fun (t,evd) (locc,a) decl -> @@ -1617,8 +1617,7 @@ let make_eq_test env evd c = let make_abstraction_core name (test,out) env sigma c ty occs check_occs concl = let id = let t = match ty with Some t -> t | None -> get_type_of env sigma c in - let t = EConstr.Unsafe.to_constr t in - let x = id_of_name_using_hdchar (Global.env()) t name in + let x = id_of_name_using_hdchar (Global.env()) sigma t name in let ids = ids_of_named_context (named_context env) in if name == Anonymous then next_ident_away_in_goal x ids else if mem_named_context_val x (named_context_val env) then -- cgit v1.2.3 From d629ec7cd920b19a063b7198d4e5b92d91a5656b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Dec 2016 18:14:45 +0100 Subject: Putting back the occur_meta_or_undefined_evar function in the old term API. This is another perfomance-critical function in unification. Putting it in the EConstr API was changing the heuristic, so better revert on that change. --- pretyping/unification.ml | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) (limited to 'pretyping') diff --git a/pretyping/unification.ml b/pretyping/unification.ml index baa12db08a..318a0b2cd8 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -65,10 +65,17 @@ let _ = Goptions.declare_bool_option { } let occur_meta_or_undefined_evar evd c = - let rec occrec c = match EConstr.kind evd c with + (** This is performance-critical. Using the evar-insensitive API changes the + resulting heuristic. *) + let c = EConstr.Unsafe.to_constr c in + let rec occrec c = match kind_of_term c with | Meta _ -> raise Occur - | Evar _ -> raise Occur - | _ -> EConstr.iter evd occrec c + | Evar (ev,args) -> + (match evar_body (Evd.find evd ev) with + | Evar_defined c -> + occrec c; Array.iter occrec args + | Evar_empty -> raise Occur) + | _ -> Constr.iter occrec c in try occrec c; false with Occur | Not_found -> true let occur_meta_evd sigma mv c = -- cgit v1.2.3 From aaf75678a13d9c26341e762ab8e56b957cf4c771 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 19 Dec 2016 01:30:45 +0100 Subject: Dedicated datatype for aliases in Evarsolve. --- pretyping/evarsolve.ml | 312 ++++++++++++++++++++++++++++------------------- pretyping/evarsolve.mli | 10 +- pretyping/unification.ml | 4 +- 3 files changed, 197 insertions(+), 129 deletions(-) (limited to 'pretyping') diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 28e63d04b9..398f2665e9 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -246,6 +246,47 @@ let noccur_evar env evd evk c = (* Managing chains of local definitons *) (***************************************) +type alias = +| RelAlias of int +| VarAlias of Id.t + +let of_alias = function +| RelAlias n -> mkRel n +| VarAlias id -> mkVar id + +let to_alias sigma c = match EConstr.kind sigma c with +| Rel n -> Some (RelAlias n) +| Var id -> Some (VarAlias id) +| _ -> None + +let is_alias sigma c alias = match EConstr.kind sigma c, alias with +| Var id, VarAlias id' -> Id.equal id id' +| Rel n, RelAlias n' -> Int.equal n n' +| _ -> false + +let eq_alias a b = match a, b with +| RelAlias n, RelAlias m -> Int.equal m n +| VarAlias id1, VarAlias id2 -> Id.equal id1 id2 +| _ -> false + +type aliasing = EConstr.t option * alias list + +let empty_aliasing = None, [] +let make_aliasing c = Some c, [] +let push_alias (alias, l) a = (alias, a :: l) +let lift_aliasing n (alias, l) = + let map a = match a with + | VarAlias _ -> a + | RelAlias m -> RelAlias (m + n) + in + (Option.map (fun c -> lift n c) alias, List.map map l) + +type aliases = { + rel_aliases : aliasing Int.Map.t; + var_aliases : aliasing Id.Map.t; + (** Only contains [VarAlias] *) +} + (* Expand rels and vars that are bound to other rels or vars so that dependencies in variables are canonically associated to the most ancient variable in its family of aliased variables *) @@ -259,10 +300,10 @@ let compute_var_aliases sign sigma = (match EConstr.kind sigma t with | Var id' -> let aliases_of_id = - try Id.Map.find id' aliases with Not_found -> [] in - Id.Map.add id (aliases_of_id@[t]) aliases + try Id.Map.find id' aliases with Not_found -> empty_aliasing in + Id.Map.add id (push_alias aliases_of_id (VarAlias id')) aliases | _ -> - Id.Map.add id [t] aliases) + Id.Map.add id (make_aliasing t) aliases) | LocalAssum _ -> aliases) sign Id.Map.empty @@ -275,14 +316,14 @@ let compute_rel_aliases var_aliases rels sigma = (match EConstr.kind sigma t with | Var id' -> let aliases_of_n = - try Id.Map.find id' var_aliases with Not_found -> [] in - Int.Map.add n (aliases_of_n@[t]) aliases + try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in + Int.Map.add n (push_alias aliases_of_n (VarAlias id')) aliases | Rel p -> let aliases_of_n = - try Int.Map.find (p+n) aliases with Not_found -> [] in - Int.Map.add n (aliases_of_n@[mkRel (p+n)]) aliases + try Int.Map.find (p+n) aliases with Not_found -> empty_aliasing in + Int.Map.add n (push_alias aliases_of_n (RelAlias (p+n))) aliases | _ -> - Int.Map.add n [lift n (mkCast(t,DEFAULTcast,u))] aliases) + Int.Map.add n (make_aliasing (lift n (mkCast(t,DEFAULTcast,u)))) aliases) | LocalAssum _ -> aliases) ) rels @@ -292,37 +333,43 @@ let make_alias_map env sigma = (* We compute the chain of aliases for each var and rel *) let var_aliases = compute_var_aliases (named_context env) sigma in let rel_aliases = compute_rel_aliases var_aliases (rel_context env) sigma in - (var_aliases,rel_aliases) + { var_aliases; rel_aliases } -let lift_aliases n (var_aliases,rel_aliases as aliases) = +let lift_aliases n aliases = if Int.equal n 0 then aliases else - (var_aliases, - Int.Map.fold (fun p l -> Int.Map.add (p+n) (List.map (lift n) l)) - rel_aliases Int.Map.empty) + let rel_aliases = + Int.Map.fold (fun p l -> Int.Map.add (p+n) (lift_aliasing n l)) + aliases.rel_aliases Int.Map.empty + in + { aliases with rel_aliases } -let get_alias_chain_of sigma aliases x = match EConstr.kind sigma x with - | Rel n -> (try Int.Map.find n (snd aliases) with Not_found -> []) - | Var id -> (try Id.Map.find id (fst aliases) with Not_found -> []) - | _ -> [] +let get_alias_chain_of sigma aliases x = match x with + | RelAlias n -> (try Int.Map.find n aliases.rel_aliases with Not_found -> empty_aliasing) + | VarAlias id -> (try Id.Map.find id aliases.var_aliases with Not_found -> empty_aliasing) -let normalize_alias_opt sigma aliases x = +let normalize_alias_opt_alias sigma aliases x = match get_alias_chain_of sigma aliases x with - | [] -> None - | a::_ when isRel sigma a || isVar sigma a -> Some a - | [_] -> None - | _::a::_ -> Some a + | _, [] -> None + | _, a :: _ -> Some a + +let normalize_alias_opt sigma aliases x = match to_alias sigma x with +| None -> None +| Some a -> normalize_alias_opt_alias sigma aliases a let normalize_alias sigma aliases x = - match normalize_alias_opt sigma aliases x with + match normalize_alias_opt_alias sigma aliases x with | Some a -> a | None -> x let normalize_alias_var sigma var_aliases id = - destVar sigma (normalize_alias sigma (var_aliases,Int.Map.empty) (mkVar id)) + let aliases = { var_aliases; rel_aliases = Int.Map.empty } in + match normalize_alias sigma aliases (VarAlias id) with + | VarAlias id -> id + | RelAlias _ -> assert false (** var only aliases to variables *) -let extend_alias sigma decl (var_aliases,rel_aliases) = +let extend_alias sigma decl { var_aliases; rel_aliases } = let rel_aliases = - Int.Map.fold (fun n l -> Int.Map.add (n+1) (List.map (lift 1) l)) + Int.Map.fold (fun n l -> Int.Map.add (n+1) (lift_aliasing 1 l)) rel_aliases Int.Map.empty in let rel_aliases = match decl with @@ -330,36 +377,36 @@ let extend_alias sigma decl (var_aliases,rel_aliases) = (match EConstr.kind sigma t with | Var id' -> let aliases_of_binder = - try Id.Map.find id' var_aliases with Not_found -> [] in - Int.Map.add 1 (aliases_of_binder@[t]) rel_aliases + try Id.Map.find id' var_aliases with Not_found -> empty_aliasing in + Int.Map.add 1 (push_alias aliases_of_binder (VarAlias id')) rel_aliases | Rel p -> let aliases_of_binder = - try Int.Map.find (p+1) rel_aliases with Not_found -> [] in - Int.Map.add 1 (aliases_of_binder@[mkRel (p+1)]) rel_aliases + try Int.Map.find (p+1) rel_aliases with Not_found -> empty_aliasing in + Int.Map.add 1 (push_alias aliases_of_binder (RelAlias (p+1))) rel_aliases | _ -> - Int.Map.add 1 [lift 1 t] rel_aliases) + Int.Map.add 1 (make_aliasing (lift 1 t)) rel_aliases) | LocalAssum _ -> rel_aliases in - (var_aliases, rel_aliases) + { var_aliases; rel_aliases } let expand_alias_once sigma aliases x = match get_alias_chain_of sigma aliases x with - | [] -> None - | l -> Some (List.last l) + | None, [] -> None + | Some a, [] -> Some a + | _, l -> Some (of_alias (List.last l)) let expansions_of_var sigma aliases x = - match get_alias_chain_of sigma aliases x with - | [] -> [x] - | a::_ as l when isRel sigma a || isVar sigma a -> x :: List.rev l - | _::l -> x :: List.rev l + let (_, l) = get_alias_chain_of sigma aliases x in + x :: List.rev l let expansion_of_var sigma aliases x = match get_alias_chain_of sigma aliases x with - | [] -> x - | a::_ -> a + | None, [] -> (false, of_alias x) + | Some a, _ -> (true, a) + | None, a :: _ -> (true, of_alias a) let rec expand_vars_in_term_using sigma aliases t = match EConstr.kind sigma t with - | Rel _ | Var _ -> - normalize_alias sigma aliases t + | Rel n -> of_alias (normalize_alias sigma aliases (RelAlias n)) + | Var id -> of_alias (normalize_alias sigma aliases (VarAlias id)) | _ -> let self aliases c = expand_vars_in_term_using sigma aliases c in map_constr_with_full_binders sigma (extend_alias sigma) self aliases t @@ -371,24 +418,28 @@ let free_vars_and_rels_up_alias_expansion sigma aliases c = let acc3 = ref Int.Set.empty and acc4 = ref Id.Set.empty in let cache_rel = ref Int.Set.empty and cache_var = ref Id.Set.empty in let is_in_cache depth = function - | Rel n -> Int.Set.mem (n-depth) !cache_rel - | Var s -> Id.Set.mem s !cache_var - | _ -> false in + | RelAlias n -> Int.Set.mem (n-depth) !cache_rel + | VarAlias s -> Id.Set.mem s !cache_var + in let put_in_cache depth = function - | Rel n -> cache_rel := Int.Set.add (n-depth) !cache_rel - | Var s -> cache_var := Id.Set.add s !cache_var - | _ -> () in + | RelAlias n -> cache_rel := Int.Set.add (n-depth) !cache_rel + | VarAlias s -> cache_var := Id.Set.add s !cache_var + in let rec frec (aliases,depth) c = match EConstr.kind sigma c with | Rel _ | Var _ as ck -> + let ck = match ck with + | Rel n -> RelAlias n + | Var id -> VarAlias id + | _ -> assert false + in if is_in_cache depth ck then () else begin put_in_cache depth ck; - let c' = expansion_of_var sigma aliases c in - (if c != c' then (* expansion, hence a let-in *) (** FIXME *) - match EConstr.kind sigma c with - | Var id -> acc4 := Id.Set.add id !acc4 - | Rel n -> if n >= depth+1 then acc3 := Int.Set.add (n-depth) !acc3 - | _ -> ()); + let expanded, c' = expansion_of_var sigma aliases ck in + (if expanded then (* expansion, hence a let-in *) + match ck with + | VarAlias id -> acc4 := Id.Set.add id !acc4 + | RelAlias n -> if n >= depth+1 then acc3 := Int.Set.add (n-depth) !acc3); match EConstr.kind sigma c' with | Var id -> acc2 := Id.Set.add id !acc2 | Rel n -> if n >= depth+1 then acc1 := Int.Set.add (n-depth) !acc1 @@ -407,30 +458,33 @@ let free_vars_and_rels_up_alias_expansion sigma aliases c = (* Managing pattern-unification *) (********************************) -let rec expand_and_check_vars sigma aliases = function +let map_all f l = + let rec map_aux f l = match l with | [] -> [] - | a::l when isRel sigma a || isVar sigma a -> - let a = expansion_of_var sigma aliases a in - if isRel sigma a || isVar sigma a then a :: expand_and_check_vars sigma aliases l - else raise Exit - | _ -> - raise Exit - -module Constrhash = Hashtbl.Make - (struct type t = Constr.constr - let equal = Term.eq_constr - let hash = hash_constr - end) - -let constr_list_distinct sigma l = - let visited = Constrhash.create 23 in - let rec loop = function - | h::t -> - let h = EConstr.to_constr sigma h in - if Constrhash.mem visited h then false - else (Constrhash.add visited h h; loop t) - | [] -> true - in loop l + | x :: l -> + match f x with + | None -> raise Exit + | Some y -> y :: map_aux f l + in + try Some (map_aux f l) with Exit -> None + +let expand_and_check_vars sigma aliases l = + let map a = match get_alias_chain_of sigma aliases a with + | None, [] -> Some a + | None, a :: _ -> Some a + | Some _, _ -> None + in + map_all map l + +let alias_distinct l = + let rec check (rels, vars) = function + | [] -> true + | RelAlias n :: l -> + not (Int.Set.mem n rels) && check (Int.Set.add n rels, vars) l + | VarAlias id :: l -> + not (Id.Set.mem id vars) && check (rels, Id.Set.add id vars) l + in + check (Int.Set.empty, Id.Set.empty) l let get_actual_deps evd aliases l t = if occur_meta_or_existential evd t then @@ -439,11 +493,10 @@ let get_actual_deps evd aliases l t = else (* Probably strong restrictions coming from t being evar-closed *) let (fv_rels,fv_ids,_,_) = free_vars_and_rels_up_alias_expansion evd aliases t in - List.filter (fun c -> - match EConstr.kind evd c with - | Var id -> Id.Set.mem id fv_ids - | Rel n -> Int.Set.mem n fv_rels - | _ -> assert false) l + List.filter (function + | VarAlias id -> Id.Set.mem id fv_ids + | RelAlias n -> Int.Set.mem n fv_rels + ) l open Context.Named.Declaration let remove_instance_local_defs evd evk args = @@ -463,34 +516,41 @@ let remove_instance_local_defs evd evk args = (* Check if an applied evar "?X[args] l" is a Miller's pattern *) let find_unification_pattern_args env evd l t = - if List.for_all (fun x -> isRel evd x || isVar evd x) l (* common failure case *) then - let aliases = make_alias_map env evd in - match (try Some (expand_and_check_vars evd aliases l) with Exit -> None) with - | Some l as x when constr_list_distinct evd (get_actual_deps evd aliases l t) -> x - | _ -> None - else - None + let aliases = make_alias_map env evd in + match expand_and_check_vars evd aliases l with + | Some l as x when alias_distinct (get_actual_deps evd aliases l t) -> x + | _ -> None let is_unification_pattern_meta env evd nb m l t = (* Variables from context and rels > nb are implicitly all there *) (* so we need to be a rel <= nb *) - if List.for_all (fun x -> isRel evd x && destRel evd x <= nb) l then - match find_unification_pattern_args env evd l t with + let map a = match EConstr.kind evd a with + | Rel n -> if n <= nb then Some (RelAlias n) else None + | _ -> None + in + match map_all map l with + | Some l -> + begin match find_unification_pattern_args env evd l t with | Some _ as x when not (dependent evd (mkMeta m) t) -> x | _ -> None - else + end + | None -> None let is_unification_pattern_evar env evd (evk,args) l t = - if List.for_all (fun x -> isRel evd x || isVar evd x) l - && noccur_evar env evd evk t - then + match map_all (fun c -> to_alias evd c) l with + | Some l when noccur_evar env evd evk t -> let args = remove_instance_local_defs evd evk args in + let args = map_all (fun c -> to_alias evd c) args in + begin match args with + | None -> None + | Some args -> let n = List.length args in match find_unification_pattern_args env evd (args @ l) t with | Some l -> Some (List.skipn n l) | _ -> None - else None + end + | _ -> None let is_unification_pattern_pure_evar env evd (evk,args) t = let is_ev = is_unification_pattern_evar env evd (evk,args) [] t in @@ -513,16 +573,16 @@ let is_unification_pattern (env,nb) evd f l t = return \y. ?1{x\y} (non constant function if ?1 depends on x) (BB) *) let solve_pattern_eqn env sigma l c = let c' = List.fold_right (fun a c -> - let c' = subst_term sigma (lift 1 a) (lift 1 c) in - match EConstr.kind sigma a with + let c' = subst_term sigma (lift 1 (of_alias a)) (lift 1 c) in + match a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) - | Rel n -> + | RelAlias n -> let open Context.Rel.Declaration in let d = map_constr (lift n) (lookup_rel n env) in mkLambda_or_LetIn d c' - | Var id -> + | VarAlias id -> let d = lookup_named id env in mkNamedLambda_or_LetIn d c' - | _ -> assert false) + ) l c in (* Warning: we may miss some opportunity to eta-reduce more since c' is not in normal form *) @@ -731,15 +791,15 @@ exception NotUniqueInType of (Id.t * evar_projection) list let rec assoc_up_to_alias sigma aliases y yc = function | [] -> raise Not_found | (c,cc,id)::l -> - if EConstr.eq_constr sigma y c then id + if is_alias sigma c y then id else match l with | _ :: _ -> assoc_up_to_alias sigma aliases y yc l | [] -> (* Last chance, we reason up to alias conversion *) match (normalize_alias_opt sigma aliases c) with - | Some cc when EConstr.eq_constr sigma yc cc -> id - | _ -> if EConstr.eq_constr sigma yc c then id else raise Not_found + | Some cc when eq_alias yc cc -> id + | _ -> if is_alias sigma c yc then id else raise Not_found let rec find_projectable_vars with_evars aliases sigma y subst = let yc = normalize_alias sigma aliases y in @@ -852,8 +912,8 @@ let invert_arg_from_subst evd aliases k0 subst_in_env_extended_with_k_binders c_ let effects = ref [] in let rec aux k t = match EConstr.kind evd t with - | Rel i when i>k0+k -> aux' k (mkRel (i-k)) - | Var id -> aux' k t + | Rel i when i>k0+k -> aux' k (RelAlias (i-k)) + | Var id -> aux' k (VarAlias id) | _ -> map_with_binders evd succ aux k t and aux' k t = try project_with_effects aliases evd effects t subst_in_env_extended_with_k_binders @@ -1113,22 +1173,24 @@ let rec is_constrainable_in top evd k (ev,(fv_rels,fv_ids) as g) t = | _ -> (* We don't try to be more clever *) true let has_constrainable_free_vars env evd aliases force k ev (fv_rels,fv_ids,let_rels,let_ids) t = - let t' = expansion_of_var evd aliases t in - if t' != t then + match to_alias evd t with + | Some t -> + let expanded, t' = expansion_of_var evd aliases t in + if expanded then (* t is a local definition, we keep it only if appears in the list *) (* of let-in variables effectively occurring on the right-hand side, *) (* which is the only reason to keep it when inverting arguments *) - match EConstr.kind evd t with - | Var id -> Id.Set.mem id let_ids - | Rel n -> Int.Set.mem n let_rels - | _ -> assert false - else + match t with + | VarAlias id -> Id.Set.mem id let_ids + | RelAlias n -> Int.Set.mem n let_rels + else begin match t with + | VarAlias id -> Id.Set.mem id fv_ids + | RelAlias n -> n <= k || Int.Set.mem n fv_rels + end + | None -> (* t is an instance for a proper variable; we filter it along *) (* the free variables allowed to occur *) - match EConstr.kind evd t with - | Var id -> Id.Set.mem id fv_ids - | Rel n -> n <= k || Int.Set.mem n fv_rels - | _ -> (not force || noccur_evar env evd ev t) && is_constrainable_in true evd k (ev,(fv_rels,fv_ids)) t + (not force || noccur_evar env evd ev t) && is_constrainable_in true evd k (ev,(fv_rels,fv_ids)) t exception EvarSolvedOnTheFly of evar_map * EConstr.constr @@ -1380,12 +1442,12 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | (id,p)::_::_ -> if choose then (mkVar id, p) else raise (NotUniqueInType sols) in - let ty = lazy (Retyping.get_type_of env !evdref t) in + let ty = lazy (Retyping.get_type_of env !evdref (of_alias t)) in let evd = do_projection_effects (evar_define conv_algo ~choose) env ty !evdref p in evdref := evd; c with - | Not_found -> raise (NotInvertibleUsingOurAlgorithm t) + | Not_found -> raise (NotInvertibleUsingOurAlgorithm (of_alias t)) | NotUniqueInType sols -> if not !progress then raise (NotEnoughInformationToProgress sols); @@ -1396,14 +1458,14 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let (evd,evar,(evk',argsv' as ev')) = materialize_evar (evar_define conv_algo ~choose) env !evdref 0 ev ty' in let ts = expansions_of_var evd aliases t in - let test c = isEvar evd c || List.mem_f (EConstr.eq_constr evd) c ts in + let test c = isEvar evd c || List.exists (is_alias evd c) ts in let filter = restrict_upon_filter evd evk test argsv' in let filter = closure_of_filter evd evk' filter in let candidates = extract_candidates sols in let evd = match candidates with | NoUpdate -> let evd, ev'' = restrict_applied_evar evd ev' filter NoUpdate in - add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',t) evd + add_conv_oriented_pb ~tail:false (None,env,mkEvar ev'',of_alias t) evd | UpdateWith _ -> restrict_evar evd evk' filter candidates in @@ -1415,15 +1477,15 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = | Rel i when i>k -> let open Context.Rel.Declaration in (match Environ.lookup_rel (i-k) env' with - | LocalAssum _ -> project_variable (mkRel (i-k)) + | LocalAssum _ -> project_variable (RelAlias (i-k)) | LocalDef (_,b,_) -> - try project_variable (mkRel (i-k)) + try project_variable (RelAlias (i-k)) with NotInvertibleUsingOurAlgorithm _ -> imitate envk (lift i (EConstr.of_constr b))) | Var id -> (match Environ.lookup_named id env' with - | LocalAssum _ -> project_variable t + | LocalAssum _ -> project_variable (VarAlias id) | LocalDef (_,b,_) -> - try project_variable t + try project_variable (VarAlias id) with NotInvertibleUsingOurAlgorithm _ -> imitate envk (EConstr.of_constr b)) | LetIn (na,b,u,c) -> imitate envk (subst1 b c) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index f2102f8cd1..b827a0ca49 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -11,6 +11,10 @@ open EConstr open Evd open Environ +type alias + +val of_alias : alias -> EConstr.t + type unification_result = | Success of evar_map | UnifFailure of evar_map * Pretype_errors.unification_error @@ -58,12 +62,12 @@ val solve_simple_eqn : conv_fun -> ?choose:bool -> env -> evar_map -> val reconsider_conv_pbs : conv_fun -> evar_map -> unification_result val is_unification_pattern_evar : env -> evar_map -> existential -> constr list -> - constr -> constr list option + constr -> alias list option val is_unification_pattern : env * int -> evar_map -> constr -> constr list -> - constr -> constr list option + constr -> alias list option -val solve_pattern_eqn : env -> evar_map -> constr list -> constr -> constr +val solve_pattern_eqn : env -> evar_map -> alias list -> constr -> constr val noccur_evar : env -> evar_map -> Evar.t -> constr -> bool diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 318a0b2cd8..336b3348cd 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -206,7 +206,9 @@ let solve_pattern_eqn_array (env,nb) f l c (sigma,metasubst,evarsubst : subst0) let pb = (Conv,TypeNotProcessed) in if noccur_between sigma 1 nb c then sigma,(k,lift (-nb) c,pb)::metasubst,evarsubst - else error_cannot_unify_local env sigma (applist (f, l),c,c) + else + let l = List.map of_alias l in + error_cannot_unify_local env sigma (applist (f, l),c,c) | Evar ev -> let env' = pop_rel_context nb env in let sigma,c = pose_all_metas_as_evars env' sigma c in -- cgit v1.2.3 From 5db9588098f9f02d923c21f3914e3c671b10728f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 24 Jan 2017 13:07:11 +0100 Subject: Quick hack to fix interpretation of patterns in Ltac. Interpretation of patterns in Ltac is essentially flawed. It does a roundtrip through the pretyper, and relies on suspicious flagging of evars in the evar source field to recognize original pattern holes. After the pattern_of_constr function was made evar-insensitive, it expanded evars that were solved by magical side-effects of the pretyper, even if it hadn't been asked to perform any heuristics. We backtrack on the insensitivity of the pattern_of_constr function. This may have a performance penalty in other dubious code, e.g. hints. In the long run we should get rid of the pattern_of_constr function. --- pretyping/patternops.ml | 24 +++++++----------------- pretyping/patternops.mli | 2 +- 2 files changed, 8 insertions(+), 18 deletions(-) (limited to 'pretyping') diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 954aa6a94c..823071e293 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -122,10 +122,9 @@ let head_of_constr_reference sigma c = match EConstr.kind sigma c with | _ -> anomaly (Pp.str "Not a rigid reference") let pattern_of_constr env sigma t = - let open EConstr in let rec pattern_of_constr env t = let open Context.Rel.Declaration in - match EConstr.kind sigma t with + match kind_of_term t with | Rel n -> PRel n | Meta n -> PMeta (Some (Id.of_string ("META" ^ string_of_int n))) | Var id -> PVar id @@ -141,7 +140,7 @@ let pattern_of_constr env sigma t = pattern_of_constr (push_rel (LocalAssum (na, c)) env) b) | App (f,a) -> (match - match EConstr.kind sigma f with + match kind_of_term f with | Evar (evk,args) -> (match snd (Evd.evar_source evk sigma) with Evar_kinds.MatchingVar (true,id) -> Some id @@ -154,18 +153,14 @@ let pattern_of_constr env sigma t = | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) | Proj (p, c) -> - pattern_of_constr env (Retyping.expand_projection env sigma p c []) + pattern_of_constr env (EConstr.to_constr sigma (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> - let ty = existential_type sigma ev in - let () = ignore (pattern_of_constr env ty) in assert (not b); PMeta (Some id) | Evar_kinds.GoalEvar -> PEvar (evk,Array.map (pattern_of_constr env) ctxt) | _ -> - let ty = existential_type sigma ev in - let () = ignore (pattern_of_constr env ty) in PMeta None) | Case (ci,p,a,br) -> let cip = @@ -179,13 +174,8 @@ let pattern_of_constr env sigma t = in PCase (cip, pattern_of_constr env p, pattern_of_constr env a, Array.to_list (Array.mapi branch_of_constr br)) - | Fix (idx, (nas, cs, ts)) -> - let inj c = EConstr.to_constr sigma c in - PFix (idx, (nas, Array.map inj cs, Array.map inj ts)) - | CoFix (idx, (nas, cs, ts)) -> - let inj c = EConstr.to_constr sigma c in - PCoFix (idx, (nas, Array.map inj cs, Array.map inj ts)) - in + | Fix f -> PFix f + | CoFix f -> PCoFix f in pattern_of_constr env t (* To process patterns, we need a translation without typing at all. *) @@ -228,7 +218,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - pattern_of_constr env sigma c + pattern_of_constr env sigma (EConstr.to_constr sigma c) with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in @@ -253,7 +243,7 @@ let rec subst_pattern subst pat = | PRef ref -> let ref',t = subst_global subst ref in if ref' == ref then pat else - pattern_of_constr (Global.env()) Evd.empty (EConstr.of_constr t) + pattern_of_constr (Global.env()) Evd.empty t | PVar _ | PEvar _ | PRel _ -> pat diff --git a/pretyping/patternops.mli b/pretyping/patternops.mli index 93d2c859a9..5694d345c1 100644 --- a/pretyping/patternops.mli +++ b/pretyping/patternops.mli @@ -39,7 +39,7 @@ val head_of_constr_reference : Evd.evar_map -> constr -> global_reference a pattern; currently, no destructor (Cases, Fix, Cofix) and no existential variable are allowed in [c] *) -val pattern_of_constr : Environ.env -> Evd.evar_map -> constr -> constr_pattern +val pattern_of_constr : Environ.env -> Evd.evar_map -> Constr.constr -> constr_pattern (** [pattern_of_glob_constr l c] translates a term [c] with metavariables into a pattern; variables bound in [l] are replaced by the pattern to which they -- cgit v1.2.3 From 486acdd7b50d4fdc0956011b7b48dc6ba96dd4a8 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Fri, 24 Mar 2017 23:45:54 +0100 Subject: Fix interpretation of Ltac patterns episode 2. After 5db9588098f9f, some extra evar-normalization remained (compared to trunk) that would change the semantics e.g. of change bindings under Ltac match. This is just circumventing a fundamental flaw in the treatment of patterns. --- pretyping/patternops.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'pretyping') diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index 8c6b39b7e6..d6a7c5192f 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -153,7 +153,7 @@ let pattern_of_constr env sigma t = | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) | Proj (p, c) -> - pattern_of_constr env (EConstr.to_constr sigma (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) + pattern_of_constr env (EConstr.Unsafe.to_constr (Retyping.expand_projection env sigma p (EConstr.of_constr c) [])) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> @@ -218,7 +218,7 @@ let instantiate_pattern env sigma lvar c = ctx in let c = substl inst c in - pattern_of_constr env sigma (EConstr.to_constr sigma c) + pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) with Not_found (* List.index failed *) -> let vars = List.map_filter (function Name id -> Some id | _ -> None) vars in -- cgit v1.2.3 From dc8d8daf8850ff1a414ae36c860bc925d87eab01 Mon Sep 17 00:00:00 2001 From: Maxime Dénès Date: Tue, 28 Mar 2017 18:15:02 +0200 Subject: Revert to incorrect heuristic in apply. Was breaking e.g. fiat-crypto. --- pretyping/unification.ml | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) (limited to 'pretyping') diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 8824c06abd..611d165fe1 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -64,6 +64,18 @@ let _ = Goptions.declare_bool_option { Goptions.optwrite = (fun a -> debug_unification:=a); } +(** Making this unification algorithm correct w.r.t. the evar-map abstraction + breaks too much stuff. So we redefine incorrect functions here. *) + +let unsafe_occur_meta_or_existential c = + let c = EConstr.Unsafe.to_constr c in + let rec occrec c = match kind_of_term c with + | Evar _ -> raise Occur + | Meta _ -> raise Occur + | _ -> iter_constr occrec c + in try occrec c; false with Occur -> true + + let occur_meta_or_undefined_evar evd c = (** This is performance-critical. Using the evar-insensitive API changes the resulting heuristic. *) @@ -1880,7 +1892,7 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = else let allow_K = flags.allow_K_in_toplevel_higher_order_unification in let flags = - if occur_meta_or_existential evd op || !keyed_unification then + if unsafe_occur_meta_or_existential op || !keyed_unification then (* This is up to delta for subterms w/o metas ... *) flags else -- cgit v1.2.3 From ce029533a1f0fc6ac9e28d162350a64446522246 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 31 Mar 2017 23:05:17 +0200 Subject: Make the Constr.kind_of_term type parametric in sorts and universes. --- pretyping/reductionops.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'pretyping') diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 15ddeb15c0..18416b1424 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -232,7 +232,7 @@ type 'a miota_args = { val reducible_mind_case : evar_map -> constr -> bool val reduce_mind_case : evar_map -> constr miota_args -> constr -val find_conclusion : env -> evar_map -> constr -> (constr,constr) kind_of_term +val find_conclusion : env -> evar_map -> constr -> (constr, constr, Sorts.t, Univ.Instance.t) kind_of_term val is_arity : env -> evar_map -> constr -> bool val is_sort : env -> evar_map -> types -> bool -- cgit v1.2.3 From 3df2431a80f9817ce051334cb9c3b1f465bffb60 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 31 Mar 2017 23:20:25 +0200 Subject: Actually exporting delayed universes in the EConstr implementation. For now we only normalize sorts, and we leave instances for the next commit. --- pretyping/coercion.ml | 6 +++--- pretyping/constr_matching.ml | 13 ++++++++----- pretyping/detyping.ml | 2 +- pretyping/evarconv.ml | 3 +++ pretyping/evardefine.ml | 6 +++--- pretyping/evarsolve.ml | 9 +++++++-- pretyping/inductiveops.ml | 1 + pretyping/pretyping.ml | 8 ++++++-- pretyping/reductionops.mli | 6 +++--- pretyping/retyping.ml | 16 ++++++++++------ pretyping/typing.ml | 15 +++++++++------ pretyping/unification.ml | 2 ++ 12 files changed, 56 insertions(+), 31 deletions(-) (limited to 'pretyping') diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 8794f238bc..542db7fdfa 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -199,7 +199,7 @@ and coerce loc env evdref (x : EConstr.constr) (y : EConstr.constr) in match (EConstr.kind !evdref x, EConstr.kind !evdref y) with | Sort s, Sort s' -> - (match s, s' with + (match ESorts.kind !evdref s, ESorts.kind !evdref s' with | Prop x, Prop y when x == y -> None | Prop _, Type _ -> None | Type x, Type y when Univ.Universe.equal x y -> None (* false *) @@ -406,7 +406,7 @@ let inh_app_fun resolve_tc env evd j = let type_judgment env sigma j = match EConstr.kind sigma (whd_all env sigma j.uj_type) with - | Sort s -> {utj_val = j.uj_val; utj_type = s } + | Sort s -> {utj_val = j.uj_val; utj_type = ESorts.kind sigma s } | _ -> error_not_a_type env sigma j let inh_tosort_force loc env evd j = @@ -421,7 +421,7 @@ let inh_tosort_force loc env evd j = let inh_coerce_to_sort loc env evd j = let typ = whd_all env evd j.uj_type in match EConstr.kind evd typ with - | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = s }) + | Sort s -> (evd,{ utj_val = j.uj_val; utj_type = ESorts.kind evd s }) | Evar ev -> let (evd',s) = Evardefine.define_evar_as_sort env evd ev in (evd',{ utj_val = j.uj_val; utj_type = s }) diff --git a/pretyping/constr_matching.ml b/pretyping/constr_matching.ml index cad21543ba..30b83cf884 100644 --- a/pretyping/constr_matching.ml +++ b/pretyping/constr_matching.ml @@ -205,11 +205,14 @@ let matches_core env sigma convert allow_partial_app allow_bound_rels | PRel n1, Rel n2 when Int.equal n1 n2 -> subst - | PSort GProp, Sort (Prop Null) -> subst - - | PSort GSet, Sort (Prop Pos) -> subst - - | PSort (GType _), Sort (Type _) -> subst + | PSort ps, Sort s -> + + begin match ps, ESorts.kind sigma s with + | GProp, Prop Null -> subst + | GSet, Prop Pos -> subst + | GType _, Type _ -> subst + | _ -> raise PatternMatchingFailure + end | PApp (p, [||]), _ -> sorec ctx env subst p t diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 1adda14abe..84022f57f2 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -457,7 +457,7 @@ let rec detype flags avoid env sigma t = | Var id -> (try let _ = Global.lookup_named id in GRef (dl, VarRef id, None) with Not_found -> GVar (dl, id)) - | Sort s -> GSort (dl,detype_sort sigma s) + | Sort s -> GSort (dl,detype_sort sigma (ESorts.kind sigma s)) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> detype flags avoid env sigma c1 | Cast (c1,k,c2) -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 85cc8762ee..b6fa257691 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -150,6 +150,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = (Stack.append_app [|a;pop b|] Stack.empty) else raise Not_found | Sort s -> + let s = ESorts.kind sigma s in lookup_canonical_conversion (proji, Sort_cs (family_of_sort s)),[] | _ -> @@ -775,6 +776,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Sort s1, Sort s2 when app_empty -> (try + let s1 = ESorts.kind evd s1 in + let s2 = ESorts.kind evd s2 in let evd' = if pbty == CONV then Evd.set_eq_sort env evd s1 s2 diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index 20d86f81b6..c5ae684e3b 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -91,7 +91,7 @@ let define_pure_evar_as_product evd evk = let newenv = push_named (LocalAssum (id, dom)) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in - if is_prop_sort s then + if is_prop_sort (ESorts.kind evd1 s) then (* Impredicative product, conclusion must fall in [Prop]. *) new_evar_unsafe newenv evd1 concl ~src ~filter else @@ -102,7 +102,7 @@ let define_pure_evar_as_product evd evk = (Sigma.to_evar_map evd3, e) in let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in - let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in + let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) (ESorts.kind evd1 s) in evd3, rng in let prod = mkProd (Name id, dom, subst_var id rng) in @@ -174,7 +174,7 @@ let define_evar_as_sort env evd (ev,args) = let concl = Reductionops.whd_all (evar_env evi) evd (EConstr.of_constr evi.evar_concl) in let sort = destSort evd concl in let evd' = Evd.define ev (Constr.mkSort s) evd in - Evd.set_leq_sort env evd' (Type (Univ.super u)) sort, s + Evd.set_leq_sort env evd' (Type (Univ.super u)) (ESorts.kind evd' sort), s (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4d78d2eb0f..77086d046c 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -50,6 +50,7 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) let modified = ref false in (* direction: true for fresh universes lower than the existing ones *) let refresh_sort status ~direction s = + let s = ESorts.kind !evdref s in let s' = evd_comb0 (new_sort_variable status) evdref in let evd = if direction then set_leq_sort env !evdref s' s @@ -59,7 +60,9 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) in let rec refresh ~onlyalg status ~direction t = match EConstr.kind !evdref t with - | Sort (Type u as s) -> + | Sort s -> + begin match ESorts.kind !evdref s with + | Type u -> (match Univ.universe_level u with | None -> refresh_sort status ~direction s | Some l -> @@ -71,10 +74,12 @@ let refresh_universes ?(status=univ_rigid) ?(onlyalg=false) ?(refreshset=false) if onlyalg && alg then (evdref := Evd.make_flexible_variable !evdref false l; t) else t)) - | Sort (Prop Pos as s) when refreshset && not direction -> + | Prop Pos when refreshset && not direction -> (* Cannot make a universe "lower" than "Set", only refreshing when we want higher universes. *) refresh_sort status ~direction s + | _ -> t + end | Prod (na,u,v) -> mkProd (na, u, refresh ~onlyalg status ~direction v) | _ -> t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index d5967c4bfc..88c492f03d 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -617,6 +617,7 @@ let type_of_inductive_knowing_conclusion env sigma ((mib,mip),u) conclty = | RegularArity s -> sigma, EConstr.of_constr (subst_instance_constr u s.mind_user_arity) | TemplateArity ar -> let _,scl = splay_arity env sigma conclty in + let scl = EConstr.ESorts.kind sigma scl in let ctx = List.rev mip.mind_arity_ctxt in let evdref = ref sigma in let ctx = diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 846d8055aa..c673851c84 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -1071,7 +1071,11 @@ and pretype_instance k0 resolve_tc env evdref lvar loc hyps evk update = and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function | GHole (loc, knd, naming, None) -> let rec is_Type c = match EConstr.kind !evdref c with - | Sort (Type _) -> true + | Sort s -> + begin match ESorts.kind !evdref s with + | Type _ -> true + | Prop _ -> false + end | Cast (c, _, _) -> is_Type c | _ -> false in @@ -1081,7 +1085,7 @@ and pretype_type k0 resolve_tc valcon (env : ExtraEnv.t) evdref lvar = function let sigma = !evdref in let t = Retyping.get_type_of env.ExtraEnv.env sigma v in match EConstr.kind sigma (whd_all env.ExtraEnv.env sigma t) with - | Sort s -> s + | Sort s -> ESorts.kind sigma s | Evar ev when is_Type (existential_type sigma ev) -> evd_comb1 (define_evar_as_sort env.ExtraEnv.env) evdref ev | _ -> anomaly (Pp.str "Found a type constraint which is not a type") diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 18416b1424..01707b47a7 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -215,8 +215,8 @@ val hnf_lam_applist : env -> evar_map -> constr -> constr list -> constr val splay_prod : env -> evar_map -> constr -> (Name.t * constr) list * constr val splay_lam : env -> evar_map -> constr -> (Name.t * constr) list * constr -val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * sorts -val sort_of_arity : env -> evar_map -> constr -> sorts +val splay_arity : env -> evar_map -> constr -> (Name.t * constr) list * ESorts.t +val sort_of_arity : env -> evar_map -> constr -> ESorts.t val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : @@ -232,7 +232,7 @@ type 'a miota_args = { val reducible_mind_case : evar_map -> constr -> bool val reduce_mind_case : evar_map -> constr miota_args -> constr -val find_conclusion : env -> evar_map -> constr -> (constr, constr, Sorts.t, Univ.Instance.t) kind_of_term +val find_conclusion : env -> evar_map -> constr -> (constr, constr, ESorts.t, Univ.Instance.t) kind_of_term val is_arity : env -> evar_map -> constr -> bool val is_sort : env -> evar_map -> types -> bool diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index bb1b2901e5..9c9751af81 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -77,7 +77,7 @@ let sort_of_atomic_type env sigma ft args = let rec concl_of_arity env n ar args = match EConstr.kind sigma (whd_all env sigma ar), args with | Prod (na, t, b), h::l -> concl_of_arity (push_rel (LocalDef (na, lift n h, t)) env) (n + 1) b l - | Sort s, [] -> s + | Sort s, [] -> ESorts.kind sigma s | _ -> retype_error NotASort in concl_of_arity env 0 ft (Array.to_list args) @@ -87,9 +87,11 @@ let type_of_var env id = let decomp_sort env sigma t = match EConstr.kind sigma (whd_all env sigma t) with - | Sort s -> s + | Sort s -> ESorts.kind sigma s | _ -> retype_error NotASort +let destSort sigma s = ESorts.kind sigma (destSort sigma s) + let retype ?(polyprop=true) sigma = let rec type_of env cstr = match EConstr.kind sigma cstr with @@ -142,8 +144,11 @@ let retype ?(polyprop=true) sigma = and sort_of env t = match EConstr.kind sigma t with | Cast (c,_, s) when isSort sigma s -> destSort sigma s - | Sort (Prop c) -> type1_sort - | Sort (Type u) -> Type (Univ.super u) + | Sort s -> + begin match ESorts.kind sigma s with + | Prop _ -> type1_sort + | Type u -> Type (Univ.super u) + end | Prod (name,t,c2) -> (match (sort_of env t, sort_of (push_rel (LocalAssum (name,t)) env) c2) with | _, (Prop Null as s) -> s @@ -163,8 +168,7 @@ let retype ?(polyprop=true) sigma = and sort_family_of env t = match EConstr.kind sigma t with | Cast (c,_, s) when isSort sigma s -> family_of_sort (destSort sigma s) - | Sort (Prop c) -> InType - | Sort (Type u) -> InType + | Sort _ -> InType | Prod (name,t,c2) -> let s2 = sort_family_of (push_rel (LocalAssum (name,t)) env) c2 in if not (is_impredicative_set env) && diff --git a/pretyping/typing.ml b/pretyping/typing.ml index dec22ecd00..d9d64e7eb3 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -46,7 +46,7 @@ let inductive_type_knowing_parameters env sigma (ind,u) jl = let e_type_judgment env evdref j = match EConstr.kind !evdref (whd_all env !evdref j.uj_type) with - | Sort s -> {utj_val = j.uj_val; utj_type = s } + | Sort s -> {utj_val = j.uj_val; utj_type = ESorts.kind !evdref s } | Evar ev -> let (evd,s) = Evardefine.define_evar_as_sort env !evdref ev in evdref := evd; { utj_val = j.uj_val; utj_type = s } @@ -102,6 +102,7 @@ let e_is_correct_arity env evdref c pj ind specif params = if not (Evarconv.e_cumul env evdref a1 a1') then error (); srec (push_rel (LocalAssum (na1,a1)) env) t ar' | Sort s, [] -> + let s = ESorts.kind !evdref s in if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> @@ -161,7 +162,7 @@ let check_type_fixpoint loc env evdref lna lar vdefj = (* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in - let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in + let ksort = family_of_sort (ESorts.kind sigma (sort_of_arity env sigma pj.uj_type)) in let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then @@ -288,11 +289,13 @@ let rec execute env evdref cstr = check_cofix env !evdref cofix; make_judge (mkCoFix cofix) tys.(i) - | Sort (Prop c) -> - judge_of_prop_contents c - - | Sort (Type u) -> + | Sort s -> + begin match ESorts.kind !evdref s with + | Prop c -> + judge_of_prop_contents c + | Type u -> judge_of_type u + end | Proj (p, c) -> let cj = execute env evdref c in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 611d165fe1..035b0c2230 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -780,6 +780,8 @@ let rec unify_0_with_initial_metas (sigma,ms,es as subst : subst0) conv_at_top e else error_cannot_unify_local curenv sigma (m,n,cN) | Sort s1, Sort s2 -> (try + let s1 = ESorts.kind sigma s1 in + let s2 = ESorts.kind sigma s2 in let sigma' = if pb == CUMUL then Evd.set_leq_sort curenv sigma s1 s2 -- cgit v1.2.3 From 7babf0d42af11f5830bc157a671bd81b478a4f02 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 1 Apr 2017 02:36:16 +0200 Subject: Using delayed universe instances in EConstr. The transition has been done a bit brutally. I think we can still save a lot of useless normalizations here and there by providing the right API in EConstr. Nonetheless, this is a first step. --- pretyping/cases.ml | 5 +++-- pretyping/classops.ml | 9 +++++---- pretyping/classops.mli | 2 +- pretyping/detyping.ml | 2 ++ pretyping/evarconv.ml | 4 ++-- pretyping/inductiveops.ml | 4 +++- pretyping/inductiveops.mli | 10 +++++----- pretyping/reductionops.ml | 17 ++++++++++------- pretyping/reductionops.mli | 2 +- pretyping/retyping.ml | 30 +++++++++++++++++------------- pretyping/tacred.ml | 37 +++++++++++++++++++++---------------- pretyping/tacred.mli | 6 +++--- pretyping/typeclasses.ml | 1 + pretyping/typeclasses.mli | 4 ++-- pretyping/typing.ml | 33 ++++++++++++++++++++------------- pretyping/unification.ml | 1 + 16 files changed, 97 insertions(+), 70 deletions(-) (limited to 'pretyping') diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 38c1056668..c5cf74ccfb 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -279,6 +279,7 @@ let rec find_row_ind = function let inductive_template evdref env tmloc ind = let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in let arsign = inductive_alldecls_env env indu in + let indu = on_snd EInstance.make indu in let hole_source i = match tmloc with | Some loc -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) | None -> (Loc.ghost, Evar_kinds.TomatchTypeParameter (ind,i)) in @@ -1314,7 +1315,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let cur_alias = lift const_info.cs_nargs current in let ind = mkApp ( - applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), snd const_info.cs_cstr), + applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), EInstance.make (snd const_info.cs_cstr)), List.map (EConstr.of_constr %> lift const_info.cs_nargs) const_info.cs_params), Array.map EConstr.of_constr const_info.cs_concl_realargs) in Alias (initial,(aliasname,cur_alias,(ci,ind))) in @@ -2104,7 +2105,7 @@ let constr_of_pat env evdref arsign pat avoid = let args = List.rev args in let patargs = List.rev patargs in let pat' = PatCstr (l, cstr, patargs, alias) in - let cstr = mkConstructU ci.cs_cstr in + let cstr = mkConstructU (on_snd EInstance.make ci.cs_cstr) in let app = applist (cstr, List.map (lift (List.length sign)) params) in let app = applist (app, args) in let apptype = Retyping.get_type_of env ( !evdref) app in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 13310c44d5..632ba0d9cd 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -193,15 +193,16 @@ let coercion_exists coe = CoeTypMap.mem coe !coercion_tab (* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) let find_class_type sigma t = + let open EConstr in let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match EConstr.kind sigma t' with - | Var id -> CL_SECVAR id, Univ.Instance.empty, args + | Var id -> CL_SECVAR id, EInstance.empty, args | Const (sp,u) -> CL_CONST sp, u, args | Proj (p, c) when not (Projection.unfolded p) -> - CL_PROJ (Projection.constant p), Univ.Instance.empty, (c :: args) + CL_PROJ (Projection.constant p), EInstance.empty, (c :: args) | Ind (ind_sp,u) -> CL_IND ind_sp, u, args - | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, [] - | Sort _ -> CL_SORT, Univ.Instance.empty, [] + | Prod (_,_,_) -> CL_FUN, EInstance.empty, [] + | Sort _ -> CL_SORT, EInstance.empty, [] | _ -> raise Not_found diff --git a/pretyping/classops.mli b/pretyping/classops.mli index a1d030f125..0d741a5a5d 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -60,7 +60,7 @@ val class_info_from_index : cl_index -> cl_typ * cl_info_typ (** [find_class_type env sigma c] returns the head reference of [c], its universe instance and its arguments *) -val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list +val find_class_type : evar_map -> types -> cl_typ * EInstance.t * constr list (** raises [Not_found] if not convertible to a class *) val class_of : env -> evar_map -> types -> types * cl_index diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 84022f57f2..e4d7ab38d1 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -438,6 +438,7 @@ let detype_level sigma l = GType (Some (dl, Pp.string_of_ppcmds (Termops.pr_evd_level sigma l))) let detype_instance sigma l = + let l = EInstance.kind sigma l in if Univ.Instance.is_empty l then None else Some (List.map (detype_level sigma) (Array.to_list (Univ.Instance.to_array l))) @@ -507,6 +508,7 @@ let rec detype flags avoid env sigma t = let ty = Retyping.get_type_of (snd env) sigma c in let ((ind,u), args) = Inductiveops.find_mrectype (snd env) sigma ty in let body' = strip_lam_assum body in + let u = EInstance.kind sigma u in let body' = CVars.subst_instance_constr u body' in let body' = EConstr.of_constr body' in substl (c :: List.rev args) body' diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index b6fa257691..9c9350ab10 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -51,9 +51,9 @@ let unfold_projection env evd ts p c = let eval_flexible_term ts env evd c = match EConstr.kind evd c with - | Const (c,u as cu) -> + | Const (c, u) -> if is_transparent_constant ts c - then Option.map EConstr.of_constr (constant_opt_value_in env cu) + then Option.map EConstr.of_constr (constant_opt_value_in env (c, EInstance.kind evd u)) else None | Rel n -> (try match lookup_rel n env with diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 88c492f03d..5b42add285 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -74,6 +74,7 @@ let substnl_ind_type l n = map_inductive_type (EConstr.Vars.substnl l n) let mkAppliedInd (IndType ((ind,params), realargs)) = let open EConstr in + let ind = on_snd EInstance.make ind in applist (mkIndU ind, (List.map EConstr.of_constr params)@realargs) (* Does not consider imbricated or mutually recursive types *) @@ -471,11 +472,12 @@ let find_rectype env sigma c = let open EConstr in let (t, l) = decompose_app sigma (whd_all env sigma c) in match EConstr.kind sigma t with - | Ind (ind,u as indu) -> + | Ind (ind,u) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in if mib.mind_nparams > List.length l then raise Not_found; let l = List.map EConstr.Unsafe.to_constr l in let (par,rargs) = List.chop mib.mind_nparams l in + let indu = (ind, EInstance.kind sigma u) in IndType((indu, par),List.map EConstr.of_constr rargs) | _ -> raise Not_found diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index ab470a540e..bdb6f996b9 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -161,12 +161,12 @@ val make_arity : env -> evar_map -> bool -> inductive_family -> sorts -> EConstr val build_branch_type : env -> evar_map -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given a valid inductive type *) -val extract_mrectype : evar_map -> EConstr.t -> pinductive * EConstr.constr list -val find_mrectype : env -> evar_map -> EConstr.types -> pinductive * EConstr.constr list -val find_mrectype_vect : env -> evar_map -> EConstr.types -> pinductive * EConstr.constr array +val extract_mrectype : evar_map -> EConstr.t -> (inductive * EConstr.EInstance.t) * EConstr.constr list +val find_mrectype : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * EConstr.constr list +val find_mrectype_vect : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * EConstr.constr array val find_rectype : env -> evar_map -> EConstr.types -> inductive_type -val find_inductive : env -> evar_map -> EConstr.types -> pinductive * constr list -val find_coinductive : env -> evar_map -> EConstr.types -> pinductive * constr list +val find_inductive : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * constr list +val find_coinductive : env -> evar_map -> EConstr.types -> (inductive * EConstr.EInstance.t) * constr list (********************) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 8be3b8328f..2703205386 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -550,7 +550,7 @@ struct let constr_of_cst_member f sk = match f with - | Cst_const (c, u) -> mkConstU (c,u), sk + | Cst_const (c, u) -> mkConstU (c, EInstance.make u), sk | Cst_proj p -> match decomp sk with | Some (hd, sk) -> mkProj (p, hd), sk @@ -703,7 +703,7 @@ let magicaly_constant_of_fixbody env sigma reference bd = function csts Univ.LMap.empty in let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in - mkConstU (cst,inst) + mkConstU (cst, EInstance.make inst) | None -> bd end with @@ -856,7 +856,8 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | Some body -> whrec cst_l (EConstr.of_constr body, stack) | None -> fold ()) | Const (c,u as const) when CClosure.RedFlags.red_set flags (CClosure.RedFlags.fCONST c) -> - (match constant_opt_value_in env const with + let u' = EInstance.kind sigma u in + (match constant_opt_value_in env (fst const, u') with | None -> fold () | Some body -> let body = EConstr.of_constr body in @@ -895,7 +896,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = | None -> fold () | Some (bef,arg,s') -> whrec Cst_stack.empty - (arg,Stack.Cst(Stack.Cst_const const,curr,remains,bef,cst_l)::s') + (arg,Stack.Cst(Stack.Cst_const (fst const, u'),curr,remains,bef,cst_l)::s') ) | Proj (p, c) when CClosure.RedFlags.red_projection flags p -> (let pb = lookup_projection p env in @@ -998,6 +999,7 @@ let rec whd_state_gen ?csts ~refold ~tactic_mode flags env sigma = (match constant_opt_value_in env const with | None -> fold () | Some body -> + let const = (fst const, EInstance.make (snd const)) in let body = EConstr.of_constr body in whrec (if refold then Cst_stack.add_cst (mkConstU const) cst_l else cst_l) (body, s' @ (Stack.append_app [|x'|] s''))) @@ -1657,12 +1659,13 @@ let meta_reducible_instance evd b = let head_unfold_under_prod ts env sigma c = - let unfold (cst,u as cstu) = + let unfold (cst,u) = + let cstu = (cst, EInstance.kind sigma u) in if Cpred.mem cst (snd ts) then match constant_opt_value_in env cstu with | Some c -> EConstr.of_constr c - | None -> mkConstU cstu - else mkConstU cstu in + | None -> mkConstU (cst, u) + else mkConstU (cst, u) in let rec aux c = match EConstr.kind sigma c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 01707b47a7..752c30a8ac 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -232,7 +232,7 @@ type 'a miota_args = { val reducible_mind_case : evar_map -> constr -> bool val reduce_mind_case : evar_map -> constr miota_args -> constr -val find_conclusion : env -> evar_map -> constr -> (constr, constr, ESorts.t, Univ.Instance.t) kind_of_term +val find_conclusion : env -> evar_map -> constr -> (constr, constr, ESorts.t, EInstance.t) kind_of_term val is_arity : env -> evar_map -> constr -> bool val is_sort : env -> evar_map -> types -> bool diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index 9c9751af81..496c706ec6 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -102,10 +102,10 @@ let retype ?(polyprop=true) sigma = let ty = RelDecl.get_type (lookup_rel n env) in lift n ty | Var id -> type_of_var env id - | Const cst -> EConstr.of_constr (rename_type_of_constant env cst) + | Const (cst, u) -> EConstr.of_constr (rename_type_of_constant env (cst, EInstance.kind sigma u)) | Evar ev -> existential_type sigma ev - | Ind ind -> EConstr.of_constr (rename_type_of_inductive env ind) - | Construct cstr -> EConstr.of_constr (rename_type_of_constructor env cstr) + | Ind (ind, u) -> EConstr.of_constr (rename_type_of_inductive env (ind, EInstance.kind sigma u)) + | Construct (cstr, u) -> EConstr.of_constr (rename_type_of_constructor env (cstr, EInstance.kind sigma u)) | Case (_,p,c,lf) -> let Inductiveops.IndType(indf,realargs) = let t = type_of env c in @@ -186,16 +186,20 @@ let retype ?(polyprop=true) sigma = let argtyps = Array.map (fun c -> lazy (EConstr.to_constr sigma (type_of env c))) args in match EConstr.kind sigma c with - | Ind ind -> - let mip = lookup_mind_specif env (fst ind) in + | Ind (ind, u) -> + let u = EInstance.kind sigma u in + let mip = lookup_mind_specif env ind in EConstr.of_constr (try Inductive.type_of_inductive_knowing_parameters - ~polyprop env (mip,snd ind) argtyps + ~polyprop env (mip, u) argtyps with Reduction.NotArity -> retype_error NotAnArity) - | Const cst -> - EConstr.of_constr (try Typeops.type_of_constant_knowing_parameters_in env cst argtyps + | Const (cst, u) -> + let u = EInstance.kind sigma u in + EConstr.of_constr (try Typeops.type_of_constant_knowing_parameters_in env (cst, u) argtyps with Reduction.NotArity -> retype_error NotAnArity) | Var id -> type_of_var env id - | Construct cstr -> EConstr.of_constr (type_of_constructor env cstr) + | Construct (cstr, u) -> + let u = EInstance.kind sigma u in + EConstr.of_constr (type_of_constructor env (cstr, u)) | _ -> assert false in type_of, sort_of, sort_family_of, @@ -212,13 +216,13 @@ let type_of_global_reference_knowing_conclusion env sigma c conclty = match EConstr.kind sigma c with | Ind (ind,u) -> let spec = Inductive.lookup_mind_specif env ind in - type_of_inductive_knowing_conclusion env sigma (spec,u) conclty - | Const cst -> - let t = constant_type_in env cst in + type_of_inductive_knowing_conclusion env sigma (spec, EInstance.kind sigma u) conclty + | Const (cst, u) -> + let t = constant_type_in env (cst, EInstance.kind sigma u) in (* TODO *) sigma, EConstr.of_constr (Typeops.type_of_constant_type_knowing_parameters env t [||]) | Var id -> sigma, type_of_var env id - | Construct cstr -> sigma, EConstr.of_constr (type_of_constructor env cstr) + | Construct (cstr, u) -> sigma, EConstr.of_constr (type_of_constructor env (cstr, EInstance.kind sigma u)) | _ -> assert false (* Profiling *) diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index ef9f39d776..67221046bd 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -60,6 +60,7 @@ let is_evaluable env = function let value_of_evaluable_ref env evref u = match evref with | EvalConstRef con -> + let u = Unsafe.to_instance u in EConstr.of_constr (try constant_value_in env (con,u) with NotEvaluableConst IsProj -> raise (Invalid_argument "value_of_evaluable_ref")) @@ -103,9 +104,9 @@ let isEvalRef env sigma c = match EConstr.kind sigma c with let destEvalRefU sigma c = match EConstr.kind sigma c with | Const (cst,u) -> EvalConst cst, u - | Var id -> (EvalVar id, Univ.Instance.empty) - | Rel n -> (EvalRel n, Univ.Instance.empty) - | Evar ev -> (EvalEvar ev, Univ.Instance.empty) + | Var id -> (EvalVar id, EInstance.empty) + | Rel n -> (EvalRel n, EInstance.empty) + | Evar ev -> (EvalEvar ev, EInstance.empty) | _ -> anomaly (Pp.str "Not an unfoldable reference") let unsafe_reference_opt_value env sigma eval = @@ -125,7 +126,9 @@ let unsafe_reference_opt_value env sigma eval = let reference_opt_value env sigma eval u = match eval with - | EvalConst cst -> Option.map EConstr.of_constr (constant_opt_value_in env (cst,u)) + | EvalConst cst -> + let u = EInstance.kind sigma u in + Option.map EConstr.of_constr (constant_opt_value_in env (cst,u)) | EvalVar id -> env |> lookup_named id |> NamedDecl.get_value | EvalRel n -> @@ -519,13 +522,13 @@ let reduce_mind_case_use_function func env sigma mia = mutual inductive, try to reuse the global name if the block was indeed initially built as a global definition *) - let kn = map_puniverses (fun x -> con_with_label x (Label.of_id id)) - (destConst sigma func) - in - try match constant_opt_value_in env kn with + let (kn, u) = destConst sigma func in + let kn = con_with_label kn (Label.of_id id) in + let cst = (kn, EInstance.kind sigma u) in + try match constant_opt_value_in env cst with | None -> None (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConstU kn) + | Some _ -> Some (minargs,mkConstU (kn, u)) with Not_found -> None else fun _ -> None in @@ -539,14 +542,15 @@ let match_eval_ref env sigma constr = match EConstr.kind sigma constr with | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> Some (EvalConst sp, u) - | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty) - | Rel i -> Some (EvalRel i, Univ.Instance.empty) - | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty) + | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, EInstance.empty) + | Rel i -> Some (EvalRel i, EInstance.empty) + | Evar ev -> Some (EvalEvar ev, EInstance.empty) | _ -> None let match_eval_ref_value env sigma constr = match EConstr.kind sigma constr with | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + let u = EInstance.kind sigma u in Some (EConstr.of_constr (constant_value_in env (sp, u))) | Var id when is_evaluable env (EvalVarRef id) -> env |> lookup_named id |> NamedDecl.get_value @@ -628,8 +632,9 @@ let whd_nothing_for_iota env sigma s = | Meta ev -> (try whrec (EConstr.of_constr (Evd.meta_value sigma ev), stack) with Not_found -> s) - | Const const when is_transparent_constant full_transparent_state (fst const) -> - (match constant_opt_value_in env const with + | Const (const, u) when is_transparent_constant full_transparent_state const -> + let u = EInstance.kind sigma u in + (match constant_opt_value_in env (const, u) with | Some body -> whrec (EConstr.of_constr body, stack) | None -> s) | LetIn (_,b,_,c) -> stacklam whrec [b] sigma c stack @@ -955,7 +960,7 @@ let simpl env sigma c = strong whd_simpl env sigma c let matches_head env sigma c t = match EConstr.kind sigma t with | App (f,_) -> Constr_matching.matches env sigma c f - | Proj (p, _) -> Constr_matching.matches env sigma c (mkConstU (Projection.constant p, Univ.Instance.empty)) + | Proj (p, _) -> Constr_matching.matches env sigma c (mkConstU (Projection.constant p, EInstance.empty)) | _ -> raise Constr_matching.PatternMatchingFailure (** FIXME: Specific function to handle projections: it ignores what happens on the @@ -1039,7 +1044,7 @@ let contextually byhead occs f env sigma t = let match_constr_evaluable_ref sigma c evref = match EConstr.kind sigma c, evref with | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u - | Var id, EvalVarRef id' when id_eq id id' -> Some Univ.Instance.empty + | Var id, EvalVarRef id' when id_eq id id' -> Some EInstance.empty | _, _ -> None let substlin env sigma evalref n (nowhere_except_in,locs) c = diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index a4499015d2..76d0bc241f 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -76,12 +76,12 @@ val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> types -> pinductive * types +val reduce_to_atomic_ind : env -> evar_map -> types -> (inductive * EInstance.t) * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types +val reduce_to_quantified_ind : env -> evar_map -> types -> (inductive * EInstance.t) * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) @@ -92,7 +92,7 @@ val reduce_to_atomic_ref : env -> evar_map -> global_reference -> types -> types val find_hnf_rectype : - env -> evar_map -> types -> pinductive * constr list + env -> evar_map -> types -> (inductive * EInstance.t) * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 478499d91d..93c71e6ea9 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -303,6 +303,7 @@ let build_subclasses ~check env sigma glob { hint_priority = pri } = | Some (Forward, info) -> let proj = Option.get proj in let rels = List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) rels in + let u = EConstr.EInstance.kind sigma u in let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in if check && check_instance env sigma (EConstr.of_constr body) then None else diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 7990b12cdb..8d1c0b94ca 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -61,13 +61,13 @@ val class_info : global_reference -> typeclass (** raises a UserError if not a c (** These raise a UserError if not a class. Caution: the typeclass structures is not instantiated w.r.t. the universe instance. This is done separately by typeclass_univ_instance. *) -val dest_class_app : env -> evar_map -> EConstr.constr -> typeclass puniverses * constr list +val dest_class_app : env -> evar_map -> EConstr.constr -> (typeclass * EConstr.EInstance.t) * constr list (** Get the instantiated typeclass structure for a given universe instance. *) val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * (typeclass puniverses * constr list)) option +val class_of_constr : evar_map -> EConstr.constr -> (EConstr.rel_context * ((typeclass * EConstr.EInstance.t) * constr list)) option val instance_impl : instance -> global_reference diff --git a/pretyping/typing.ml b/pretyping/typing.ml index d9d64e7eb3..c2a030bcd2 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -35,11 +35,13 @@ let meta_type evd mv = let ty = Evd.map_fl EConstr.of_constr ty in meta_instance evd ty -let constant_type_knowing_parameters env sigma cst jl = +let constant_type_knowing_parameters env sigma (cst, u) jl = + let u = Unsafe.to_instance u in let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr sigma j.uj_type)) jl in - EConstr.of_constr (type_of_constant_knowing_parameters_in env cst paramstyp) + EConstr.of_constr (type_of_constant_knowing_parameters_in env (cst, u) paramstyp) let inductive_type_knowing_parameters env sigma (ind,u) jl = + let u = Unsafe.to_instance u in let mspec = lookup_mind_specif env ind in let paramstyp = Array.map (fun j -> lazy (EConstr.to_constr sigma j.uj_type)) jl in EConstr.of_constr (Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp) @@ -140,9 +142,10 @@ let e_type_case_branches env evdref (ind,largs) pj c = (lc, ty) let e_judge_of_case env evdref ci pj cj lfj = - let indspec = + let ((ind, u), spec) = try find_mrectype env !evdref cj.uj_type with Not_found -> error_case_not_inductive env !evdref cj in + let indspec = ((ind, EInstance.kind !evdref u), spec) in let _ = check_case_info env (fst indspec) ci in let (bty,rslty) = e_type_case_branches env evdref indspec pj cj.uj_val in e_check_branch_types env evdref (fst indspec) cj (lfj,bty); @@ -224,6 +227,7 @@ let judge_of_projection env sigma p cj = try find_mrectype env sigma cj.uj_type with Not_found -> error_case_not_inductive env sigma cj in + let u = EInstance.kind sigma u in let ty = EConstr.of_constr (CVars.subst_instance_constr u pb.Declarations.proj_type) in let ty = substl (cj.uj_val :: List.rev args) ty in {uj_val = EConstr.mkProj (p,cj.uj_val); @@ -262,14 +266,17 @@ let rec execute env evdref cstr = | Var id -> judge_of_variable env id - | Const c -> - make_judge cstr (EConstr.of_constr (rename_type_of_constant env c)) + | Const (c, u) -> + let u = EInstance.kind !evdref u in + make_judge cstr (EConstr.of_constr (rename_type_of_constant env (c, u))) - | Ind ind -> - make_judge cstr (EConstr.of_constr (rename_type_of_inductive env ind)) + | Ind (ind, u) -> + let u = EInstance.kind !evdref u in + make_judge cstr (EConstr.of_constr (rename_type_of_inductive env (ind, u))) - | Construct cstruct -> - make_judge cstr (EConstr.of_constr (rename_type_of_constructor env cstruct)) + | Construct (cstruct, u) -> + let u = EInstance.kind !evdref u in + make_judge cstr (EConstr.of_constr (rename_type_of_constructor env (cstruct, u))) | Case (ci,p,c,lf) -> let cj = execute env evdref c in @@ -305,14 +312,14 @@ let rec execute env evdref cstr = let jl = execute_array env evdref args in let j = match EConstr.kind !evdref f with - | Ind ind when Environ.template_polymorphic_pind ind env -> + | Ind (ind, u) when EInstance.is_empty u && Environ.template_polymorphic_ind ind env -> (* Sort-polymorphism of inductive types *) make_judge f - (inductive_type_knowing_parameters env !evdref ind jl) - | Const cst when Environ.template_polymorphic_pconstant cst env -> + (inductive_type_knowing_parameters env !evdref (ind, u) jl) + | Const (cst, u) when EInstance.is_empty u && Environ.template_polymorphic_constant cst env -> (* Sort-polymorphism of inductive types *) make_judge f - (constant_type_knowing_parameters env !evdref cst jl) + (constant_type_knowing_parameters env !evdref (cst, u) jl) | _ -> execute env evdref f in diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 035b0c2230..91781a0769 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -535,6 +535,7 @@ let key_of env sigma b flags f = | Const (cst, u) when is_transparent env (ConstKey cst) && (Cpred.mem cst (snd flags.modulo_delta) || Environ.is_projection cst env) -> + let u = EInstance.kind sigma u in Some (IsKey (ConstKey (cst, u))) | Var id when is_transparent env (VarKey id) && Id.Pred.mem id (fst flags.modulo_delta) -> -- cgit v1.2.3 From 2794b3c91bbbef115303b40f2e494ad97467dc9e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 5 Apr 2017 14:05:42 +0200 Subject: Removing a normalization hotspot from EConstr. It was not necessary to normalize a term just to check whether it was a global reference. The hotspot appeared in mathcomp. --- pretyping/evarconv.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'pretyping') diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index 9c9350ab10..44b771283b 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -154,7 +154,7 @@ let check_conv_record env sigma (t1,sk1) (t2,sk2) = lookup_canonical_conversion (proji, Sort_cs (family_of_sort s)),[] | _ -> - let c2 = global_of_constr (EConstr.to_constr sigma t2) in + let (c2, _) = Termops.global_of_constr sigma t2 in lookup_canonical_conversion (proji, Const_cs c2),sk2 with Not_found -> let (c, cs) = lookup_canonical_conversion (proji,Default_cs) in -- cgit v1.2.3 From d6175b9980808ff91f1299ca26a9a49a117169ca Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 6 Apr 2017 17:34:23 +0200 Subject: Fix a normalization hotspot in computation of constr keys. Getting a key only needs to observe the root of a term. This hotspot was observed in HoTT. --- pretyping/unification.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'pretyping') diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 91781a0769..eb90dfbdb6 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -1739,7 +1739,7 @@ let keyed_unify env evd kop = | None -> fun _ -> true | Some kop -> fun cl -> - let kc = Keys.constr_key (EConstr.to_constr evd cl) in + let kc = Keys.constr_key (fun c -> EConstr.kind evd c) cl in match kc with | None -> false | Some kc -> Keys.equiv_keys kop kc @@ -1749,7 +1749,7 @@ let keyed_unify env evd kop = Fails if no match is found *) let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let bestexn = ref None in - let kop = Keys.constr_key (EConstr.to_constr evd op) in + let kop = Keys.constr_key (fun c -> EConstr.kind evd c) op in let rec matchrec cl = let cl = strip_outer_cast evd cl in (try -- cgit v1.2.3