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. --- plugins/btauto/refl_btauto.ml | 19 +++++++-------- plugins/cc/cctac.ml | 10 ++++---- plugins/decl_mode/decl_interp.ml | 2 +- plugins/decl_mode/decl_proof_instr.ml | 32 +++++++++++++------------- plugins/extraction/extraction.ml | 6 ++--- plugins/firstorder/formula.ml | 12 +++++----- plugins/firstorder/rules.ml | 4 ++-- plugins/firstorder/unify.ml | 13 +++++++---- plugins/fourier/fourierR.ml | 3 ++- plugins/funind/functional_principles_proofs.ml | 22 +++++++++--------- plugins/funind/functional_principles_types.ml | 18 +++++++-------- plugins/funind/indfun.ml | 9 ++++---- plugins/funind/invfun.ml | 8 +++---- plugins/funind/merge.ml | 4 ++-- plugins/funind/recdef.ml | 12 +++++----- plugins/micromega/coq_micromega.ml | 5 ++-- plugins/quote/quote.ml | 8 +++---- plugins/rtauto/refl_tauto.ml | 4 ++-- plugins/ssrmatching/ssrmatching.ml4 | 2 +- 19 files changed, 100 insertions(+), 93 deletions(-) (limited to 'plugins') diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 2c5b108e55..3ba5da149a 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -14,8 +14,8 @@ let get_inductive dir s = let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) -let decomp_term (c : Term.constr) = - Term.kind_of_term (Termops.strip_outer_cast c) +let decomp_term sigma (c : Term.constr) = + Term.kind_of_term (Termops.strip_outer_cast sigma (EConstr.of_constr c)) let lapp c v = Term.mkApp (Lazy.force c, v) @@ -105,7 +105,7 @@ module Bool = struct | Negb of t | Ifb of t * t * t - let quote (env : Env.t) (c : Term.constr) : t = + let quote (env : Env.t) sigma (c : Term.constr) : t = let trueb = Lazy.force trueb in let falseb = Lazy.force falseb in let andb = Lazy.force andb in @@ -113,7 +113,7 @@ module Bool = struct let xorb = Lazy.force xorb in let negb = Lazy.force negb in - let rec aux c = match decomp_term c with + let rec aux c = match decomp_term sigma c with | Term.App (head, args) -> if head === andb && Array.length args = 2 then Andb (aux args.(0), aux args.(1)) @@ -181,7 +181,7 @@ module Btauto = struct let var = lapp witness [|p|] in (* Compute an assignment that dissatisfies the goal *) let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in - let rec to_list l = match decomp_term l with + let rec to_list l = match decomp_term (Tacmach.project gl) l with | Term.App (c, _) when c === (Lazy.force CoqList._nil) -> [] | Term.App (c, [|_; h; t|]) @@ -220,7 +220,7 @@ module Btauto = struct Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in - let t = decomp_term concl in + let t = decomp_term (Tacmach.New.project gl) concl in match t with | Term.App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) @@ -234,15 +234,16 @@ module Btauto = struct let tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in let eq = Lazy.force eq in let bool = Lazy.force Bool.typ in - let t = decomp_term concl in + let t = decomp_term sigma concl in match t with | Term.App (c, [|typ; tl; tr|]) when typ === bool && c === eq -> let env = Env.empty () in - let fl = Bool.quote env tl in - let fr = Bool.quote env tr in + let fl = Bool.quote env sigma tl in + let fr = Bool.quote env sigma tr in let env = Env.to_list env in let fl = reify env fl in let fr = reify env fr in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index b5ca2f50fc..425bb2d6f8 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -58,8 +58,8 @@ let rec decompose_term env sigma t= let tf=decompose_term env sigma f in let targs=Array.map (decompose_term env sigma) args in Array.fold_left (fun s t->Appli (s,t)) tf targs - | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> - let b = Termops.pop _b in + | Prod (_,a,_b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr _b) -> + let b = Termops.pop (EConstr.of_constr _b) in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in Appli(Appli(Product (sort_a,sort_b) , @@ -86,7 +86,7 @@ let rec decompose_term env sigma t= let p' = Projection.map canon_const p in (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) | _ -> - let t = Termops.strip_outer_cast t in + let t = Termops.strip_outer_cast sigma (EConstr.of_constr t) in if closed0 t then Symb t else raise Not_found (* decompose equality in members and type *) @@ -112,8 +112,8 @@ let rec pattern_of_constr env sigma c = (Array.map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Int.Set.union Int.Set.empty lrels - | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> - let b = Termops.pop _b in + | Prod (_,a,_b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr _b) -> + let b = Termops.pop (EConstr.of_constr _b) in let pa,sa = pattern_of_constr env sigma a in let pb,sb = pattern_of_constr env sigma b in let sort_b = sf_of env sigma b in diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index f68c01b18b..65d273fafb 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -374,7 +374,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = match st'.st_it with Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} | This _ -> {st_it = This st.st_it;st_label=st.st_label} in - let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in + let thyps = fst (match_hyps blend nam2 (Termops.pop (EConstr.of_constr rest1)) hyps) in tparams,{pat_vars=tpatvars; pat_aliases=taliases; pat_constr=pat_pat; diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index e19dc86c45..46fa5b408a 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -445,7 +445,7 @@ let concl_refiner metas body gls = let bsort,_B,nbody = aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in let body = mkNamedLambda _x _A nbody in - if occur_term (mkVar _x) _B then + if local_occur_var evd _x (EConstr.of_constr _B) then begin let _P = mkNamedLambda _x _A _B in match bsort,sort with @@ -672,14 +672,14 @@ let rec metas_from n hyps = _ :: q -> n :: metas_from (succ n) q | [] -> [] -let rec build_product args body = +let rec build_product sigma args body = match args with (Hprop st| Hvar st )::rest -> - let pprod= lift 1 (build_product rest body) in + let pprod= lift 1 (build_product sigma rest body) in let lbody = match st.st_label with Anonymous -> pprod - | Name id -> subst_term (mkVar id) pprod in + | Name id -> subst_var id pprod in mkProd (st.st_label, st.st_it, lbody) | [] -> body @@ -694,7 +694,7 @@ let instr_suffices _then cut gls0 = let info = get_its_info gls0 in let c_id = pf_get_new_id (Id.of_string "_cofact") gls0 in let ctx,hd = cut.cut_stat in - let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in + let c_stat = build_product (project gls0) ctx (mk_stat_or_thesis info gls0 hd) in let metas = metas_from 1 ctx in let c_ctx,c_head = build_applist c_stat metas in let c_term = applist (mkVar c_id,List.map mkMeta metas) in @@ -780,7 +780,7 @@ let rec consider_match may_intro introduced available expected gls = gls let consider_tac c hyps gls = - match kind_of_term (strip_outer_cast c) with + match kind_of_term (strip_outer_cast (project gls) (EConstr.of_constr c)) with Var id -> consider_match false [] [id] hyps gls | _ -> @@ -805,18 +805,18 @@ let rec take_tac wits gls = (* tactics for define *) -let rec build_function args body = +let rec build_function sigma args body = match args with st::rest -> - let pfun= lift 1 (build_function rest body) in + let pfun= lift 1 (build_function sigma rest body) in let id = match st.st_label with Anonymous -> assert false | Name id -> id in - mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) + mkLambda (Name id, st.st_it, subst_term sigma (EConstr.mkVar id) (EConstr.of_constr pfun)) | [] -> body let define_tac id args body gls = - let t = build_function args body in + let t = build_function (project gls) args body in Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls (* tactics for reconsider *) @@ -880,7 +880,7 @@ let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_unsafe_type_of gls casee in - let is_dep = dependent casee concl in + let is_dep = dependent (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl) in let hd,args = decompose_app (special_whd gls ctyp) in let (ind,u) = try @@ -895,9 +895,9 @@ let build_per_info etype casee gls = let params,real_args = List.chop nparams args in let abstract_obj c body = let typ=pf_unsafe_type_of gls c in - lambda_create env (typ,subst_term c body) in + lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in let pred= List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in + real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl))) in is_dep, {per_casee=casee; per_ctype=ctyp; @@ -953,7 +953,7 @@ let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in let id = pf_get_new_id (Id.of_string "subcase_") gls0 in - let clause = build_product hyps thesis in + let clause = build_product (project gls0) hyps thesis in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in let old_clauses,stack = register_nodep_subcase id info.pm_stack in let ninfo2 = {pm_stack=stack} in @@ -1263,9 +1263,9 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let params,real_args = List.chop nparams all_args in let abstract_obj c body = let typ=pf_unsafe_type_of gls c in - lambda_create env (typ,subst_term c body) in + lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in let elim_pred = List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in + real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl))) in let case_info = Inductiveops.make_case_info env ind RegularStyle in let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index a980a43f53..85cacecdbb 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -42,11 +42,11 @@ let none = Evd.empty let type_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_type_of ~polyprop env none (strip_outer_cast c) + Retyping.get_type_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) let sort_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) + Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) (*S Generation of flags and signatures. *) @@ -887,7 +887,7 @@ let extract_std_constant env kn body typ = break user's clever let-ins and partial applications). *) let rels, c = let n = List.length s - and m = nb_lam body in + and m = nb_lam Evd.empty (EConstr.of_constr body) (** FIXME *) in if n <= m then decompose_lam_n n body else let s,s' = List.chop m s in diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index b34a364920..79f185d187 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -79,13 +79,13 @@ type kind_of_formula= let kind_of_formula gl term = let normalize=special_nf gl in let cciterm=special_whd gl term in - match match_with_imp_term cciterm with - Some (a,b)-> Arrow(a,(pop b)) + match match_with_imp_term (project gl) cciterm with + Some (a,b)-> Arrow(a,(pop (EConstr.of_constr b))) |_-> - match match_with_forall_term cciterm with + match match_with_forall_term (project gl) cciterm with Some (_,a,b)-> Forall(a,b) |_-> - match match_with_nodep_ind cciterm with + match match_with_nodep_ind (project gl) cciterm with Some (i,l,n)-> let ind,u=destInd i in let (mib,mip) = Global.lookup_inductive ind in @@ -96,7 +96,7 @@ let kind_of_formula gl term = let has_realargs=(n>0) in let is_trivial= let is_constant c = - Int.equal (nb_prod c) mib.mind_nparams in + Int.equal (nb_prod (project gl) (EConstr.of_constr c)) mib.mind_nparams in Array.exists is_constant mip.mind_nf_lc in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) @@ -108,7 +108,7 @@ let kind_of_formula gl term = else Or((ind,u),l,is_trivial) | _ -> - match match_with_sigma_type cciterm with + match match_with_sigma_type (project gl) cciterm with Some (i,l)-> Exists((destInd i),l) |_-> Atom (normalize cciterm) diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 7ffc78928d..1d107e9afe 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -38,8 +38,8 @@ let wrap n b continue seq gls= []->anomaly (Pp.str "Not the expected number of hyps") | nd::q-> let id = NamedDecl.get_id nd in - if occur_var env id (pf_concl gls) || - List.exists (occur_var_in_decl env id) ctx then + if occur_var env (project gls) id (EConstr.of_constr (pf_concl gls)) || + List.exists (occur_var_in_decl env (project gls) id) ctx then (aux (i-1) q (nd::ctx)) else add_formula Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) gls in diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index d9ab36ad64..01c0197443 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -21,7 +21,10 @@ exception UFAIL of constr*constr to the equation set. Raises UFAIL with a pair of terms *) +let strip_outer_cast t = strip_outer_cast Evd.empty (EConstr.of_constr t) (** FIXME *) + let unif t1 t2= + let evd = Evd.empty in (** FIXME *) let bige=Queue.create () and sigma=ref [] in let bind i t= @@ -47,18 +50,18 @@ let unif t1 t2= else bind i nt2 | Meta i,_ -> let t=subst_meta !sigma nt2 in - if Int.Set.is_empty (free_rels t) && - not (occur_term (mkMeta i) t) then + if Int.Set.is_empty (free_rels evd (EConstr.of_constr t)) && + not (occur_term evd (EConstr.mkMeta i) (EConstr.of_constr t)) then bind i t else raise (UFAIL(nt1,nt2)) | _,Meta i -> let t=subst_meta !sigma nt1 in - if Int.Set.is_empty (free_rels t) && - not (occur_term (mkMeta i) t) then + if Int.Set.is_empty (free_rels evd (EConstr.of_constr t)) && + not (occur_term evd (EConstr.mkMeta i) (EConstr.of_constr t)) then bind i t else raise (UFAIL(nt1,nt2)) | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> - Queue.add (a,c) bige;Queue.add (pop b,pop d) bige + Queue.add (a,c) bige;Queue.add (pop (EConstr.of_constr b),pop (EConstr.of_constr d)) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 8e193c753e..a14ec8a2ca 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -461,8 +461,9 @@ exception GoalDone let rec fourier () = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; - let goal = Termops.strip_outer_cast concl in + let goal = Termops.strip_outer_cast sigma (EConstr.of_constr concl) in let fhyp=Id.of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, et le but à prouver devient False *) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 527f4f0b12..f6567ab812 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -287,7 +287,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *) + let end_of_type_with_pop = Termops.pop (EConstr.of_constr end_of_type) in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 @@ -309,7 +309,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) + (Termops.pop (EConstr.of_constr end_of_type),ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -430,7 +430,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = begin let pte,pte_args = (destApp t_x) in let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = Termops.pop t' in + let popped_t' = Termops.pop (EConstr.of_constr t') in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in @@ -480,7 +480,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) - let popped_t' = Termops.pop t' in + let popped_t' = Termops.pop (EConstr.of_constr t') in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in @@ -508,7 +508,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ] else if is_trivial_eq t_x then (* t_x := t = t => we remove this precond *) - let popped_t' = Termops.pop t' in + let popped_t' = Termops.pop (EConstr.of_constr t') in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in @@ -608,7 +608,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let fun_body = mkLambda(Anonymous, pf_unsafe_type_of g' term, - Termops.replace_term term (mkRel 1) dyn_infos.info + Termops.replace_term (project g') (EConstr.of_constr term) (EConstr.mkRel 1) (EConstr.of_constr dyn_infos.info) ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in @@ -699,7 +699,7 @@ let build_proof let t = dyn_info'.info in let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (pf_concl g) in + let g_nb_prod = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in let type_of_term = pf_unsafe_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t @@ -712,7 +712,7 @@ let build_proof (fun g -> observe_tac "toto" ( tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in + let g'_nb_prod = nb_prod (project g') (EConstr.of_constr (pf_concl g')) in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case @@ -927,8 +927,8 @@ let generalize_non_dep hyp g = Environ.fold_named_context_reverse (fun (clear,keep) decl -> let hyp = get_id decl in if Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env hyp) keep - || Termops.occur_var env hyp hyp_typ + || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep + || Termops.occur_var env (project g) hyp (EConstr.of_constr hyp_typ) || Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) @@ -1042,7 +1042,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in res in - let nb_intro_to_do = nb_prod (pf_concl g) in + let nb_intro_to_do = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in tclTHEN (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) ( diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index cc699e5d3d..032d887de7 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -110,7 +110,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in + let res = mkApp(rel_to_fun.(i), Array.map (fun c -> Termops.pop (EConstr.of_constr c)) (array_get_start args)) in observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); res in @@ -168,25 +168,25 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b + then (Termops.pop (EConstr.of_constr new_b)), filter_map (eq_constr (mkRel 1)) (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b else ( bind_fun(new_x,new_t,new_b), list_union_eq eq_constr binders_to_remove_from_t - (List.map Termops.pop binders_to_remove_from_b) + (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map Termops.pop binders_to_remove_from_b + new_b, List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin @@ -197,25 +197,25 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b + then (Termops.pop (EConstr.of_constr new_b)),filter_map (eq_constr (mkRel 1)) (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b else ( mkLetIn(new_x,new_v,new_t,new_b), list_union_eq eq_constr (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) - (List.map Termops.pop binders_to_remove_from_b) + (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map Termops.pop binders_to_remove_from_b + new_b, List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 99b04898ba..a264c37c57 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -14,20 +14,21 @@ open Sigma.Notations module RelDecl = Context.Rel.Declaration -let is_rec_info scheme_info = +let is_rec_info sigma scheme_info = let test_branche min acc decl = acc || ( let new_branche = it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (RelDecl.get_type decl))) in - let free_rels_in_br = Termops.free_rels new_branche in + let free_rels_in_br = Termops.free_rels sigma (EConstr.of_constr new_branche) in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br ) in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) -let choose_dest_or_ind scheme_info = - Tactics.induction_destruct (is_rec_info scheme_info) false +let choose_dest_or_ind scheme_info args = + Proofview.tclBIND Proofview.tclEVARMAP (fun sigma -> + Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = let res = diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index c8b4e48337..cf42a809db 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -254,7 +254,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let princ_type = nf_zeta princ_type in let princ_infos = Tactics.compute_elim_sig princ_type in (* The number of args of the function is then easily computable *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in + let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the functional principle is defined in the @@ -467,7 +467,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | LocalAssum (id,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -666,7 +666,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (* Then we get the number of argument of the function and compute a fresh name for each of them *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in + let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) @@ -684,7 +684,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (RelDecl.get_type decl))) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (EConstr.of_constr (RelDecl.get_type decl)))) ) branches in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 19c2ed4178..865042afbe 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -32,7 +32,7 @@ module RelDecl = Context.Rel.Declaration (** {2 Useful operations on constr and glob_constr} *) -let rec popn i c = if i<=0 then c else pop (popn (i-1) c) +let rec popn i c = if i<=0 then c else pop (EConstr.of_constr (popn (i-1) c)) (** Substitutions in constr *) let compare_constr_nosub t1 t2 = @@ -985,7 +985,7 @@ let relprinctype_to_funprinctype relprinctype nfuns = (* first remove indarg and indarg_in_concl *) let relinfo_noindarg = { relinfo with indarg_in_concl = false; indarg = None; - concl = remove_last_arg (pop relinfo.concl); } in + concl = remove_last_arg (pop (EConstr.of_constr relinfo.concl)); } in (* the nfuns last induction arguments are functional ones: remove them *) let relinfo_argsok = { relinfo_noindarg with nargs = relinfo_noindarg.nargs - nfuns; diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 54066edfb8..6b63d7771e 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -407,7 +407,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = let _,args = try destApp ty_teq with DestKO -> assert false in args.(1),args.(2) in - let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in + let new_b' = Termops.replace_term (project g') (EConstr.of_constr teq_lhs) (EConstr.of_constr teq_rhs) (EConstr.of_constr new_b) in let new_infos = { infos with info = new_b'; @@ -681,7 +681,7 @@ let mkDestructEq : (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl)) + if Id.List.mem id not_on_hyp || not (Termops.occur_term (project g) (EConstr.of_constr expr) (EConstr.of_constr (get_type decl))) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in @@ -1251,7 +1251,7 @@ let clear_goals = | Prod(Name id as na,t',b) -> let b' = clear_goal b in if noccurn 1 b' && (is_rec_res id) - then Termops.pop b' + then Termops.pop (EConstr.of_constr b') else if b' == b then t else mkProd(na,t',b') | _ -> Term.map_constr clear_goal t @@ -1285,7 +1285,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp anomaly (Pp.str "open_new_goal with an unamed theorem") in let na = next_global_ident_away name [] in - if Termops.occur_existential gls_type then + if Termops.occur_existential sigma (EConstr.of_constr gls_type) then CErrors.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = @@ -1422,7 +1422,7 @@ let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in + let nargs = nb_prod (project g) (EConstr.of_constr (fst (type_of_const terminate_constr))) (*FIXME*) in let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; @@ -1552,7 +1552,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; + functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod evm (EConstr.of_constr res)) relation; if Flags.is_verbose () then msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a063cbbfe3..49fcf83b46 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1221,7 +1221,7 @@ struct let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)-> + | Prod(typ,a,b) when EConstr.Vars.noccurn Evd.empty 1 (EConstr.of_constr b) (** FIXME *) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg @@ -1687,7 +1687,8 @@ let rec mk_topo_order le l = | (Some v,l') -> v :: (mk_topo_order le l') -let topo_sort_constr l = mk_topo_order Termops.dependent l +let topo_sort_constr l = + mk_topo_order (fun c t -> Termops.dependent Evd.empty (** FIXME *) (EConstr.of_constr c) (EConstr.of_constr t)) l (** diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 6405c8cebd..c6376727af 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -183,7 +183,7 @@ type inversion_scheme = { let i_can't_do_that () = error "Quote: not a simple fixpoint" -let decomp_term c = kind_of_term (Termops.strip_outer_cast c) +let decomp_term gl c = kind_of_term (Termops.strip_outer_cast (Tacmach.New.project gl) (EConstr.of_constr c)) (*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive @@ -223,14 +223,14 @@ let compute_rhs bodyi index_of_f = let compute_ivs f cs gl = let cst = try destConst f with DestKO -> i_can't_do_that () in let body = Environ.constant_value_in (Global.env()) cst in - match decomp_term body with + match decomp_term gl body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> let (args3, body3) = decompose_lam body2 in let nargs3 = List.length args3 in let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let is_conv = Reductionops.is_conv env sigma in - begin match decomp_term body3 with + begin match decomp_term gl body3 with | Case(_,p,c,lci) -> (*

Case c of c1 ... cn end *) let n_lhs_rhs = ref [] and v_lhs = ref (None : constr option) @@ -267,7 +267,7 @@ let compute_ivs f cs gl = (* The Cases predicate is a lambda; we assume no dependency *) let p = match kind_of_term p with - | Lambda (_,_,p) -> Termops.pop p + | Lambda (_,_,p) -> Termops.pop (EConstr.of_constr p) | _ -> p in diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 367a133330..b129b0bb3b 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -94,7 +94,7 @@ let rec make_form atom_env gls term = let cciterm=special_whd gls term in match kind_of_term cciterm with Prod(_,a,b) -> - if not (Termops.dependent (mkRel 1) b) && + if EConstr.Vars.noccurn Evd.empty (** FIXME *) 1 (EConstr.of_constr b) && Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) a == InProp then @@ -134,7 +134,7 @@ let rec make_hyps atom_env gls lenv = function | LocalAssum (id,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in - if List.exists (Termops.dependent (mkVar id)) lenv || + if List.exists (fun c -> Termops.local_occur_var Evd.empty (** FIXME *) id (EConstr.of_constr c)) lenv || (Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) typ != InProp) then diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 77e25b2a5b..86cc928c85 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -702,7 +702,7 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = let fixed_upat = function | {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false -| {up_t = t} -> not (occur_existential t) +| {up_t = t} -> not (occur_existential Evd.empty (EConstr.of_constr t)) (** FIXME *) let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) -- 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. --- plugins/decl_mode/decl_proof_instr.ml | 4 ++-- plugins/extraction/extraction.ml | 22 +++++++++++----------- plugins/firstorder/instances.ml | 2 +- plugins/firstorder/unify.ml | 4 ++-- plugins/funind/functional_principles_proofs.ml | 24 ++++++++++++------------ plugins/funind/functional_principles_types.ml | 2 +- plugins/funind/glob_term_to_relation.ml | 8 ++++---- plugins/funind/invfun.ml | 14 +++++++------- plugins/funind/merge.ml | 2 +- plugins/funind/recdef.ml | 4 ++-- plugins/micromega/coq_micromega.ml | 2 +- plugins/omega/coq_omega.ml | 2 +- plugins/quote/quote.ml | 4 ++-- plugins/setoid_ring/newring.ml | 5 +++-- plugins/ssrmatching/ssrmatching.ml4 | 4 +++- 15 files changed, 53 insertions(+), 50 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 46fa5b408a..c17c8dbb81 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -1092,7 +1092,7 @@ let thesis_for obj typ per_info env= ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in - compose_prod rc (Reductionops.whd_beta Evd.empty hd2) + compose_prod rc (Reductionops.whd_beta Evd.empty (EConstr.of_constr hd2)) let rec build_product_dep pat_info per_info args body gls = match args with @@ -1222,7 +1222,7 @@ let hrec_for fix_id per_info gls obj_id = try List.for_all2 eq_constr params per_info.per_params with Invalid_argument _ -> false end; let hd2 = applist (mkVar fix_id,args@[obj]) in - compose_lam rc (Reductionops.whd_beta gls.sigma hd2) + compose_lam rc (Reductionops.whd_beta gls.sigma (EConstr.of_constr hd2)) let warn_missing_case = CWarnings.create ~name:"declmode-missing-case" ~category:"declmode" diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 85cacecdbb..6ca34036af 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -74,7 +74,7 @@ type flag = info * scheme Really important function. *) let rec flag_of_type env t : flag = - let t = whd_all env none t in + let t = whd_all env none (EConstr.of_constr t) in match kind_of_term t with | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) @@ -102,14 +102,14 @@ let is_info_scheme env t = match flag_of_type env t with (*s [type_sign] gernerates a signature aimed at treating a type application. *) let rec type_sign env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env none (EConstr.of_constr c)) with | Prod (n,t,d) -> (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] let rec type_scheme_nb_args env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env none (EConstr.of_constr c)) with | Prod (n,t,d) -> let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in if is_info_scheme env t then n+1 else n @@ -135,7 +135,7 @@ let make_typvar n vl = next_ident_away id' vl let rec type_sign_vl env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env none (EConstr.of_constr c)) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in if not (is_info_scheme env t) then Kill Kprop::s, vl @@ -143,7 +143,7 @@ let rec type_sign_vl env c = | _ -> [],[] let rec nb_default_params env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env none (EConstr.of_constr c)) with | Prod (n,t,d) -> let n = nb_default_params (push_rel_assum (n,t) env) d in if is_default env t then n+1 else n @@ -214,7 +214,7 @@ let parse_ind_args si args relmax = let rec extract_type env db j c args = - match kind_of_term (whd_betaiotazeta Evd.empty c) with + match kind_of_term (whd_betaiotazeta none (EConstr.of_constr c)) with | App (d, args') -> (* We just accumulate the arguments. *) extract_type env db j d (Array.to_list args' @ args) @@ -297,7 +297,7 @@ and extract_type_app env db (r,s) args = let ml_args = List.fold_right (fun (b,c) a -> if b == Keep then - let p = List.length (fst (splay_prod env none (type_of env c))) in + let p = List.length (fst (splay_prod env none (EConstr.of_constr (type_of env c)))) in let db = iterate (fun l -> 0 :: l) p db in (extract_type_scheme env db c p) :: a else a) @@ -316,12 +316,12 @@ and extract_type_app env db (r,s) args = and extract_type_scheme env db c p = if Int.equal p 0 then extract_type env db 0 c [] else - let c = whd_betaiotazeta Evd.empty c in + let c = whd_betaiotazeta none (EConstr.of_constr c) in match kind_of_term c with | Lambda (n,t,d) -> extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) | _ -> - let rels = fst (splay_prod env none (type_of env c)) in + let rels = fst (splay_prod env none (EConstr.of_constr (type_of env c))) in let env = push_rels_assum rels env in let eta_args = List.rev_map mkRel (List.interval 1 p) in extract_type env db 0 (lift p c) eta_args @@ -488,7 +488,7 @@ and extract_really_ind env kn mib = *) and extract_type_cons env db dbmap c i = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env none (EConstr.of_constr c)) with | Prod (n,t,d) -> let env' = push_rel_assum (n,t) env in let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in @@ -846,7 +846,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt = and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *) let decomp_lams_eta_n n m env c t = - let rels = fst (splay_prod_n env none n t) in + let rels = fst (splay_prod_n env none n (EConstr.of_constr t)) in let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in let rels',c = decompose_lam c in let d = n - m in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index eebd974ea8..a3513692c5 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -107,7 +107,7 @@ let mk_open_instance id idc gl m t= let typ=pf_unsafe_type_of gl idc in (* since we know we will get a product, reduction is not too expensive *) - let (nam,_,_)=destProd (whd_all env evmap typ) in + let (nam,_,_)=destProd (whd_all env evmap (EConstr.of_constr typ)) in match nam with Name id -> id | Anonymous -> dummy_bvid in diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 01c0197443..fb237f29bf 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -41,8 +41,8 @@ let unif t1 t2= Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) - and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in + let nt1=head_reduce (whd_betaiotazeta Evd.empty (EConstr.of_constr t1)) + and nt2=head_reduce (whd_betaiotazeta Evd.empty (EConstr.of_constr t2)) in match (kind_of_term nt1),(kind_of_term nt2) with Meta i,Meta j-> if not (Int.equal i j) then diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f6567ab812..258ee5ad69 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -318,7 +318,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = context in let new_type_of_hyp = - Reductionops.nf_betaiota Evd.empty new_type_of_hyp in + Reductionops.nf_betaiota Evd.empty (EConstr.of_constr new_type_of_hyp) in let new_ctxt,new_end_of_type = decompose_prod_n_assum ctxt_size new_type_of_hyp in @@ -786,7 +786,7 @@ let build_proof do_finalize dyn_infos g | Lambda _ -> let new_term = - Reductionops.nf_beta Evd.empty dyn_infos.info in + Reductionops.nf_beta Evd.empty (EConstr.of_constr dyn_infos.info) in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> @@ -1090,7 +1090,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) - body + (EConstr.of_constr body) | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in @@ -1142,8 +1142,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam Array.map (fun body -> Reductionops.nf_betaiota Evd.empty - (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)) + (EConstr.of_constr (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, + List.rev_map var_of_decl princ_params))) ) bodies in @@ -1179,20 +1179,20 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = - Reductionops.nf_betaiota Evd.empty ( - applist(body,List.rev_map var_of_decl full_params)) + Reductionops.nf_betaiota Evd.empty (EConstr.of_constr ( + applist(body,List.rev_map var_of_decl full_params))) in match kind_of_term body_with_full_params with | Fix((_,num),(_,_,bs)) -> Reductionops.nf_betaiota Evd.empty - ( + (EConstr.of_constr ( (applist (substl (List.rev (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) - ),num + )),num | _ -> error "Not a mutual block" in let info = @@ -1269,7 +1269,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam rec_hyps = []; info = Reductionops.nf_betaiota Evd.empty - (applist(fix_body,List.rev_map mkVar args_id)); + (EConstr.of_constr (applist(fix_body,List.rev_map mkVar args_id))); eq_hyps = [] } in @@ -1329,10 +1329,10 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam rec_hyps = []; info = Reductionops.nf_betaiota Evd.empty - (applist(fbody_with_full_params, + (EConstr.of_constr (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) - )); + ))); eq_hyps = [] } in diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 032d887de7..9637632a6c 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -405,7 +405,7 @@ let get_funs_constant mp dp = (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.from_env (Global.env ())) - body + (EConstr.of_constr body) in body | None -> error ( "Cannot define a principle over an axiom ") diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index de2e5ea4e2..92de4d8734 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -352,7 +352,7 @@ let add_pat_variables pat typ env : Environ.env = | PatVar(_,na) -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) typ + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -409,7 +409,7 @@ let rec pattern_to_term_and_type env typ = function constr in let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) typ + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -629,7 +629,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ + try Inductiveops.find_inductive env (Evd.from_env env) (EConstr.of_constr b_typ) with Not_found -> user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ @@ -661,7 +661,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) b_typ + try Inductiveops.find_inductive env (Evd.from_env env) (EConstr.of_constr b_typ) with Not_found -> user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index cf42a809db..9abe604025 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -251,7 +251,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in - let princ_type = nf_zeta princ_type in + let princ_type = nf_zeta (EConstr.of_constr princ_type) in let princ_infos = Tactics.compute_elim_sig princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in @@ -428,7 +428,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in - (nf_zeta p)::bindings,id::avoid) + (nf_zeta (EConstr.of_constr p))::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -496,7 +496,7 @@ and intros_with_rewrite_aux : tactic = begin match kind_of_term t with | App(eq,args) when (eq_constr eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) + if Reductionops.is_conv (pf_env g) (project g) (EConstr.of_constr args.(1)) (EConstr.of_constr args.(2)) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g @@ -655,12 +655,12 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt)) + (fun (_,(ctxt,concl)) -> nf_zeta (EConstr.of_constr (Termops.it_mkLambda_or_LetIn concl ctxt))) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = nf_zeta schemes.(i) in + let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g graph_principle in let princ_infos = Tactics.compute_elim_sig princ_type in (* Then we get the number of argument of the function @@ -793,7 +793,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( graphs_constr.(i) <- graph; let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in - let type_of_lemma = nf_zeta type_of_lemma in + let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) @@ -860,7 +860,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let type_of_lemma = nf_zeta type_of_lemma in + let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 865042afbe..222c0c8043 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -135,7 +135,7 @@ let prNamedRLDecl s lc = let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in - let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in + let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty (EConstr.of_constr cstrid) in let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in List.iter (fun decl -> print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 6b63d7771e..4fd9e0ff89 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -693,7 +693,7 @@ let mkDestructEq : (fun g2 -> let changefun patvars = { run = fun sigma -> let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in - redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) + redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert @@ -1499,7 +1499,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in - let eq' = nf_zeta env_eq' eq' in + let eq' = nf_zeta env_eq' (EConstr.of_constr eq') in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 49fcf83b46..9fb1463db0 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -902,7 +902,7 @@ struct let is_convertible gl t1 t2 = - Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2 + Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) (EConstr.of_constr t1) (EConstr.of_constr t2) let parse_zop gl (op,args) = match kind_of_term op with diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 1afc6500b7..d15449aef9 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1591,7 +1591,7 @@ let nat_inject = (loop lit) ] | Kapp(Eq,[typ;t1;t2]) -> - if is_conv typ (Lazy.force coq_nat) then + if is_conv (EConstr.of_constr typ) (EConstr.of_constr (Lazy.force coq_nat)) then Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index c6376727af..afc7e6665b 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -249,8 +249,8 @@ let compute_ivs f cs gl = (* Then we test if the RHS is the RHS for variables *) else begin match decompose_app bodyi with | vmf, [_; _; a3; a4 ] - when isRel a3 && isRel a4 && is_conv vmf - (Lazy.force coq_varmap_find)-> + when isRel a3 && isRel a4 && is_conv (EConstr.of_constr vmf) + (EConstr.of_constr (Lazy.force coq_varmap_find)) -> v_lhs := Some (compute_lhs (snd (List.hd args3)) i nargsi) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 657efe175b..cf0f51911c 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -82,6 +82,7 @@ let lookup_map map = user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") let protect_red map env sigma c = + let c = EConstr.Unsafe.to_constr c in kl (create_clos_infos all env) (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; @@ -347,7 +348,7 @@ let find_ring_structure env sigma l = let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma ty ty') then + if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") in @@ -827,7 +828,7 @@ let find_field_structure env sigma l = let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma ty ty') then + if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") in diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 86cc928c85..cc39b72604 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -481,7 +481,9 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = (* p_origin can be passed to obtain a better error message *) let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = let k, f, a = - let f, a = Reductionops.whd_betaiota_stack ise p in + let f, a = Reductionops.whd_betaiota_stack ise (EConstr.of_constr p) in + let f = EConstr.Unsafe.to_constr f in + let a = List.map EConstr.Unsafe.to_constr a in match kind_of_term f with | Const (p,_) -> let np = proj_nparams p in -- 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. --- plugins/extraction/extraction.ml | 6 +++--- plugins/micromega/coq_micromega.ml | 2 +- plugins/rtauto/refl_tauto.ml | 8 ++++---- plugins/setoid_ring/newring.ml | 14 +++++++------- 4 files changed, 15 insertions(+), 15 deletions(-) (limited to 'plugins') diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6ca34036af..42a8cac69b 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -42,11 +42,11 @@ let none = Evd.empty let type_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_type_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) + Retyping.get_type_of ~polyprop env none (EConstr.of_constr (strip_outer_cast none (EConstr.of_constr c))) let sort_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) + Retyping.get_sort_family_of ~polyprop env none (EConstr.of_constr (strip_outer_cast none (EConstr.of_constr c))) (*S Generation of flags and signatures. *) @@ -595,7 +595,7 @@ let rec extract_term env mle mlt c args = | Construct (cp,_) -> extract_cons_app env mle mlt cp args | Proj (p, c) -> - let term = Retyping.expand_projection env (Evd.from_env env) p c [] in + let term = Retyping.expand_projection env (Evd.from_env env) p (EConstr.of_constr c) [] in extract_term env mle mlt term args | Rel n -> (* As soon as the expected [mlt] for the head is known, *) diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index 9fb1463db0..a943ef2b01 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1199,7 +1199,7 @@ struct with e when CErrors.noncritical e -> (X(t),env,tg) in let is_prop term = - let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) term in + let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) (EConstr.of_constr term) in Term.is_prop_sort sort in let rec xparse_formula env tg term = diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index b129b0bb3b..f88b3a7001 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -94,9 +94,9 @@ let rec make_form atom_env gls term = let cciterm=special_whd gls term in match kind_of_term cciterm with Prod(_,a,b) -> - if EConstr.Vars.noccurn Evd.empty (** FIXME *) 1 (EConstr.of_constr b) && + if EConstr.Vars.noccurn (Tacmach.project gls) 1 (EConstr.of_constr b) && Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) a == InProp + (pf_env gls) (Tacmach.project gls) (EConstr.of_constr a) == InProp then let fa=make_form atom_env gls a in let fb=make_form atom_env gls b in @@ -136,7 +136,7 @@ let rec make_hyps atom_env gls lenv = function make_hyps atom_env gls (typ::lenv) rest in if List.exists (fun c -> Termops.local_occur_var Evd.empty (** FIXME *) id (EConstr.of_constr c)) lenv || (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) typ != InProp) + (pf_env gls) (Tacmach.project gls) (EConstr.of_constr typ) != InProp) then hrec else @@ -262,7 +262,7 @@ let rtauto_tac gls= let gl=pf_concl gls in let _= if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) gl != InProp + (pf_env gls) (Tacmach.project gls) (EConstr.of_constr gl) != InProp then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index cf0f51911c..e1b95ddbc5 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -345,9 +345,9 @@ let ring_for_carrier r = Cmap.find r !from_carrier let find_ring_structure env sigma l = match l with | t::cl' -> - let ty = Retyping.get_type_of env sigma t in + let ty = Retyping.get_type_of env sigma (EConstr.of_constr t) in let check c = - let ty' = Retyping.get_type_of env sigma c in + let ty' = Retyping.get_type_of env sigma (EConstr.of_constr c) in if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") @@ -540,7 +540,7 @@ let build_setoid_params env evd r add mul opp req eqth = | None -> ring_equality env evd (r,add,mul,opp,req) let dest_ring env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma th_spec in + let th_typ = Retyping.get_type_of env sigma (EConstr.of_constr th_spec) in match kind_of_term th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) -> @@ -571,7 +571,7 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])) let make_hyp env evd c = - let t = Retyping.get_type_of env !evd c in + let t = Retyping.get_type_of env !evd (EConstr.of_constr c) in plapp evd coq_mkhypo [|t;c|] let make_hyp_list env evd lH = @@ -796,7 +796,7 @@ let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" let dest_field env evd th_spec = - let th_typ = Retyping.get_type_of env !evd th_spec in + let th_typ = Retyping.get_type_of env !evd (EConstr.of_constr th_spec) in match kind_of_term th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) when is_global (Lazy.force afield_theory) f -> @@ -825,9 +825,9 @@ let find_field_structure env sigma l = check_required_library (cdir@["Field_tac"]); match l with | t::cl' -> - let ty = Retyping.get_type_of env sigma t in + let ty = Retyping.get_type_of env sigma (EConstr.of_constr t) in let check c = - let ty' = Retyping.get_type_of env sigma c in + let ty' = Retyping.get_type_of env sigma (EConstr.of_constr c) in if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") -- 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. --- plugins/cc/cctac.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 425bb2d6f8..36a96fdb5e 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -259,7 +259,7 @@ let refresh_universes ty k = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in - let evm, ty = refresh_type env evm ty in + let evm, ty = refresh_type env evm (EConstr.of_constr ty) in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k ty) end } @@ -376,7 +376,7 @@ let discriminate_tac (cstr,u as cstru) p = let identity = Universes.constr_of_global (Lazy.force _I) in let trivial = Universes.constr_of_global (Lazy.force _True) in let evm = Tacmach.New.project gl in - let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl t1) in + let evm, intype = refresh_type env evm (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl t1)) in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in @@ -481,7 +481,7 @@ let mk_eq f c1 c2 k = Proofview.Goal.enter { enter = begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in - let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in + let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm (EConstr.of_constr ty) in let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm term in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) -- 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. --- plugins/funind/functional_principles_proofs.ml | 2 +- plugins/ssrmatching/ssrmatching.ml4 | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'plugins') diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 258ee5ad69..340dd2c28b 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -237,7 +237,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = failwith "NoChange"; end in - let eq_constr = Evarconv.e_conv env (ref sigma) in + let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) (EConstr.of_constr c1) (EConstr.of_constr c2) in if not (noccurn 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) if not (isApp t) then nochange "not an equality"; diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index cc39b72604..e0d99d4535 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -298,9 +298,9 @@ let unif_EQ_args env sigma pa a = prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a ;; -let unif_HO env ise p c = Evarconv.the_conv_x env p c ise +let unif_HO env ise p c = Evarconv.the_conv_x env (EConstr.of_constr p) (EConstr.of_constr c) ise -let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise +let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env (EConstr.of_constr p) (EConstr.of_constr c) ise let unif_HO_args env ise0 pa i ca = let n = Array.length pa in -- 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. --- plugins/cc/cctac.ml | 10 +++++----- plugins/decl_mode/decl_proof_instr.ml | 4 ++-- plugins/firstorder/instances.ml | 2 +- plugins/funind/functional_principles_proofs.ml | 10 +++++----- plugins/funind/functional_principles_types.ml | 10 +++++----- plugins/funind/glob_term_to_relation.ml | 18 +++++++++--------- plugins/funind/indfun.ml | 2 +- plugins/funind/invfun.ml | 8 ++++---- plugins/funind/recdef.ml | 2 +- plugins/setoid_ring/newring.ml | 8 ++++---- 10 files changed, 37 insertions(+), 37 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 36a96fdb5e..58454eedfe 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -50,7 +50,7 @@ let whd_delta env= (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = e_sort_of env (ref sigma) c +let sf_of env sigma c = e_sort_of env (ref sigma) (EConstr.of_constr c) let rec decompose_term env sigma t= match kind_of_term (whd env t) with @@ -247,7 +247,7 @@ let new_refine c = Proofview.V82.tactic (refine c) let assert_before n c = Proofview.Goal.enter { enter = begin fun gl -> - let evm, _ = Tacmach.New.pf_apply type_of gl c in + let evm, _ = Tacmach.New.pf_apply type_of gl (EConstr.of_constr c) in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) end } @@ -340,7 +340,7 @@ let refute_tac c t1 t2 p = end } let refine_exact_check c gl = - let evm, _ = pf_apply type_of gl c in + let evm, _ = pf_apply type_of gl (EConstr.of_constr c) in Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl let convert_to_goal_tac c t1 t2 p = @@ -480,10 +480,10 @@ let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> Proofview.Goal.enter { enter = begin fun gl -> let open Tacmach.New in - let evm, ty = pf_apply type_of gl c1 in + let evm, ty = pf_apply type_of gl (EConstr.of_constr c1) in let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm (EConstr.of_constr ty) in let term = mkApp (fc, [| ty; c1; c2 |]) in - let evm, _ = type_of (pf_env gl) evm term in + let evm, _ = type_of (pf_env gl) evm (EConstr.of_constr term) in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k term) end }) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index c17c8dbb81..dcebf78065 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -429,7 +429,7 @@ let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in - let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in + let sort = family_of_sort (Typing.e_sort_of env (ref evd) (EConstr.of_constr concl)) in let rec aux env avoid subst = function [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") | (n,typ)::rest -> @@ -437,7 +437,7 @@ let concl_refiner metas body gls = let x = id_of_name_using_hdchar env _A Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (LocalAssum (_x,_A)) env in - let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) _A) in + let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) (EConstr.of_constr _A)) in let nsubst = (n,mkVar _x)::subst in if List.is_empty rest then asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index a3513692c5..44bdb585a1 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -155,7 +155,7 @@ let left_instance_tac (inst,id) continue seq= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in let evmap, _ = - try Typing.type_of (pf_env gl) evmap gt + try Typing.type_of (pf_env gl) evmap (EConstr.of_constr gt) with e when CErrors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 340dd2c28b..0a7938069f 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -329,7 +329,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g to_refine in + let evm, _ = pf_apply Typing.type_of g (EConstr.of_constr to_refine) in tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in @@ -544,7 +544,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = tclIDTAC in try - scan_type [] (Typing.unsafe_type_of env sigma (mkVar hyp_id)), [hyp_id] + scan_type [] (Typing.unsafe_type_of env sigma (EConstr.mkVar hyp_id)), [hyp_id] with TOREMOVE -> thin [hyp_id],[] @@ -639,7 +639,7 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g c in + let evm, _ = pf_apply Typing.type_of g (EConstr.of_constr c) in tclTHENLIST[ Refiner.tclEVARS evm; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); @@ -968,7 +968,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let (type_ctxt,type_of_f),evd = - let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f + let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in decompose_prod_n_assum (nb_params + nb_args) t,evd @@ -1039,7 +1039,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in evd:=evd'; - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr res) in res in let nb_intro_to_do = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 9637632a6c..4b47b83afb 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -283,7 +283,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let new_princ_name = next_ident_away_in_goal (Id.of_string "___________princ_________") [] in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd new_principle_type in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof @@ -337,7 +337,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in ignore( @@ -488,7 +488,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con in let _ = evd := sigma in let l_schemes = - List.map (Typing.unsafe_type_of env sigma) schemes + List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma) schemes in let i = ref (-1) in let sorts = @@ -616,7 +616,7 @@ let build_scheme fas = in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in let _ = evd := evd' in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd f in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in (destConst f,sort) ) fas @@ -666,7 +666,7 @@ let build_case_scheme fa = Indrec.build_case_analysis_scheme_default env sigma ind sf in let sigma = Sigma.to_evar_map sigma in - let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in + let scheme_type = (Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme) in let sorts = (fun (_,_,x) -> Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 92de4d8734..38cd21684a 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -503,7 +503,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = The "value" of this branch is then simply [res] *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in + let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr rt_as_constr) in let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in @@ -611,7 +611,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in + let v_type = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr v_as_constr) in let new_env = match n with Anonymous -> env @@ -627,7 +627,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr b_as_constr) in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) (EConstr.of_constr b_typ) with Not_found -> @@ -659,7 +659,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = nal in let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr b_as_constr) in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) (EConstr.of_constr b_typ) with Not_found -> @@ -706,7 +706,7 @@ and build_entry_lc_from_case env funname make_discr let types = List.map (fun (case_arg,_) -> let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr + Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr case_arg_as_constr) ) el in (****** The next works only if the match is not dependent ****) @@ -753,7 +753,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.fold_right (fun id acc -> let typ_of_id = - Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (mkVar id) + Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = Detyping.detype false [] @@ -807,7 +807,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (mkVar id) in + let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = Detyping.detype false [] new_env (Evd.from_env env) typ_of_id in @@ -1121,7 +1121,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in - let type_t' = Typing.unsafe_type_of env evd t' in + let type_t' = Typing.unsafe_type_of env evd (EConstr.of_constr t') in let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1272,7 +1272,7 @@ let do_build_inductive let evd,env = Array.fold_right2 (fun id c (evd,env) -> - let evd,t = Typing.type_of env evd (mkConstU c) in + let evd,t = Typing.type_of env evd (EConstr.mkConstU c) in evd, Environ.push_named (LocalAssum (id,t)) (* try *) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a264c37c57..0743fc5d92 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -369,7 +369,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in - let princ_type = Typing.e_type_of ~refresh:true env evd uprinc in + let princ_type = Typing.e_type_of ~refresh:true env evd (EConstr.of_constr uprinc) in Functional_principles_types.generate_functional_principle evd interactive_proof diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 9abe604025..e5286fb1fd 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -134,7 +134,7 @@ let generate_type evd g_to_f f graph i = Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd graph))) in evd:=evd'; - let graph_arity = Typing.e_type_of (Global.env ()) evd graph in + let graph_arity = Typing.e_type_of (Global.env ()) evd (EConstr.of_constr graph) in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with @@ -202,7 +202,7 @@ let find_induction_principle evd f = | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in + let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr rect_lemma) in evd:=evd'; rect_lemma,typ @@ -449,7 +449,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes "functional_induction" ( (fun gl -> let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in + let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl (EConstr.of_constr term) in Proofview.V82.of_tactic (apply term) gl') )) (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) @@ -792,7 +792,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in + let _ = Typing.e_type_of (Global.env ()) evd (EConstr.of_constr type_of_lemma) in let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 4fd9e0ff89..12ed758ba9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -657,7 +657,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} let pf_type c tac gl = - let evars, ty = Typing.type_of (pf_env gl) (project gl) c in + let evars, ty = Typing.type_of (pf_env gl) (project gl) (EConstr.of_constr c) in tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index e1b95ddbc5..b0a3e839b9 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -493,8 +493,8 @@ let ring_equality env evd (r,add,mul,opp,req) = match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let setoid = Typing.e_solve_evars env evd setoid in - let op_morph = Typing.e_solve_evars env evd op_morph in + let setoid = Typing.e_solve_evars env evd (EConstr.of_constr setoid) in + let op_morph = Typing.e_solve_evars env evd (EConstr.of_constr op_morph) in (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in @@ -581,7 +581,7 @@ let make_hyp_list env evd lH = (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH (plapp evd coq_nil [|carrier|]) in - let l' = Typing.e_solve_evars env evd l in + let l' = Typing.e_solve_evars env evd (EConstr.of_constr l) in Evarutil.nf_evars_universes !evd l' let interp_power env evd pow = @@ -707,7 +707,7 @@ let make_term_list env evd carrier rl = let l = List.fold_right (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl (plapp evd coq_nil [|carrier|]) - in Typing.e_solve_evars env evd l + in Typing.e_solve_evars env evd (EConstr.of_constr l) let carg = Tacinterp.Value.of_constr let tacarg expr = -- 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. --- plugins/quote/quote.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index afc7e6665b..a13948f779 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -212,9 +212,9 @@ let compute_rhs bodyi index_of_f = let i = destRel (Array.last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> - PApp (pattern_of_constr (Global.env()) Evd.empty f, Array.map aux args) + PApp (pattern_of_constr (Global.env()) Evd.empty (EConstr.of_constr f), Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> pattern_of_constr (Global.env())(*FIXME*) Evd.empty c + | _ -> pattern_of_constr (Global.env())(*FIXME*) Evd.empty (EConstr.of_constr c) in aux bodyi -- 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. --- plugins/quote/quote.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'plugins') diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index a13948f779..7b6d502b5d 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -402,7 +402,7 @@ let quote_terms ivs lc = match l with | (lhs, rhs)::tail -> begin try - let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs c) in + let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs (EConstr.of_constr c)) in let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 in Termops.subst_meta s2 lhs -- 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. --- plugins/funind/recdef.ml | 2 +- plugins/ssrmatching/ssrmatching.ml4 | 5 ++++- 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 12ed758ba9..bdbf0242d7 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -692,7 +692,7 @@ let mkDestructEq : [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars = { run = fun sigma -> - let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in + let redfun = pattern_occs [Locus.AllOccurrencesBut [1], EConstr.of_constr expr] in redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index e0d99d4535..18aeca6faa 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -836,7 +836,10 @@ let rec uniquize = function | Context.Rel.Declaration.LocalDef (x,_,y) -> Context.Rel.Declaration.LocalAssum(x,y) in Environ.push_rel ctx_item env, h' + 1 in - let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in + let self acc c = EConstr.of_constr (subst_loop acc (EConstr.Unsafe.to_constr c)) in + let f = EConstr.of_constr f in + let f' = map_constr_with_binders_left_to_right sigma inc_h self acc f in + let f' = EConstr.Unsafe.to_constr f' in mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), ((fun () -> -- 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. --- plugins/decl_mode/decl_proof_instr.ml | 8 ++++---- plugins/firstorder/formula.ml | 2 +- plugins/funind/functional_principles_proofs.ml | 2 +- 3 files changed, 6 insertions(+), 6 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index dcebf78065..e587fd52ce 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -352,7 +352,7 @@ let enstack_subsubgoals env se stack gls= let constructor = mkConstructU ((ind,succ i),u) (* constructors numbering*) in let appterm = applist (constructor,params) in - let apptype = prod_applist gentyp params in + let apptype = Term.prod_applist gentyp params in let rc,_ = Reduction.dest_prod env apptype in let rec meta_aux last lenv = function [] -> (last,lenv,[]) @@ -687,7 +687,7 @@ let rec build_applist prod = function [] -> [],prod | n::q -> let (_,typ,_) = destProd prod in - let ctx,head = build_applist (prod_applist prod [mkMeta n]) q in + let ctx,head = build_applist (Term.prod_applist prod [mkMeta n]) q in (n,typ)::ctx,head let instr_suffices _then cut gls0 = @@ -720,7 +720,7 @@ let conjunction_arity id gls = let gentypes= Inductive.arities_of_constructors indu (mib,oib) in let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in - let apptype = prod_applist gentypes.(0) params in + let apptype = Term.prod_applist gentypes.(0) params in let rc,_ = Reduction.dest_prod env apptype in List.length rc | _ -> raise Not_found @@ -1270,7 +1270,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = let sign = - (prod_assum (prod_applist typ params)) in + (prod_assum (Term.prod_applist typ params)) in find_intro_names sign gls in let constr_args_ids = Array.map f_ids gen_arities in let case_term = diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 79f185d187..60e9196afa 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -54,7 +54,7 @@ let construct_nhyps ind gls = let ind_hyps nevar ind largs gls= let types= Inductiveops.arities_of_constructors (pf_env gls) ind in let myhyps t = - let t1=prod_applist t largs in + let t1=Term.prod_applist t largs in let t2=snd (decompose_prod_n_assum nevar t1) in fst (decompose_prod_assum t2) in Array.map myhyps types diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 0a7938069f..83fc48623c 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1150,7 +1150,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let info_array = Array.mapi (fun i types -> - let types = prod_applist types (List.rev_map var_of_decl princ_params) in + let types = Term.prod_applist types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; name = Nameops.out_name (fresh_id names.(i)); types = types; -- 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. --- plugins/decl_mode/decl_interp.ml | 2 +- plugins/decl_mode/decl_proof_instr.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index 65d273fafb..ddf0137354 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -173,7 +173,7 @@ let get_eq_typ info env = typ let interp_constr_in_type typ env sigma c = - fst (understand env sigma (fst c) ~expected_type:(OfType typ))(*FIXME*) + fst (understand env sigma (fst c) ~expected_type:(OfType (EConstr.of_constr typ)))(*FIXME*) let interp_statement interp_it env sigma st = {st_label=st.st_label; diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index e587fd52ce..5e16d2da0e 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -1330,7 +1330,7 @@ let understand_my_constr env sigma c concl = | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None) | rc -> map_glob_constr frob rc in - Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc) + Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType (EConstr.of_constr concl)) (frob rawc) let my_refine c gls = let oc = { run = begin fun sigma -> -- 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. --- plugins/decl_mode/decl_proof_instr.ml | 2 +- plugins/extraction/extraction.ml | 3 +++ plugins/ssrmatching/ssrmatching.ml4 | 2 +- 3 files changed, 5 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 5e16d2da0e..44cd22c8bb 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -408,7 +408,7 @@ let find_subsubgoal c ctyp skip submetas gls = try let unifier = Unification.w_unify env se.se_evd Reduction.CUMUL - ~flags:(Unification.elim_flags ()) ctyp se.se_type in + ~flags:(Unification.elim_flags ()) (EConstr.of_constr ctyp) (EConstr.of_constr se.se_type) in if n <= 0 then {se with se_evd=meta_assign se.se_meta diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 42a8cac69b..0c4fa70555 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -99,6 +99,9 @@ let is_info_scheme env t = match flag_of_type env t with | (Info, TypeScheme) -> true | _ -> false +let push_rel_assum (n, t) env = + Environ.push_rel (LocalAssum (n, t)) env + (*s [type_sign] gernerates a signature aimed at treating a type application. *) let rec type_sign env c = diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 18aeca6faa..308fb414ee 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -332,7 +332,7 @@ let flags_FO = (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars } let unif_FO env ise p c = - Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c + Unification.w_unify env ise Reduction.CONV ~flags:flags_FO (EConstr.of_constr p) (EConstr.of_constr c) (* Perform evar substitution in main term and prune substitution. *) let nf_open_term sigma0 ise c = -- 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. --- plugins/cc/cctac.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 58454eedfe..11da923e18 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -512,7 +512,7 @@ let f_equal = | _ -> Proofview.tclUNIT () end begin function (e, info) -> match e with - | Type_errors.TypeError _ -> Proofview.tclUNIT () + | Pretype_errors.PretypeError _ | Type_errors.TypeError _ -> Proofview.tclUNIT () | e -> Proofview.tclZERO ~info e end end } -- 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. --- plugins/extraction/extraction.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'plugins') diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 0c4fa70555..6559aeb082 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -599,6 +599,7 @@ let rec extract_term env mle mlt c args = extract_cons_app env mle mlt cp args | Proj (p, c) -> let term = Retyping.expand_projection env (Evd.from_env env) p (EConstr.of_constr c) [] in + let term = EConstr.Unsafe.to_constr term in extract_term env mle mlt term args | Rel n -> (* As soon as the expected [mlt] for the head is known, *) -- cgit v1.2.3 From 7267dfafe9215c35275a39814c8af451961e997c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 17:48:47 +0100 Subject: Goal API using EConstr. --- plugins/decl_mode/decl_proof_instr.ml | 6 +++--- plugins/decl_mode/g_decl_mode.ml4 | 2 +- plugins/setoid_ring/newring.ml | 2 +- plugins/ssrmatching/ssrmatching.ml4 | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 44cd22c8bb..3bb6f1b5d5 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -41,7 +41,7 @@ let clear ids { it = goal; sigma } = let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in let env = Goal.V82.env sigma goal in let sign = Goal.V82.hyps sigma goal in - let cl = Goal.V82.concl sigma goal in + let cl = EConstr.Unsafe.to_constr (Goal.V82.concl sigma goal) in let evdref = ref (Evd.clear_metas sigma) in let (hyps, concl) = try Evarutil.clear_hyps_in_evi env evdref sign cl ids @@ -49,7 +49,7 @@ let clear ids { it = goal; sigma } = user_err (str "Cannot clear " ++ pr_id id) in let sigma = !evdref in - let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in + let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps (EConstr.of_constr concl) (Goal.V82.extra sigma goal) in let sigma = Goal.V82.partial_solution_to sigma goal gl ev in { it = [gl]; sigma } @@ -74,7 +74,7 @@ let tcl_change_info_gen info_gen = let concl = pf_concl gls in let hyps = Goal.V82.hyps (project gls) it in let extra = Goal.V82.extra (project gls) it in - let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in + let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps (EConstr.of_constr concl) (info_gen extra) in let sigma = Goal.V82.partial_solution sigma it ev in { it = [gl] ; sigma= sigma; } ) diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 18a35c6cfb..9e2c9f5973 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -25,7 +25,7 @@ open Ppdecl_proof let pr_goal gs = let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in let env = Goal.V82.env sigma g in - let concl = Goal.V82.concl sigma g in + let concl = EConstr.Unsafe.to_constr (Goal.V82.concl sigma g) in let goal = Printer.pr_context_of env sigma ++ cut () ++ str "============================" ++ cut () ++ diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index b0a3e839b9..089e76d7a0 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -172,7 +172,7 @@ let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = let dummy_goal env sigma = let (gl,_,sigma) = - Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in + Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp Evd.Store.empty in {Evd.it = gl; Evd.sigma = sigma} let constr_of v = match Value.to_constr v with diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 308fb414ee..7f628f1650 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1078,7 +1078,7 @@ END let thin id sigma goal = let ids = Id.Set.singleton id in let env = Goal.V82.env sigma goal in - let cl = Goal.V82.concl sigma goal in + let cl = EConstr.Unsafe.to_constr (Goal.V82.concl sigma goal) in let evdref = ref (Evd.clear_metas sigma) in let ans = try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) @@ -1088,7 +1088,7 @@ let thin id sigma goal = | None -> sigma | Some (hyps, concl) -> let sigma = !evdref in - let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in + let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps (EConstr.of_constr concl) (Goal.V82.extra sigma goal) in let sigma = Goal.V82.partial_solution_to sigma goal gl ev in sigma -- 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. --- plugins/btauto/refl_btauto.ml | 1 + plugins/cc/ccalgo.ml | 4 ++-- plugins/cc/cctac.ml | 11 ++++++----- plugins/decl_mode/decl_proof_instr.ml | 14 +++++++------- plugins/firstorder/instances.ml | 2 +- plugins/firstorder/sequent.ml | 4 ++-- plugins/funind/functional_principles_proofs.ml | 22 ++++++++++++++-------- plugins/funind/indfun.ml | 4 ++-- plugins/funind/invfun.ml | 12 ++++++------ plugins/funind/recdef.ml | 12 ++++++------ plugins/omega/coq_omega.ml | 18 +++++++++--------- plugins/romega/const_omega.ml | 2 +- plugins/ssrmatching/ssrmatching.ml4 | 2 +- 13 files changed, 58 insertions(+), 50 deletions(-) (limited to 'plugins') diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 3ba5da149a..1e49d8cad9 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -179,6 +179,7 @@ module Btauto = struct let print_counterexample p env gl = let var = lapp witness [|p|] in + let var = EConstr.of_constr var in (* Compute an assignment that dissatisfies the goal *) let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in let rec to_list l = match decomp_term (Tacmach.project gl) l with diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index bc53b113df..102efe55bc 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -508,7 +508,7 @@ let rec add_term state t= Not_found -> let b=next uf in let trm = constr_of_term t in - let typ = pf_unsafe_type_of state.gls trm in + let typ = pf_unsafe_type_of state.gls (EConstr.of_constr trm) in let typ = canonize_name typ in let new_node= match t with @@ -832,7 +832,7 @@ let complete_one_class state i= let id = new_state_var etyp state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = pf_unsafe_type_of state.gls - (constr_of_term (term state.uf pac.cnode)) in + (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in let _args = List.map (fun i -> constr_of_term (term state.uf i)) pac.args in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 11da923e18..7c78f3a17c 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -243,7 +243,8 @@ let app_global f args k = let new_app_global f args k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) -let new_refine c = Proofview.V82.tactic (refine c) +let new_refine c = Proofview.V82.tactic (refine (EConstr.of_constr c)) +let refine c = refine (EConstr.of_constr c) let assert_before n c = Proofview.Goal.enter { enter = begin fun gl -> @@ -265,7 +266,7 @@ let refresh_universes ty k = let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> - let type_of t = Tacmach.New.pf_unsafe_type_of gl t in + let type_of t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr t) in try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check c @@ -336,7 +337,7 @@ let refute_tac c t1 t2 p = let neweq= new_app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] - in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k + in refresh_universes (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr tt1)) k end } let refine_exact_check c gl = @@ -354,7 +355,7 @@ let convert_to_goal_tac c t1 t2 p = let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] - in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k + in refresh_universes (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr tt2)) k end } let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -376,7 +377,7 @@ let discriminate_tac (cstr,u as cstru) p = let identity = Universes.constr_of_global (Lazy.force _I) in let trivial = Universes.constr_of_global (Lazy.force _True) in let evm = Tacmach.New.project gl in - let evm, intype = refresh_type env evm (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl t1)) in + let evm, intype = refresh_type env evm (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr t1))) in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 3bb6f1b5d5..031a6253a4 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -491,7 +491,7 @@ let thus_tac c ctyp submetas gls = Proofview.V82.of_tactic (exact_check proof) gls else let refiner = concl_refiner list proof gls in - Tacmach.refine refiner gls + Tacmach.refine (EConstr.of_constr refiner) gls (* general forward step *) @@ -799,7 +799,7 @@ let rec take_tac wits gls = match wits with [] -> tclIDTAC gls | wit::rest -> - let typ = pf_unsafe_type_of gls wit in + let typ = pf_unsafe_type_of gls (EConstr.of_constr wit) in tclTHEN (thus_tac wit typ []) (take_tac rest) gls @@ -879,7 +879,7 @@ let start_tree env ind rp = let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in - let ctyp=pf_unsafe_type_of gls casee in + let ctyp=pf_unsafe_type_of gls (EConstr.of_constr casee) in let is_dep = dependent (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl) in let hd,args = decompose_app (special_whd gls ctyp) in let (ind,u) = @@ -894,7 +894,7 @@ let build_per_info etype casee gls = | _ -> mind.mind_nparams,None in let params,real_args = List.chop nparams args in let abstract_obj c body = - let typ=pf_unsafe_type_of gls c in + let typ=pf_unsafe_type_of gls (EConstr.of_constr c) in lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in let pred= List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl))) in @@ -1256,13 +1256,13 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let nparams = mind.mind_nparams in let concl=pf_concl gls in let env=pf_env gls in - let ctyp=pf_unsafe_type_of gls casee in + let ctyp=pf_unsafe_type_of gls (EConstr.of_constr casee) in let hd,all_args = decompose_app (special_whd gls ctyp) in let ind', u = destInd hd in let _ = assert (eq_ind ind' ind) in (* just in case *) let params,real_args = List.chop nparams all_args in let abstract_obj c body = - let typ=pf_unsafe_type_of gls c in + let typ=pf_unsafe_type_of gls (EConstr.of_constr c) in lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in let elim_pred = List.fold_right abstract_obj real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl))) in @@ -1314,7 +1314,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = execute_cases fix_name per_info tacnext p_args objs nhrec tree] gls0 in tclTHENSV - (refine case_term) + (refine (EConstr.of_constr case_term)) (Array.mapi branch_tac br) gls | Split_patt (_, _, _) , [] -> anomaly ~label:"execute_cases " (Pp.str "Nothing to split") diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 44bdb585a1..6c245063c8 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -104,7 +104,7 @@ let mk_open_instance id idc gl m t= let evmap=Refiner.project gl in let var_id= if id==dummy_id then dummy_bvid else - let typ=pf_unsafe_type_of gl idc in + let typ=pf_unsafe_type_of gl (EConstr.of_constr idc) in (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd (whd_all env evmap (EConstr.of_constr typ)) in diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 1248b60a76..87e7192d78 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -200,7 +200,7 @@ let extend_with_ref_list l seq gl = let l = expand_constructor_hints l in let f gr (seq,gl) = let gl, c = pf_eapply Evd.fresh_global gl gr in - let typ=(pf_unsafe_type_of gl c) in + let typ=(pf_unsafe_type_of gl (EConstr.of_constr c)) in (add_formula Hyp gr typ seq gl,gl) in List.fold_right f l (seq,gl) @@ -215,7 +215,7 @@ let extend_with_auto_hints l seq gl= let (c, _, _) = c in (try let gr = global_of_constr c in - let typ=(pf_unsafe_type_of gl c) in + let typ=(pf_unsafe_type_of gl (EConstr.of_constr c)) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) | _-> () in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 83fc48623c..b674f40e9a 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -202,6 +202,7 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = (List.map mkVar context_hyps) in let to_refine = applist(mkVar h_id,List.rev context_hyps') in + let to_refine = EConstr.of_constr to_refine in refine to_refine g ) ] @@ -329,7 +330,8 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let evm, _ = pf_apply Typing.type_of g (EConstr.of_constr to_refine) in + let to_refine = EConstr.of_constr to_refine in + let evm, _ = pf_apply Typing.type_of g to_refine in tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) in @@ -448,6 +450,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = List.rev_map mkVar (rec_pte_id::context_hyps_ids) ) in + let to_refine = EConstr.of_constr to_refine in (* observe_tac "rec hyp " *) (tclTHENS (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) @@ -497,6 +500,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = List.rev (coq_I::List.map mkVar context_hyps) ) in + let to_refine = (EConstr.of_constr to_refine) in refine to_refine g ) ] @@ -594,7 +598,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) - let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in + let new_term_value_eq = pf_unsafe_type_of g' (EConstr.mkVar heq_id) in (* compute the new value of the body *) let new_term_value = match kind_of_term new_term_value_eq with @@ -605,13 +609,14 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = ); anomaly (Pp.str "cannot compute new term value") in + let term = EConstr.of_constr term in let fun_body = mkLambda(Anonymous, pf_unsafe_type_of g' term, - Termops.replace_term (project g') (EConstr.of_constr term) (EConstr.mkRel 1) (EConstr.of_constr dyn_infos.info) + Termops.replace_term (project g') term (EConstr.mkRel 1) (EConstr.of_constr dyn_infos.info) ) in - let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in + let new_body = pf_nf_betaiota g' (EConstr.of_constr (mkApp(fun_body,[| new_term_value |]))) in let new_infos = {dyn_infos with info = new_body; @@ -700,7 +705,7 @@ let build_proof let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in - let type_of_term = pf_unsafe_type_of g t in + let type_of_term = pf_unsafe_type_of g (EConstr.of_constr t) in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in @@ -741,7 +746,7 @@ let build_proof let id = pf_last_hyp g' |> get_id in let new_term = pf_nf_betaiota g' - (mkApp(dyn_infos.info,[|mkVar id|])) + (EConstr.of_constr (mkApp(dyn_infos.info,[|mkVar id|]))) in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = @@ -908,6 +913,7 @@ let prove_rec_hyp_for_struct fix_info = let rec_hyp_proof = mkApp(mkVar fix_info.name,array_get_start pte_args) in + let rec_hyp_proof = EConstr.of_constr rec_hyp_proof in refine rec_hyp_proof g )) @@ -921,7 +927,7 @@ let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in - let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in + let hyp_typ = pf_unsafe_type_of g (EConstr.mkVar hyp) in let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> @@ -1418,7 +1424,7 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (pf_unsafe_type_of gls (mkVar hrec)) in + let _,hrec_concl = decompose_prod (pf_unsafe_type_of gls (EConstr.mkVar hrec)) in let f_app = Array.last (snd (destApp hrec_concl)) in let f = (fst (destApp f_app)) in let rec backtrack : tactic = diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 0743fc5d92..e3ba522467 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -75,11 +75,11 @@ let functional_induction with_clean c princl pat = user_err (str "Cannot find induction principle for " ++Printer.pr_lconstr (mkConst c') ) in - (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') + (princ,NoBindings, Tacmach.pf_unsafe_type_of g' (EConstr.of_constr princ),g') | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_unsafe_type_of g princ,g + princ,binding,Tacmach.pf_unsafe_type_of g (EConstr.of_constr princ),g in let princ_infos = Tactics.compute_elim_sig princ_type in let args_as_induction_constr = diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index e5286fb1fd..6359255626 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -305,7 +305,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_unsafe_type_of g (mkVar hid) in + let type_of_hid = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term type_of_hid with | Prod(_,_,t') -> begin @@ -596,7 +596,7 @@ let rec reflexivity_with_destruct_cases g = match sc with None -> tclIDTAC g | Some id -> - match kind_of_term (pf_unsafe_type_of g (mkVar id)) with + match kind_of_term (pf_unsafe_type_of g (EConstr.mkVar id)) with | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g @@ -661,7 +661,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in - let princ_type = pf_unsafe_type_of g graph_principle in + let princ_type = pf_unsafe_type_of g (EConstr.of_constr graph_principle) in let princ_infos = Tactics.compute_elim_sig princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them @@ -919,7 +919,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = - let typ = pf_unsafe_type_of g (mkVar hid) in + let typ = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term typ with | App(i,args) when isInd i -> let ((kn',num) as ind'),u = destInd i in @@ -970,7 +970,7 @@ let revert_graph kn post_tac hid g = let functional_inversion kn hid fconst f_correct : tactic = fun g -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in - let type_of_h = pf_unsafe_type_of g (mkVar hid) in + let type_of_h = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term type_of_h with | App(eq,args) when eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = @@ -1022,7 +1022,7 @@ let invfun qhyp f g = Proofview.V82.of_tactic begin Tactics.try_intros_until (fun hid -> Proofview.V82.tactic begin fun g -> - let hyp_typ = pf_unsafe_type_of g (mkVar hid) in + let hyp_typ = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term hyp_typ with | App(eq,args) when eq_constr eq (make_eq ()) -> begin diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index bdbf0242d7..b2c93a7540 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -117,7 +117,7 @@ let pf_get_new_ids idl g = let compute_renamed_type gls c = rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] - (pf_unsafe_type_of gls c) + (pf_unsafe_type_of gls (EConstr.of_constr c)) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" @@ -402,7 +402,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> - let ty_teq = pf_unsafe_type_of g' (mkVar heq) in + let ty_teq = pf_unsafe_type_of g' (EConstr.mkVar heq) in let teq_lhs,teq_rhs = let _,args = try destApp ty_teq with DestKO -> assert false in args.(1),args.(2) @@ -516,13 +516,13 @@ let rec prove_lt hyple g = in let h = List.find (fun id -> - match decompose_app (pf_unsafe_type_of g (mkVar id)) with + match decompose_app (pf_unsafe_type_of g (EConstr.mkVar id)) with | _, t::_ -> eq_constr t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (mkVar h))))) in + List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (EConstr.mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) @@ -684,7 +684,7 @@ let mkDestructEq : if Id.List.mem id not_on_hyp || not (Termops.occur_term (project g) (EConstr.of_constr expr) (EConstr.of_constr (get_type decl))) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let type_of_expr = pf_unsafe_type_of g expr in + let type_of_expr = pf_unsafe_type_of g (EConstr.of_constr expr) in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> @@ -839,7 +839,7 @@ let rec prove_le g = let matching_fun = pf_is_matching g (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in - let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) + let (h,t) = List.find (fun (_,t) -> matching_fun (EConstr.of_constr t)) (pf_hyps_types g) in let y = let _,args = decompose_app t in diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index d15449aef9..b832250a51 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -568,7 +568,7 @@ let abstract_path typ path t = mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = - let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in + let newc = context (fun i t -> pf_nf gl (EConstr.of_constr t)) (List.rev path) (pf_concl gl) in Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl let focused_simpl path = focused_simpl path @@ -644,7 +644,7 @@ let clever_rewrite_base_poly typ p result theorem gl = [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), [abstracted]) in - exact (applist(t,[mkNewMeta()])) gl + exact (EConstr.of_constr (applist(t,[mkNewMeta()]))) gl let clever_rewrite_base p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl @@ -665,7 +665,7 @@ let clever_rewrite p vpath t gl = let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurrence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in - exact (applist(t',[mkNewMeta()])) gl + exact (EConstr.of_constr (applist(t',[mkNewMeta()]))) gl let rec shuffle p (t1,t2) = match t1,t2 with @@ -1384,7 +1384,7 @@ let destructure_omega gl tac_def (id,c) = else try match destructurate_prop c with | Kapp(Eq,[typ;t1;t2]) - when begin match destructurate_type (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end -> + when begin match destructurate_type (pf_nf gl (EConstr.of_constr typ)) with Kapp(Z,[]) -> true | _ -> false end -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def @@ -1659,7 +1659,7 @@ let rec decidability gl t = | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type (pf_nf gl typ) with + begin match destructurate_type (pf_nf gl (EConstr.of_constr typ)) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable @@ -1720,7 +1720,7 @@ let destructure_hyps = | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if is_Prop (type_of t2) + if is_Prop (type_of (EConstr.of_constr t2)) then let d1 = decidability t1 in Tacticals.New.tclTHENLIST [ @@ -1789,7 +1789,7 @@ let destructure_hyps = with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin - match destructurate_type (pf_nf typ) with + match destructurate_type (pf_nf (EConstr.of_constr typ)) with | Kapp(Nat,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim @@ -1806,7 +1806,7 @@ let destructure_hyps = ] | _ -> loop lit end else begin - match destructurate_type (pf_nf typ) with + match destructurate_type (pf_nf (EConstr.of_constr typ)) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) @@ -1849,7 +1849,7 @@ let destructure_goal = let dec = decidability t in Tacticals.New.tclTHEN (Proofview.V82.tactic (Tacmach.refine - (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))) + (EConstr.of_constr (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))) intro with Undecidable -> Tactics.elim_type (build_coq_False ()) in diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 4935fe4bbc..f2d91bad37 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -353,7 +353,7 @@ let parse_term t = let parse_rel gl t = try match destructurate t with | Kapp("eq",[typ;t1;t2]) - when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) + when destructurate (Tacmach.pf_nf gl (EConstr.of_constr typ)) = Kapp("Z",[]) -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 7f628f1650..ace557a52a 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1390,7 +1390,7 @@ let ssrpatterntac _ist (arg_ist,arg) gl = let concl0 = pf_concl gl in let (t, uc), concl_x = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in - let gl, tty = pf_type_of gl t in + let gl, tty = pf_type_of gl (EConstr.of_constr t) in let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl -- cgit v1.2.3 From 771be16883c8c47828f278ce49545716918764c4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 12 Nov 2016 01:52:15 +0100 Subject: Hipattern API using EConstr. --- plugins/firstorder/formula.ml | 17 +++++++++-------- plugins/funind/invfun.ml | 4 ++-- 2 files changed, 11 insertions(+), 10 deletions(-) (limited to 'plugins') diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 60e9196afa..96b991e1fd 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -79,15 +79,16 @@ type kind_of_formula= let kind_of_formula gl term = let normalize=special_nf gl in let cciterm=special_whd gl term in - match match_with_imp_term (project gl) cciterm with - Some (a,b)-> Arrow(a,(pop (EConstr.of_constr b))) + match match_with_imp_term (project gl) (EConstr.of_constr cciterm) with + Some (a,b)-> Arrow(EConstr.Unsafe.to_constr a,(pop b)) |_-> - match match_with_forall_term (project gl) cciterm with - Some (_,a,b)-> Forall(a,b) + match match_with_forall_term (project gl) (EConstr.of_constr cciterm) with + Some (_,a,b)-> Forall(EConstr.Unsafe.to_constr a,EConstr.Unsafe.to_constr b) |_-> - match match_with_nodep_ind (project gl) cciterm with + match match_with_nodep_ind (project gl) (EConstr.of_constr cciterm) with Some (i,l,n)-> - let ind,u=destInd i in + let l = List.map EConstr.Unsafe.to_constr l in + let ind,u=EConstr.destInd (project gl) i in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in if Int.equal nconstr 0 then @@ -108,8 +109,8 @@ let kind_of_formula gl term = else Or((ind,u),l,is_trivial) | _ -> - match match_with_sigma_type (project gl) cciterm with - Some (i,l)-> Exists((destInd i),l) + match match_with_sigma_type (project gl) (EConstr.of_constr cciterm) with + Some (i,l)-> Exists((EConstr.destInd (project gl) i),List.map EConstr.Unsafe.to_constr l) |_-> Atom (normalize cciterm) type atoms = {positive:constr list;negative:constr list} diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 6359255626..b2419b1a5d 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -598,9 +598,9 @@ let rec reflexivity_with_destruct_cases g = | Some id -> match kind_of_term (pf_unsafe_type_of g (EConstr.mkVar id)) with | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) t1 t2 + if Equality.discriminable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) t1 t2 + else if Equality.injectable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g -- 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. --- plugins/btauto/refl_btauto.ml | 3 +- plugins/cc/cctac.ml | 20 ++++--- plugins/decl_mode/decl_proof_instr.ml | 37 +++++++----- plugins/decl_mode/decl_proof_instr.mli | 2 +- plugins/firstorder/instances.ml | 18 +++--- plugins/firstorder/rules.ml | 27 +++++---- plugins/fourier/fourierR.ml | 31 ++++++---- plugins/funind/functional_principles_proofs.ml | 42 +++++++------ plugins/funind/functional_principles_types.ml | 10 ++-- plugins/funind/g_indfun.ml4 | 10 ++-- plugins/funind/indfun.ml | 7 ++- plugins/funind/invfun.ml | 44 +++++++------- plugins/funind/merge.ml | 9 +-- plugins/funind/recdef.ml | 83 +++++++++++++------------- plugins/micromega/coq_micromega.ml | 14 ++--- plugins/nsatz/nsatz.ml | 1 + plugins/omega/coq_omega.ml | 39 ++++++------ plugins/quote/quote.ml | 4 +- plugins/romega/refl_omega.ml | 9 +-- plugins/rtauto/refl_tauto.ml | 1 + plugins/ssrmatching/ssrmatching.ml4 | 1 + 21 files changed, 229 insertions(+), 183 deletions(-) (limited to 'plugins') diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 1e49d8cad9..27398cf65a 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -249,9 +249,10 @@ module Btauto = struct let fl = reify env fl in let fr = reify env fr in let changed_gl = Term.mkApp (c, [|typ; fl; fr|]) in + let changed_gl = EConstr.of_constr changed_gl in Tacticals.New.tclTHENLIST [ Tactics.change_concl changed_gl; - Tactics.apply (Lazy.force soundness); + Tactics.apply (EConstr.of_constr (Lazy.force soundness)); Tactics.normalise_vm_in_concl; try_unification env ] diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7c78f3a17c..7b023413d6 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -238,17 +238,17 @@ let build_projection intype (cstr:pconstructor) special default gls= let _M =mkMeta let app_global f args k = - Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) + Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (EConstr.of_constr (mkApp (fc, args)))) let new_app_global f args k = - Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) + Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (EConstr.of_constr (mkApp (fc, args)))) -let new_refine c = Proofview.V82.tactic (refine (EConstr.of_constr c)) -let refine c = refine (EConstr.of_constr c) +let new_refine c = Proofview.V82.tactic (refine c) +let refine c = refine c let assert_before n c = Proofview.Goal.enter { enter = begin fun gl -> - let evm, _ = Tacmach.New.pf_apply type_of gl (EConstr.of_constr c) in + let evm, _ = Tacmach.New.pf_apply type_of gl c in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) end } @@ -269,7 +269,7 @@ let rec proof_tac p : unit Proofview.tactic = let type_of t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr t) in try (* type_of can raise exceptions *) match p.p_rule with - Ax c -> exact_check c + Ax c -> exact_check (EConstr.of_constr c) | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in @@ -333,6 +333,7 @@ let refute_tac c t1 t2 p = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in + let false_t = EConstr.of_constr false_t in let k intype = let neweq= new_app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) @@ -341,7 +342,7 @@ let refute_tac c t1 t2 p = end } let refine_exact_check c gl = - let evm, _ = pf_apply type_of gl (EConstr.of_constr c) in + let evm, _ = pf_apply type_of gl c in Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl let convert_to_goal_tac c t1 t2 p = @@ -363,6 +364,8 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = let tt2=constr_of_term t2 in let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in let false_t=mkApp (c2,[|mkVar h|]) in + let false_t = EConstr.of_constr false_t in + let tt2 = EConstr.of_constr tt2 in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] @@ -387,6 +390,7 @@ let discriminate_tac (cstr,u as cstru) p = [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = injt (fun injt -> + let injt = EConstr.Unsafe.to_constr injt in app_global _eq_rect [|outtype;trivial;pred;identity;concl;injt|] k) in let neweq=new_app_global _eq [|intype;t1;t2|] in @@ -486,7 +490,7 @@ let mk_eq f c1 c2 k = let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm (EConstr.of_constr term) in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) - (k term) + (k (EConstr.of_constr term)) end }) let f_equal = diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 031a6253a4..54206aa955 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -130,7 +130,7 @@ let clean_tmp gls = clean_all (tmp_ids gls) gls let assert_postpone id t = - assert_before (Name id) t + assert_before (Name id) (EConstr.of_constr t) (* start a proof *) @@ -268,6 +268,7 @@ let add_justification_hyps keep items gls = | _ -> let id=pf_get_new_id local_hyp_prefix gls in keep:=Id.Set.add id !keep; + let c = EConstr.of_constr c in tclTHEN (Proofview.V82.of_tactic (letin_tac None (Names.Name id) c None Locusops.nowhere)) (Proofview.V82.of_tactic (clear_body [id])) gls in tclMAP add_aux items gls @@ -488,6 +489,7 @@ let thus_tac c ctyp submetas gls = with Not_found -> error "I could not relate this statement to the thesis." in if List.is_empty list then + let proof = EConstr.of_constr proof in Proofview.V82.of_tactic (exact_check proof) gls else let refiner = concl_refiner list proof gls in @@ -546,7 +548,7 @@ let decompose_eq id gls = let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> - if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 + if Term.eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then (args.(0), args.(1), args.(2)) @@ -584,15 +586,15 @@ let instr_rew _thus rew_side cut gls0 = let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info - (tclTHENS (Proofview.V82.of_tactic (transitivity lhs)) - [just_tac;Proofview.V82.of_tactic (exact_check (mkVar last_id))]); + (tclTHENS (Proofview.V82.of_tactic (transitivity (EConstr.of_constr lhs))) + [just_tac;Proofview.V82.of_tactic (exact_check (EConstr.mkVar last_id))]); thus_tac new_eq] gls0 | Rhs -> let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info - (tclTHENS (Proofview.V82.of_tactic (transitivity rhs)) - [Proofview.V82.of_tactic (exact_check (mkVar last_id));just_tac]); + (tclTHENS (Proofview.V82.of_tactic (transitivity (EConstr.of_constr rhs))) + [Proofview.V82.of_tactic (exact_check (EConstr.mkVar last_id));just_tac]); thus_tac new_eq] gls0 @@ -772,7 +774,7 @@ let rec consider_match may_intro introduced available expected gls = try conjunction_arity id gls with Not_found -> error "Matching hypothesis not found." in tclTHENLIST - [Proofview.V82.of_tactic (simplest_case (mkVar id)); + [Proofview.V82.of_tactic (simplest_case (EConstr.mkVar id)); intron_then nhyps [] (fun l -> consider_match may_intro introduced (List.rev_append l rest_ids) expected)] gls) @@ -780,7 +782,8 @@ let rec consider_match may_intro introduced available expected gls = gls let consider_tac c hyps gls = - match kind_of_term (strip_outer_cast (project gls) (EConstr.of_constr c)) with + let c = EConstr.of_constr c in + match kind_of_term (strip_outer_cast (project gls) c) with Var id -> consider_match false [] [id] hyps gls | _ -> @@ -817,6 +820,7 @@ let rec build_function sigma args body = let define_tac id args body gls = let t = build_function (project gls) args body in + let t = EConstr.of_constr t in Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls (* tactics for reconsider *) @@ -828,6 +832,7 @@ let cast_tac id_or_thesis typ gls = | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> + let typ = EConstr.of_constr typ in Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls (* per cases *) @@ -1087,7 +1092,7 @@ let thesis_for obj typ per_info env= ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = List.chop per_info.per_nparams all_args in - let _ = if not (List.for_all2 eq_constr params per_info.per_params) then + let _ = if not (List.for_all2 Term.eq_constr params per_info.per_params) then user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in @@ -1219,10 +1224,10 @@ let hrec_for fix_id per_info gls obj_id = let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind); let params,args= List.chop per_info.per_nparams all_args in assert begin - try List.for_all2 eq_constr params per_info.per_params with + try List.for_all2 Term.eq_constr params per_info.per_params with Invalid_argument _ -> false end; let hd2 = applist (mkVar fix_id,args@[obj]) in - compose_lam rc (Reductionops.whd_beta gls.sigma (EConstr.of_constr hd2)) + EConstr.of_constr (compose_lam rc (Reductionops.whd_beta gls.sigma (EConstr.of_constr hd2))) let warn_missing_case = CWarnings.create ~name:"declmode-missing-case" ~category:"declmode" @@ -1336,7 +1341,7 @@ let my_refine c gls = let oc = { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in - Sigma.Unsafe.of_pair (c, sigma) + Sigma.Unsafe.of_pair (EConstr.of_constr c, sigma) end } in Proofview.V82.of_tactic (Tactics.New.refine oc) gls @@ -1366,14 +1371,14 @@ let end_tac et2 gls = begin match et,ek with _,EK_unknown -> - tclSOLVE [Proofview.V82.of_tactic (simplest_elim pi.per_casee)] + tclSOLVE [Proofview.V82.of_tactic (simplest_elim (EConstr.of_constr pi.per_casee))] | ET_Case_analysis,EK_nodep -> tclTHEN - (Proofview.V82.of_tactic (simplest_case pi.per_casee)) + (Proofview.V82.of_tactic (simplest_case (EConstr.of_constr pi.per_casee))) (default_justification (List.map mkVar clauses)) | ET_Induction,EK_nodep -> tclTHENLIST - [Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee])); + [Proofview.V82.of_tactic (generalize (List.map EConstr.of_constr (pi.per_args@[pi.per_casee]))); Proofview.V82.of_tactic (simple_induct (AnonHyp (succ (List.length pi.per_args)))); default_justification (List.map mkVar clauses)] | ET_Case_analysis,EK_dep tree -> @@ -1385,7 +1390,7 @@ let end_tac et2 gls = (initial_instance_stack clauses) [pi.per_casee] 0 tree | ET_Induction,EK_dep tree -> let nargs = (List.length pi.per_args) in - tclTHEN (Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee]))) + tclTHEN (Proofview.V82.of_tactic (generalize (List.map EConstr.of_constr (pi.per_args@[pi.per_casee])))) begin fun gls0 -> let fix_id = diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli index 325969dadb..ba196ff01b 100644 --- a/plugins/decl_mode/decl_proof_instr.mli +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -89,7 +89,7 @@ val push_arg : Term.constr -> val hrec_for: Id.t -> Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> - Id.t -> Term.constr + Id.t -> EConstr.constr val consider_match : bool -> diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 6c245063c8..a320b47aa3 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -117,6 +117,7 @@ let mk_open_instance id idc gl m t= let nid=(fresh_id avoid var_id gl) in let evmap = Sigma.Unsafe.of_evar_map evmap in let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + let c = EConstr.Unsafe.to_constr c in let evmap = Sigma.to_evar_map evmap in let decl = LocalAssum (Name nid, c) in aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in @@ -131,13 +132,13 @@ let left_instance_tac (inst,id) continue seq= if lookup (id,None) seq then tclFAIL 0 (Pp.str "already done") else - tclTHENS (Proofview.V82.of_tactic (cut dom)) + tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr dom))) [tclTHENLIST [Proofview.V82.of_tactic introf; pf_constr_of_global id (fun idc -> (fun gls-> Proofview.V82.of_tactic (generalize - [mkApp(idc, - [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])]) gls)); + [EConstr.of_constr (mkApp(idc, + [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|]))]) gls)); Proofview.V82.of_tactic introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; @@ -154,14 +155,15 @@ let left_instance_tac (inst,id) continue seq= let gt= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in + let gt = EConstr.of_constr gt in let evmap, _ = - try Typing.type_of (pf_env gl) evmap (EConstr.of_constr gt) + try Typing.type_of (pf_env gl) evmap gt with e when CErrors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl) else pf_constr_of_global id (fun idc -> - Proofview.V82.of_tactic (generalize [mkApp(idc,[|t|])])) + Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(idc,[|t|]))])) in tclTHENLIST [special_generalize; @@ -172,16 +174,16 @@ let left_instance_tac (inst,id) continue seq= let right_instance_tac inst continue seq= match inst with Phantom dom -> - tclTHENS (Proofview.V82.of_tactic (cut dom)) + tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr dom))) [tclTHENLIST [Proofview.V82.of_tactic introf; (fun gls-> Proofview.V82.of_tactic (split (ImplicitBindings - [mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls); + [EConstr.mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY (Proofview.V82.of_tactic assumption)] | Real ((0,t),_) -> - (tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [t]))) + (tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr t]))) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 1d107e9afe..bed7a727f7 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -59,7 +59,7 @@ let clear_global=function (* connection rules *) let axiom_tac t seq= - try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check c)) + try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check (EConstr.of_constr c))) with Not_found->tclFAIL 0 (Pp.str "No axiom link") let ll_atom_tac a backtrack id continue seq= @@ -68,7 +68,7 @@ let ll_atom_tac a backtrack id continue seq= tclTHENLIST [pf_constr_of_global (find_left a seq) (fun left -> pf_constr_of_global id (fun id -> - Proofview.V82.of_tactic (generalize [mkApp(id, [|left|])]))); + Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(id, [|left|]))]))); clear_global id; Proofview.V82.of_tactic intro] with Not_found->tclFAIL 0 (Pp.str "No link")) @@ -95,7 +95,7 @@ let left_and_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (tclTHENLIST - [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim); + [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim)); clear_global id; tclDO n (Proofview.V82.of_tactic intro)]) (wrap n false continue seq) @@ -109,12 +109,12 @@ let left_or_tac ind backtrack id continue seq gls= tclDO n (Proofview.V82.of_tactic intro); wrap n false continue seq] in tclIFTHENSVELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim))) (Array.map f v) backtrack gls let left_false_tac id= - Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim) + Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim)) (* left arrow connective rules *) @@ -131,7 +131,7 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= let vars=Array.init p (fun j->mkRel (p-j)) in let capply=mkApp ((lift p cstr),vars) in let head=mkApp ((lift p idc),[|capply|]) in - it_mkLambda_or_LetIn head rc in + EConstr.of_constr (it_mkLambda_or_LetIn head rc) in let lp=Array.length rcs in let newhyps idc =List.init lp (myterm idc) in tclIFTHENELSE @@ -143,16 +143,16 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= let ll_arrow_tac a b c backtrack id continue seq= let cc=mkProd(Anonymous,a,(lift 1 b)) in - let d idc =mkLambda (Anonymous,b, - mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in + let d idc =EConstr.of_constr (mkLambda (Anonymous,b, + mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|]))) in tclORELSE - (tclTHENS (Proofview.V82.of_tactic (cut c)) + (tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr c))) [tclTHENLIST [Proofview.V82.of_tactic introf; clear_global id; wrap 1 false continue seq]; - tclTHENS (Proofview.V82.of_tactic (cut cc)) - [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check c)); + tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr cc))) + [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check (EConstr.of_constr c))); tclTHENLIST [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [d idc])); clear_global id; @@ -177,7 +177,7 @@ let forall_tac backtrack continue seq= let left_exists_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim))) (tclTHENLIST [clear_global id; tclDO n (Proofview.V82.of_tactic intro); (wrap (n-1) false continue seq)]) @@ -186,13 +186,14 @@ let left_exists_tac ind backtrack id continue seq gls= let ll_forall_tac prod backtrack id continue seq= tclORELSE - (tclTHENS (Proofview.V82.of_tactic (cut prod)) + (tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr prod))) [tclTHENLIST [Proofview.V82.of_tactic intro; pf_constr_of_global id (fun idc -> (fun gls-> let id0=pf_nth_hyp_id gls 1 in let term=mkApp(idc,[|mkVar(id0)|]) in + let term = EConstr.of_constr term in tclTHEN (Proofview.V82.of_tactic (generalize [term])) (Proofview.V82.of_tactic (clear [id0])) gls)); clear_global id; Proofview.V82.of_tactic intro; diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index a14ec8a2ca..fa64b276c8 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -281,6 +281,8 @@ let fourier_lineq lineq1 = (* Defined constants *) let get = Lazy.force +let cget = get +let eget c = EConstr.of_constr (Lazy.force c) let constant = Coqlib.gen_constant "Fourier" (* Standard library *) @@ -373,6 +375,7 @@ let rational_to_real x = (* preuve que 0 False *) let tac_zero_inf_false gl (n,d) = - if n=0 then (apply (get coq_Rnot_lt0)) + let get = eget in +if n=0 then (apply (get coq_Rnot_lt0)) else (Tacticals.New.tclTHEN (apply (get coq_Rle_not_lt)) (tac_zero_infeq_pos gl (-n,d))) @@ -408,6 +413,7 @@ let tac_zero_inf_false gl (n,d) = (* preuve que 0<=(-n)*(1/d) => False *) let tac_zero_infeq_false gl (n,d) = + let get = eget in (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) (tac_zero_inf_pos gl (-n,d))) ;; @@ -415,7 +421,8 @@ let tac_zero_infeq_false gl (n,d) = let exact = exact_check;; let tac_use h = - let tac = exact h.hname in + let get = eget in + let tac = exact (EConstr.of_constr h.hname) in match h.htype with "Rlt" -> tac |"Rle" -> tac @@ -470,6 +477,7 @@ let rec fourier () = try match (kind_of_term goal) with App (f,args) -> + let get = eget in (match (string_of_R_constr f) with "Rlt" -> (Tacticals.New.tclTHEN @@ -548,6 +556,7 @@ let rec fourier () = !t2 |] in let tc=rational_to_real cres in (* puis sa preuve *) + let get = eget in let tac1=ref (if h1.hstrict then (Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt)) [tac_use h1; @@ -584,29 +593,29 @@ let rec fourier () = then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in - tac:=(Tacticals.New.tclTHENS (cut ineq) + tac:=(Tacticals.New.tclTHENS (cut (EConstr.of_constr ineq)) [Tacticals.New.tclTHEN (change_concl - (mkAppL [| get coq_not; ineq|] - )) + (EConstr.of_constr (mkAppL [| cget coq_not; ineq|] + ))) (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt else get coq_Rnot_le_le)) (Tacticals.New.tclTHENS (Equality.replace - (mkAppL [|get coq_Rminus;!t2;!t1|] + (mkAppL [|cget coq_Rminus;!t2;!t1|] ) tc) [tac2; (Tacticals.New.tclTHENS (Equality.replace - (mkApp (get coq_Rinv, - [|get coq_R1|])) - (get coq_R1)) + (mkApp (cget coq_Rinv, + [|cget coq_R1|])) + (cget coq_R1)) (* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) [Tacticals.New.tclORELSE (* TODO : Ring.polynom []*) (Proofview.tclUNIT ()) (Proofview.tclUNIT ()); - Tacticals.New.pf_constr_of_global (get coq_sym_eqT) (fun symeq -> - (Tacticals.New.tclTHEN (apply symeq) + Tacticals.New.pf_constr_of_global (cget coq_sym_eqT) (fun symeq -> + (Tacticals.New.tclTHEN (apply (EConstr.of_constr symeq)) (apply (get coq_Rinv_1))))] ) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b674f40e9a..503cafdd50 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -175,6 +175,7 @@ let is_incompatible_eq t = res let change_hyp_with_using msg hyp_id t tac : tactic = + let t = EConstr.of_constr t in fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS @@ -451,6 +452,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ) in let to_refine = EConstr.of_constr to_refine in + let t_x = EConstr.of_constr t_x in (* observe_tac "rec hyp " *) (tclTHENS (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) @@ -644,7 +646,8 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g (EConstr.of_constr c) in + let c = EConstr.of_constr c in + let evm, _ = pf_apply Typing.type_of g c in tclTHENLIST[ Refiner.tclEVARS evm; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); @@ -709,13 +712,14 @@ let build_proof let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in + let term_eq = EConstr.of_constr term_eq in tclTHENSEQ [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); + Proofview.V82.of_tactic (generalize (term_eq::(List.map EConstr.mkVar dyn_infos.rec_hyps))); thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); + Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],EConstr.of_constr t] None); (fun g -> observe_tac "toto" ( - tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); + tclTHENSEQ [Proofview.V82.of_tactic (Simple.case (EConstr.of_constr t)); (fun g' -> let g'_nb_prod = nb_prod (project g') (EConstr.of_constr (pf_concl g')) in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in @@ -942,7 +946,7 @@ let generalize_non_dep hyp g = in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) + ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar to_revert) ))) ((* observe_tac "thin" *) (thin to_revert)) g @@ -950,7 +954,7 @@ let id_of_decl = RelDecl.get_name %> Nameops.out_name let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN - (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) + (Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar idl))) (thin idl) let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = @@ -991,7 +995,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); + observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (EConstr.mkVar rec_id))); (Proofview.V82.of_tactic intros_reflexivity)] g ) ] @@ -1064,10 +1068,11 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = fun g -> let princ_type = pf_concl g in + let princ_type = EConstr.of_constr princ_type in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig princ_type in + let princ_info = compute_elim_sig (project g) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps g) in (fun na -> @@ -1227,7 +1232,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam | _, this_fix_info::others_infos -> let other_fix_infos = List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) + (fun fi -> fi.name,fi.idx + 1 ,EConstr.of_constr fi.types) (pre_info@others_infos) in if List.is_empty other_fix_infos @@ -1462,11 +1467,11 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) + (Proofview.V82.of_tactic (apply (EConstr.mkVar hrec))) [ tclTHENSEQ [ (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); + (Proofview.V82.of_tactic (apply (EConstr.of_constr (Lazy.force acc_inv)))); (fun g -> if is_mes then @@ -1482,7 +1487,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (EConstr.of_constr (Lazy.force refl_equal)) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ) ) @@ -1518,7 +1523,8 @@ let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in - let princ_info = compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_info = compute_elim_sig (project gl) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps gl) in fun na -> @@ -1572,7 +1578,7 @@ let prove_principle_for_gen Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map EConstr.mkVar l))) (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = @@ -1580,12 +1586,12 @@ let prove_principle_for_gen (tclCOMPLETE (tclTHEN (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) + (EConstr.of_constr (mkApp (delayed_force well_founded,[|input_type;relation|]))) (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) ( (* observe_tac *) (* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) + Proofview.V82.of_tactic (Tactics.Simple.apply (EConstr.of_constr (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])))) ) ) ) @@ -1596,7 +1602,7 @@ let prove_principle_for_gen let lemma = match !tcc_lemma_ref with | None -> error "No tcc proof !!" - | Some lemma -> lemma + | Some lemma -> EConstr.of_constr lemma in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1644,7 +1650,7 @@ let prove_principle_for_gen ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (EConstr.of_constr (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))) (Proofview.V82.tactic prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 4b47b83afb..4d88f9f915 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -28,7 +28,8 @@ let observe s = a functional one *) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = - let princ_type_info = compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_type_info = compute_elim_sig Evd.empty princ_type (** FIXME *) in let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in @@ -89,7 +90,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (Option.fold_right mkProd_or_LetIn princ_type_info.indarg - princ_type_info.concl + (EConstr.Unsafe.to_constr princ_type_info.concl) ) princ_type_info.args ) @@ -243,7 +244,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in - let princ_info = compute_elim_sig princ in + let princ = EConstr.of_constr princ in + let princ_info = compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum (get_name decl, @@ -270,7 +272,7 @@ let change_property_sort evd toSort princ princName = let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + let mutr_nparams = (compute_elim_sig !evd (EConstr.of_constr old_princ_type)).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 6603a95a84..a6f971703d 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -58,7 +58,7 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = | None -> mt () | Some b -> let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in - spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) + spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed (EConstr.Unsafe.to_constr %> prc) (EConstr.Unsafe.to_constr %> prlc) b) ARGUMENT EXTEND fun_ind_using @@ -97,7 +97,9 @@ ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [] ->[ None ] END - +let functional_induction b c x pat = + let x = Option.map (Miscops.map_with_bindings EConstr.Unsafe.to_constr) x in + Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) TACTIC EXTEND newfunind @@ -108,7 +110,7 @@ TACTIC EXTEND newfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] END (***** debug only ***) TACTIC EXTEND snewfunind @@ -119,7 +121,7 @@ TACTIC EXTEND snewfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] END diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index e3ba522467..37a76bec1c 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -81,7 +81,8 @@ let functional_induction with_clean c princl pat = | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g (EConstr.of_constr princ),g in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in let args_as_induction_constr = let c_list = if princ_infos.Tactics.farg_in_concl @@ -89,9 +90,11 @@ let functional_induction with_clean c princl pat = in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) + List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((EConstr.of_constr c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in + let princ = EConstr.of_constr princ in + let bindings = Miscops.map_bindings EConstr.of_constr bindings in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index b2419b1a5d..36fb6dad3d 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -252,7 +252,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta (EConstr.of_constr princ_type) in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in @@ -315,7 +316,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes match kind_of_term t'',kind_of_term t''' with | App(eq,args), App(graph',_) when - (eq_constr eq eq_ind) && + (Term.eq_constr eq eq_ind) && Array.exists (Constr.eq_constr_nounivs graph') graphs_constr -> (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::acc) @@ -387,7 +388,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); (* Conclusion *) observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) + Proofview.V82.of_tactic (exact_check (EConstr.of_constr (app_constructor g))) g) ] ) g @@ -440,7 +441,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes observe_tac "principle" (Proofview.V82.of_tactic (assert_by (Name principle_id) princ_type - (exact_check f_principle))); + (exact_check (EConstr.of_constr f_principle)))); observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) observe_tac "idtac" tclIDTAC; @@ -450,7 +451,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun gl -> let term = mkApp (mkVar principle_id,Array.of_list bindings) in let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl (EConstr.of_constr term) in - Proofview.V82.of_tactic (apply term) gl') + Proofview.V82.of_tactic (apply (EConstr.of_constr term)) gl') )) (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) ] @@ -467,7 +468,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | LocalAssum (id,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -495,7 +496,7 @@ and intros_with_rewrite_aux : tactic = | Prod(_,t,t') -> begin match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> + | App(eq,args) when (Term.eq_constr eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) (EConstr.of_constr args.(1)) (EConstr.of_constr args.(2)) then let id = pf_get_new_id (Id.of_string "y") g in @@ -541,11 +542,11 @@ and intros_with_rewrite_aux : tactic = intros_with_rewrite ] g end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + | Ind _ when Term.eq_constr t (Coqlib.build_coq_False ()) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ - Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr v)); intros_with_rewrite ] g | LetIn _ -> @@ -582,7 +583,7 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ - Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr v)); Proofview.V82.of_tactic intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] @@ -597,7 +598,7 @@ let rec reflexivity_with_destruct_cases g = None -> tclIDTAC g | Some id -> match kind_of_term (pf_unsafe_type_of g (EConstr.mkVar id)) with - | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> + | App(eq,[|_;t1;t2|]) when Term.eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) then Proofview.V82.of_tactic (Equality.discrHyp id) g else if Equality.injectable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) @@ -662,7 +663,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let f = funcs.(i) in let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g (EConstr.of_constr graph_principle) in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them *) @@ -717,7 +719,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = }) Locusops.onConcl) ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); + Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar ids)); thin ids ] else @@ -756,10 +758,10 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = tclTHENSEQ [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); + (Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas))])); Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (EConstr.mkVar hres,NoBindings) (Some (EConstr.mkVar graph_principle_id,NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -939,7 +941,7 @@ let revert_graph kn post_tac hid g = let f_args,res = Array.chop (Array.length args - 1) args in tclTHENSEQ [ - Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); + Proofview.V82.of_tactic (generalize [EConstr.of_constr (applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid]))]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); post_tac hid @@ -972,18 +974,18 @@ let functional_inversion kn hid fconst f_correct : tactic = let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let type_of_h = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (make_eq ()) -> + | App(eq,args) when Term.eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = match kind_of_term args.(1),kind_of_term args.(2) with - | App(f,f_args),_ when eq_constr f fconst -> + | App(f,f_args),_ when Term.eq_constr f fconst -> ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) - |_,App(f,f_args) when eq_constr f fconst -> + |_,App(f,f_args) when Term.eq_constr f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in tclTHENSEQ[ pre_tac hid; - Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); + Proofview.V82.of_tactic (generalize [EConstr.of_constr (applist(f_correct,(Array.to_list f_args)@[res;mkVar hid]))]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); @@ -1024,7 +1026,7 @@ let invfun qhyp f g = (fun hid -> Proofview.V82.tactic begin fun g -> let hyp_typ = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (make_eq ()) -> + | App(eq,args) when Term.eq_constr eq (make_eq ()) -> begin let f1,_ = decompose_app args.(1) in try diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 222c0c8043..3688b8c15f 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -32,7 +32,7 @@ module RelDecl = Context.Rel.Declaration (** {2 Useful operations on constr and glob_constr} *) -let rec popn i c = if i<=0 then c else pop (EConstr.of_constr (popn (i-1) c)) +let rec popn i c = if i<=0 then c else EConstr.of_constr (pop (popn (i-1) c)) (** Substitutions in constr *) let compare_constr_nosub t1 t2 = @@ -979,19 +979,20 @@ let funify_branches relinfo nfuns branch = let relprinctype_to_funprinctype relprinctype nfuns = - let relinfo = compute_elim_sig relprinctype in + let relprinctype = EConstr.of_constr relprinctype in + let relinfo = compute_elim_sig Evd.empty (** FIXME*) relprinctype in assert (not relinfo.farg_in_concl); assert (relinfo.indarg_in_concl); (* first remove indarg and indarg_in_concl *) let relinfo_noindarg = { relinfo with indarg_in_concl = false; indarg = None; - concl = remove_last_arg (pop (EConstr.of_constr relinfo.concl)); } in + concl = EConstr.of_constr (remove_last_arg (pop relinfo.concl)); } in (* the nfuns last induction arguments are functional ones: remove them *) let relinfo_argsok = { relinfo_noindarg with nargs = relinfo_noindarg.nargs - nfuns; (* args is in reverse order, so remove fst *) args = remove_n_fst_list nfuns relinfo_noindarg.args; - concl = popn nfuns relinfo_noindarg.concl + concl = popn nfuns relinfo_noindarg.concl; } in let new_branches = List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index b2c93a7540..d5ee42af8d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -286,7 +286,7 @@ let tclUSER tac is_mes l g = let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes - then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) + then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (EConstr.of_constr (delayed_force well_founded_ltof))) gl) else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) @@ -465,7 +465,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = end | App _ -> let f,args = decompose_app expr_info.info in - if eq_constr f (expr_info.f_constr) + if Term.eq_constr f (expr_info.f_constr) then jinfo.app_reC (f,args) expr_info continuation_tac expr_info else begin @@ -517,21 +517,21 @@ let rec prove_lt hyple g = let h = List.find (fun id -> match decompose_app (pf_unsafe_type_of g (EConstr.mkVar id)) with - | _, t::_ -> eq_constr t varx + | _, t::_ -> Term.eq_constr t varx | _ -> false ) hyple in let y = List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (EConstr.mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ - Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); + Proofview.V82.of_tactic (apply (EConstr.of_constr (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|])))); observe_tac (str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( observe_tclTHENLIST (str "prove_lt2")[ - Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force lt_S_n))); (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) ) @@ -549,15 +549,15 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in observe_tclTHENLIST (str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); + Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr s_max])); Proofview.V82.of_tactic (intro_then (fun id -> Proofview.V82.tactic begin observe_tac (str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) + (tclTHENS (Proofview.V82.of_tactic (simplest_case (EConstr.mkVar id))) [ observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); + Proofview.V82.of_tactic (simplest_elim(EConstr.of_constr (mkApp(delayed_force lt_n_O,[|s_max|])))); Proofview.V82.of_tactic default_full_auto]; observe_tclTHENLIST (str "destruct_bounds_aux2")[ observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id])); @@ -588,7 +588,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = ] g | (_,v_bound)::l -> observe_tclTHENLIST (str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); + Proofview.V82.of_tactic (simplest_elim (EConstr.mkVar v_bound)); Proofview.V82.of_tactic (clear [v_bound]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 @@ -597,7 +597,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (fun p -> observe_tclTHENLIST (str "destruct_bounds_aux4")[ Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); + (EConstr.of_constr (mkApp(delayed_force max_constr, [| bound; mkVar p|])))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with @@ -622,7 +622,7 @@ let terminate_app f_and_args expr_info continuation_tac infos = observe_tclTHENLIST (str "terminate_app1")[ continuation_tac infos; observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr infos.info]))); observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos @@ -633,7 +633,7 @@ let terminate_others _ expr_info continuation_tac infos = observe_tclTHENLIST (str "terminate_others")[ continuation_tac infos; observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr infos.info]))); observe_tac (str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos @@ -657,7 +657,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} let pf_type c tac gl = - let evars, ty = Typing.type_of (pf_env gl) (project gl) (EConstr.of_constr c) in + let evars, ty = Typing.type_of (pf_env gl) (project gl) c in tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = @@ -687,16 +687,18 @@ let mkDestructEq : let type_of_expr = pf_unsafe_type_of g (EConstr.of_constr expr) in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in + let new_hyps = List.map EConstr.of_constr new_hyps in pf_typel new_hyps (fun _ -> observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars = { run = fun sigma -> let redfun = pattern_occs [Locus.AllOccurrencesBut [1], EConstr.of_constr expr] in - redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) + let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) in + Sigma (EConstr.of_constr c, sigma, p) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]), to_revert + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr expr))]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = @@ -742,7 +744,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = then observe_tclTHENLIST (str "terminate_app_rec1")[ observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr new_infos.info]))); observe_tac (str "destruct_bounds (3)") (destruct_bounds new_infos) ] @@ -751,7 +753,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ] with Not_found -> observe_tac (str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) + (Proofview.V82.of_tactic (simplest_elim (EConstr.of_constr (mkApp(mkVar expr_info.ih,Array.of_list args))))) [ observe_tclTHENLIST (str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); @@ -772,7 +774,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = then observe_tclTHENLIST (str "terminate_app_rec4")[ observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr new_infos.info]))); observe_tac (str "destruct_bounds (2)") (destruct_bounds new_infos) ] @@ -785,7 +787,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ]; observe_tac (str "proving decreasing") ( tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (Lazy.force expr_info.acc_inv)))) [ observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); observe_tclTHENLIST (str "terminate_app_rec5") @@ -833,7 +835,7 @@ let rec prove_le g = in tclFIRST[ Proofview.V82.of_tactic assumption; - Proofview.V82.of_tactic (apply (delayed_force le_n)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_n))); begin try let matching_fun = @@ -846,7 +848,7 @@ let rec prove_le g = List.hd (List.tl args) in observe_tclTHENLIST (str "prove_le")[ - Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); + Proofview.V82.of_tactic (apply(EConstr.of_constr (mkApp(le_trans (),[|x;y;z;mkVar h|])))); observe_tac (str "prove_le (rec)") (prove_le) ] with Not_found -> tclFAIL 0 (mt()) @@ -876,7 +878,7 @@ let rec make_rewrite_list expr_info max = function ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_n_Sm))); observe_tac (str "prove_le(2)") prove_le ] ] ) @@ -916,7 +918,7 @@ let make_rewrite expr_info l hp max = ])) ; observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_SS)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); observe_tac (str "prove_le (3)") prove_le ] ]) @@ -928,7 +930,7 @@ let rec compute_max rew_tac max l = | (_,p,_)::l -> observe_tclTHENLIST (str "compute_max")[ Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| max; mkVar p|]))); + (EConstr.of_constr (mkApp(delayed_force max_constr, [| max; mkVar p|])))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with @@ -947,7 +949,7 @@ let rec destruct_hex expr_info acc l = end | (v,hex)::l -> observe_tclTHENLIST (str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (mkVar hex)); + Proofview.V82.of_tactic (simplest_case (EConstr.mkVar hex)); Proofview.V82.of_tactic (clear [hex]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hp -> @@ -995,13 +997,13 @@ let equation_app_rec (f,args) expr_info continuation_tac info = if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + [ Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (expr_info.f_terminate,Array.of_list args)))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) ] else observe_tclTHENLIST (str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (expr_info.f_terminate,Array.of_list args)))); observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) ] end @@ -1086,9 +1088,9 @@ let termination_proof_header is_mes input_type ids args_id relation (str "first assert") (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, + (EConstr.of_constr (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) - ) + )) )) ) [ @@ -1098,7 +1100,7 @@ let termination_proof_header is_mes input_type ids args_id relation (str "second assert") (Proofview.V82.of_tactic (assert_before (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) + (EConstr.of_constr (mkApp (delayed_force well_founded,[|input_type;relation|]))) )) ) [ @@ -1107,7 +1109,7 @@ let termination_proof_header is_mes input_type ids args_id relation (* this gives the accessibility argument *) observe_tac (str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) + (Proofview.V82.of_tactic (Simple.apply (EConstr.of_constr (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])))) ) ] ; @@ -1116,7 +1118,7 @@ let termination_proof_header is_mes input_type ids args_id relation [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1))); @@ -1214,7 +1216,7 @@ let build_and_l l = | Prod(_,_,t') -> is_well_founded t' | App(_,_) -> let (f,_) = decompose_app t in - eq_constr f (well_founded ()) + Term.eq_constr f (well_founded ()) | _ -> false in @@ -1231,7 +1233,7 @@ let build_and_l l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (Proofview.V82.of_tactic (apply (constr_of_global conj_constr))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_global conj_constr)))) [tclIDTAC; tac ],nb+1 @@ -1297,6 +1299,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Some lemma ; + let lemma = EConstr.of_constr lemma in let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in @@ -1323,7 +1326,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ] gls) (fun g -> match kind_of_term (pf_concl g) with - | App(f,_) when eq_constr f (well_founded ()) -> + | App(f,_) when Term.eq_constr f (well_founded ()) -> Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; @@ -1332,11 +1335,11 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp tclCOMPLETE( tclFIRST[ tclTHEN - (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) + (Proofview.V82.of_tactic (eapply_with_bindings (EConstr.mkVar (List.nth !lid !h_num), NoBindings))) (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (EConstr.of_constr (Lazy.force refl_equal)) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ] ) @@ -1366,7 +1369,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (fun c -> Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [intros; - Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); + Simple.apply (EConstr.of_constr (fst (interp_constr (Global.env()) Evd.empty c))) (*FIXME*); Tacticals.New.tclCOMPLETE Auto.default_auto ]) ) @@ -1428,8 +1431,8 @@ let start_equation (f:global_reference) (term_f:global_reference) h_intros x; Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); observe_tac (str "simplest_case") - (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x))))); + (Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (terminate_constr, + Array.of_list (List.map mkVar x)))))); observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a943ef2b01..f96b189c52 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1461,7 +1461,7 @@ let rec make_goal_of_formula dexpr form = xset (Term.mkNamedLetIn (Names.Id.of_string name) expr typ acc) l in - xset concl l + EConstr.of_constr (xset concl l) end (** * MODULE END: M @@ -2000,12 +2000,12 @@ let micromega_gen (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + (Tactics.forward true (Some None) (ipat_of_name goal_name) (EConstr.of_constr arith_goal)) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map Term.mkVar ids)); - Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + [(Tactics.generalize (List.map EConstr.mkVar ids)); + Tactics.exact_check (EConstr.of_constr (Term.applist (Term.mkVar goal_name, arith_args))) ] ) ] with @@ -2114,12 +2114,12 @@ let micromega_genr prover tac = (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + (Tactics.forward true (Some None) (ipat_of_name goal_name) (EConstr.of_constr arith_goal)) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map Term.mkVar ids)); - Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + [(Tactics.generalize (List.map EConstr.mkVar ids)); + Tactics.exact_check (EConstr.of_constr (Term.applist (Term.mkVar goal_name, arith_args))) ] ) ] diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 36bce780bd..cc0c4277e5 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -625,6 +625,7 @@ let nsatz lpol = let return_term t = let a = mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in + let a = EConstr.of_constr a in generalize [a] let nsatz_compute t = diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index b832250a51..35d763ccc5 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -38,9 +38,9 @@ open OmegaSolver let elim_id id = Proofview.Goal.nf_enter { enter = begin fun gl -> - simplest_elim (Tacmach.New.pf_global id gl) + simplest_elim (EConstr.of_constr (Tacmach.New.pf_global id gl)) end } -let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl +let resolve_id id gl = Proofview.V82.of_tactic (apply (EConstr.of_constr (pf_global gl id))) gl let timing timer_name f arg = f arg @@ -149,7 +149,7 @@ let mk_then = tclTHENLIST let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c]) -let generalize_tac t = generalize t +let generalize_tac t = generalize (List.map EConstr.of_constr t) let elim t = simplest_elim t let exact t = Tacmach.refine t let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] @@ -373,7 +373,7 @@ let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), [| Lazy.force coq_Z; t1; t2 |]) let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) -let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) +let mk_gt t1 t2 = EConstr.of_constr (mkApp (Lazy.force coq_Zgt, [| t1; t2 |])) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) @@ -569,6 +569,7 @@ let abstract_path typ path t = let focused_simpl path gl = let newc = context (fun i t -> pf_nf gl (EConstr.of_constr t)) (List.rev path) (pf_concl gl) in + let newc = EConstr.of_constr newc in Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl let focused_simpl path = focused_simpl path @@ -1116,7 +1117,7 @@ let replay_history tactic_normalisation = let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in Tacticals.New.tclTHENS - (cut state_eg) + (cut (EConstr.of_constr state_eg)) [ Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ (intros_using [aux]); @@ -1185,7 +1186,7 @@ let replay_history tactic_normalisation = if e1.kind == DISE then let tac = scalar_norm [P_APP 3] e2.body in Tacticals.New.tclTHENS - (cut state_eq) + (cut (EConstr.of_constr state_eq)) [Tacticals.New.tclTHENLIST [ (intros_using [aux1]); (generalize_tac @@ -1197,7 +1198,7 @@ let replay_history tactic_normalisation = Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in - Tacticals.New.tclTHENS (cut state_eq) + Tacticals.New.tclTHENS (cut (EConstr.of_constr state_eq)) [ Tacticals.New.tclTHENS (cut (mk_gt kk izero)) @@ -1227,7 +1228,7 @@ let replay_history tactic_normalisation = scalar_norm [P_APP 3] e1.body in Tacticals.New.tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) + (cut (EConstr.of_constr (mk_eq eq1 (mk_inv eq2)))) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA8, @@ -1260,7 +1261,7 @@ let replay_history tactic_normalisation = shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in Tacticals.New.tclTHENS - (cut theorem) + (cut (EConstr.of_constr theorem)) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (elim_id aux); @@ -1273,7 +1274,7 @@ let replay_history tactic_normalisation = (clear [aux]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ] + Tacticals.New.tclTHEN (exists_tac (EConstr.of_constr eq1)) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in @@ -1283,7 +1284,7 @@ let replay_history tactic_normalisation = let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in Tacticals.New.tclTHENS - (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))) [Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac1); (intros_using [id1]); (loop act1) ]; Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> @@ -1433,7 +1434,7 @@ let coq_omega = let i = new_id () in tag_hypothesis id i; (Tacticals.New.tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_intro_Z, [t])))); (intros_using [v; id]); (elim_id id); (clear [id]); @@ -1444,7 +1445,7 @@ let coq_omega = constant = zero; id = i} :: sys else (Tacticals.New.tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_new_var, [t]))); + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_new_var, [t])))); (intros_using [v;th]); tac ]), sys) @@ -1494,7 +1495,7 @@ let nat_inject = let id = new_identifier () in Tacticals.New.tclTHENS (Tacticals.New.tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_le_gt_dec, [t2;t1])))) (intros_using [id])) [ Tacticals.New.tclTHENLIST [ @@ -1793,15 +1794,15 @@ let destructure_hyps = | Kapp(Nat,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim - (mkApp - (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); + (EConstr.of_constr (mkApp + (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim - (mkApp - (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); + (EConstr.of_constr (mkApp + (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])))); (onClearedName i (fun _ -> loop lit)) ] | _ -> loop lit @@ -1851,7 +1852,7 @@ let destructure_goal = (Proofview.V82.tactic (Tacmach.refine (EConstr.of_constr (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))) intro - with Undecidable -> Tactics.elim_type (build_coq_False ()) + with Undecidable -> Tactics.elim_type (EConstr.of_constr (build_coq_False ())) in Tacticals.New.tclTHEN goal_tac destructure_hyps in diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 7b6d502b5d..2cc402e28a 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -458,8 +458,8 @@ let quote f lid = | _ -> assert false in match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast + | None -> Tactics.convert_concl (EConstr.of_constr (mkApp (f, [| p |]))) DEFAULTcast + | Some _ -> Tactics.convert_concl (EConstr.of_constr (mkApp (f, [| vm; p |]))) DEFAULTcast end } let gen_quote cont c f lid = diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index ba882e39a2..ab5033601a 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -1222,7 +1222,7 @@ let resolution env full_reified_goal systems_list = (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in - let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in + let l_generalize_arg = List.map (fun (_,t,_,_) -> EConstr.of_constr t) to_introduce in let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in (* L'environnement de base se construit en deux morceaux : - les variables des équations utiles (et de la conclusion) @@ -1258,6 +1258,7 @@ let resolution env full_reified_goal systems_list = let reified = app coq_interp_sequent [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in + let reified = EConstr.of_constr reified in let normalize_equation e = let rec loop = function [] -> app (if e.e_negated then coq_p_invert else coq_p_step) @@ -1281,9 +1282,9 @@ let resolution env full_reified_goal systems_list = let decompose_tactic = decompose_tree env context solution_tree in Proofview.V82.of_tactic (Tactics.generalize - (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps))) >> + (l_generalize_arg @ List.map EConstr.mkVar (List.tl l_hyps))) >> Proofview.V82.of_tactic (Tactics.change_concl reified) >> - Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> + Proofview.V82.of_tactic (Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic; normalization_trace|]))) >> show_goal >> Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >> (*i Alternatives to the previous line: @@ -1292,7 +1293,7 @@ let resolution env full_reified_goal systems_list = - Skip the conversion check and rely directly on the QED: Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> i*) - Proofview.V82.of_tactic (Tactics.apply (Lazy.force coq_I)) + Proofview.V82.of_tactic (Tactics.apply (EConstr.of_constr (Lazy.force coq_I))) let total_reflexive_omega_tactic gl = Coqlib.check_required_library ["Coq";"romega";"ROmega"]; diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index f88b3a7001..981ce2a61f 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -312,6 +312,7 @@ let rtauto_tac gls= str "Giving proof term to Coq ... ") end in let tac_start_time = System.get_time () in + let term = EConstr.of_constr term in let result= if !check then Proofview.V82.of_tactic (Tactics.exact_check term) gls diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index ace557a52a..aa91494eb8 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1392,6 +1392,7 @@ let ssrpatterntac _ist (arg_ist,arg) gl = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in let gl, tty = pf_type_of gl (EConstr.of_constr t) in let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in + let concl = EConstr.of_constr concl in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) -- cgit v1.2.3 From 8b660087beb2209e52bc4412dc82c6727963c6a5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Nov 2016 20:26:15 +0100 Subject: Elim API using EConstr. --- plugins/funind/functional_principles_proofs.ml | 2 +- plugins/funind/recdef.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 503cafdd50..940f1669ab 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1626,7 +1626,7 @@ let prove_principle_for_gen [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); + Proofview.V82.of_tactic (Elim.h_decompose_and (EConstr.mkVar hid)); (fun g -> let new_hyps = pf_ids_of_hyps g in tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index d5ee42af8d..74affa3964 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1314,7 +1314,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (fun g -> let ids = pf_ids_of_hyps g in tclTHEN - (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) + (Proofview.V82.of_tactic (Elim.h_decompose_and (EConstr.mkVar hid))) (fun g -> let ids' = pf_ids_of_hyps g in lid := List.rev (List.subtract Id.equal ids' ids); -- cgit v1.2.3 From 3f9e56fcbf479999325a86bbdaeefd6a0be13c65 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Nov 2016 20:35:01 +0100 Subject: Equality API using EConstr. --- plugins/cc/cctac.ml | 3 ++- plugins/fourier/fourierR.ml | 12 ++++++------ plugins/funind/functional_principles_proofs.ml | 10 +++++----- plugins/funind/indfun_common.ml | 1 + plugins/funind/invfun.ml | 10 +++++----- plugins/funind/recdef.ml | 12 ++++++------ 6 files changed, 25 insertions(+), 23 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7b023413d6..a12ef00ec3 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -229,7 +229,8 @@ let make_prb gls depth additionnal_terms = let build_projection intype (cstr:pconstructor) special default gls= let ci= (snd(fst cstr)) in - let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in + let body=Equality.build_selector (pf_env gls) (project gls) ci (EConstr.mkRel 1) (EConstr.of_constr intype) (EConstr.of_constr special) (EConstr.of_constr default) in + let body = EConstr.Unsafe.to_constr body in let id=pf_get_new_id (Id.of_string "t") gls in mkLambda(Name id,intype,body) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index fa64b276c8..dbb5cc2de7 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -600,15 +600,15 @@ let rec fourier () = (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt else get coq_Rnot_le_le)) (Tacticals.New.tclTHENS (Equality.replace - (mkAppL [|cget coq_Rminus;!t2;!t1|] - ) - tc) + (EConstr.of_constr (mkAppL [|cget coq_Rminus;!t2;!t1|] + )) + (EConstr.of_constr tc)) [tac2; (Tacticals.New.tclTHENS (Equality.replace - (mkApp (cget coq_Rinv, - [|cget coq_R1|])) - (cget coq_R1)) + (EConstr.of_constr (mkApp (cget coq_Rinv, + [|cget coq_R1|]))) + (get coq_R1)) (* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) [Tacticals.New.tclORELSE diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 940f1669ab..2e3992be94 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -401,7 +401,7 @@ let rewrite_until_var arg_num eq_ids : tactic = | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property"); | eq_id::eq_ids -> tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (EConstr.mkVar eq_id)))) (do_rewrite eq_ids) g in @@ -1060,7 +1060,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let just_introduced = nLastDecls nb_intro_to_do g' in let open Context.Named.Declaration in let just_introduced_id = List.map get_id just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) + tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.of_constr equation_lemma))) (revert just_introduced_id) g' ) g @@ -1425,7 +1425,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = let backtrack_eqs_until_hrec hrec eqs : tactic = fun gls -> - let eqs = List.map mkVar eqs in + let eqs = List.map EConstr.mkVar eqs in let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in @@ -1453,7 +1453,7 @@ let rec rewrite_eqs_in_eqs eqs = observe_tac (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences - true (* dep proofs also: *) true id (mkVar eq) false))) + true (* dep proofs also: *) true id (EConstr.mkVar eq) false))) gl ) eqs @@ -1659,7 +1659,7 @@ let prove_principle_for_gen (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix (Some fix_id) (List.length args_ids + 1))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); + Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.of_constr (mkConst eq_ref))); (* observe_tac "finish" *) (fun gl' -> let body = let _,args = destApp (pf_concl gl') in diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index a45effb167..08b40a1f7e 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -502,6 +502,7 @@ let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (G | _ -> assert false;; let list_rewrite (rev:bool) (eqs: (constr*bool) list) = + let eqs = List.map (Util.on_fst EConstr.of_constr) eqs in tclREPEAT (List.fold_right (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 36fb6dad3d..d29d4694f3 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -385,7 +385,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* introducing the the result of the graph and the equality hypothesis *) observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); + observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.mkVar hres))); (* Conclusion *) observe_tac "exact" (fun g -> Proofview.V82.of_tactic (exact_check (EConstr.of_constr (app_constructor g))) g) @@ -520,7 +520,7 @@ and intros_with_rewrite_aux : tactic = let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); generalize_dependent_of (destVar args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.mkVar id))); intros_with_rewrite ] g @@ -529,7 +529,7 @@ and intros_with_rewrite_aux : tactic = let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); generalize_dependent_of (destVar args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (EConstr.mkVar id))); intros_with_rewrite ] g @@ -538,7 +538,7 @@ and intros_with_rewrite_aux : tactic = let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ[ Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.mkVar id))); intros_with_rewrite ] g end @@ -709,7 +709,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = in tclTHENSEQ[ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); + Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.of_constr (mkConst eq_lemma))); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) Proofview.V82.of_tactic (reduce diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 74affa3964..5cee3cb204 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -871,10 +871,10 @@ let rec make_rewrite_list expr_info max = function in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true - (mkVar hp, + (EConstr.mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, - expr_info.f_constr;Loc.ghost,NamedHyp k, - (f_S max)]) false) g) ) + EConstr.of_constr expr_info.f_constr;Loc.ghost,NamedHyp k, + EConstr.of_constr (f_S max)]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) @@ -898,10 +898,10 @@ let make_rewrite expr_info l hp max = observe_tac (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true - (mkVar hp, + (EConstr.mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, - expr_info.f_constr;Loc.ghost,NamedHyp k, - (f_S (f_S max))]) false)) g) + EConstr.of_constr expr_info.f_constr;Loc.ghost,NamedHyp k, + EConstr.of_constr (f_S (f_S max))]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ -- cgit v1.2.3 From 118ae18590dbc7d01cf34e0cd6133b1e34ef9090 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 00:20:30 +0100 Subject: Contradiction API using EConstr. --- plugins/omega/coq_omega.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'plugins') diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 35d763ccc5..f39549514c 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1092,6 +1092,7 @@ let replay_history tactic_normalisation = Lazy.force coq_Gt; Lazy.force coq_Gt |]) in + let not_sup_sup = EConstr.of_constr not_sup_sup in Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ unfold sp_Zle; -- 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. --- plugins/extraction/extraction.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'plugins') diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 6559aeb082..e9fd407225 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -325,6 +325,7 @@ and extract_type_scheme env db c p = extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) | _ -> let rels = fst (splay_prod env none (EConstr.of_constr (type_of env c))) in + let rels = List.map (on_snd EConstr.Unsafe.to_constr) rels in let env = push_rels_assum rels env in let eta_args = List.rev_map mkRel (List.interval 1 p) in extract_type env db 0 (lift p c) eta_args -- 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. --- plugins/firstorder/sequent.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 87e7192d78..91cd102a23 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -214,8 +214,8 @@ let extend_with_auto_hints l seq gl= | Res_pf_THEN_trivial_fail (c,_) -> let (c, _, _) = c in (try - let gr = global_of_constr c in - let typ=(pf_unsafe_type_of gl (EConstr.of_constr c)) in + let (gr, _) = Termops.global_of_constr (project gl) c in + let typ=(pf_unsafe_type_of gl c) in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) | _-> () in -- 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. --- plugins/quote/quote.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'plugins') diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 2cc402e28a..09e77598a4 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -403,7 +403,7 @@ let quote_terms ivs lc = | (lhs, rhs)::tail -> begin try let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs (EConstr.of_constr c)) in - let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 + let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux (EConstr.Unsafe.to_constr c_i))) s1 in Termops.subst_meta s2 lhs with PatternMatchingFailure -> auxl tail -- 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. --- plugins/decl_mode/decl_proof_instr.ml | 7 +++++-- plugins/setoid_ring/newring.ml | 29 +++++++++++++++++++++++++---- 2 files changed, 30 insertions(+), 6 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 54206aa955..5de2c41517 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -382,6 +382,9 @@ let enstack_subsubgoals env se stack gls= Array.iteri process gentypes | _ -> () +let nf_meta sigma c = + EConstr.Unsafe.to_constr (Reductionops.nf_meta sigma (EConstr.of_constr c)) + let rec nf_list evd = function [] -> [] @@ -389,7 +392,7 @@ let rec nf_list evd = if meta_defined evd m then nf_list evd others else - (m,Reductionops.nf_meta evd typ)::nf_list evd others + (m,nf_meta evd typ)::nf_list evd others let find_subsubgoal c ctyp skip submetas gls = let env= pf_env gls in @@ -424,7 +427,7 @@ let find_subsubgoal c ctyp skip submetas gls = dfs n end in let nse= try dfs skip with Stack.Empty -> raise Not_found in - nf_list nse.se_evd nse.se_meta_list,Reductionops.nf_meta nse.se_evd (mkMeta 0) + nf_list nse.se_evd nse.se_meta_list,nf_meta nse.se_evd (mkMeta 0) let concl_refiner metas body gls = let concl = pf_concl gls in diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 089e76d7a0..4492b854b4 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -416,11 +416,18 @@ let theory_to_obj : ring_info -> obj = let setoid_of_relation env evd a r = + let a = EConstr.of_constr a in + let r = EConstr.of_constr r in try let evm = !evd in let evm, refl = Rewrite.get_reflexive_proof env evm a r in let evm, sym = Rewrite.get_symmetric_proof env evm a r in let evm, trans = Rewrite.get_transitive_proof env evm a r in + let refl = EConstr.Unsafe.to_constr refl in + let sym = EConstr.Unsafe.to_constr sym in + let trans = EConstr.Unsafe.to_constr trans in + let a = EConstr.Unsafe.to_constr a in + let r = EConstr.Unsafe.to_constr r in evd := evm; lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> @@ -498,22 +505,32 @@ let ring_equality env evd (r,add,mul,opp,req) = (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in - let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in + let signature = + let r = EConstr.of_constr r in + let req = EConstr.of_constr req in + [Some (r,Some req);Some (r,Some req)],Some(r,Some req) + in +(* let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in *) let add_m, add_m_lem = - try Rewrite.default_morphism signature add + try Rewrite.default_morphism signature (EConstr.of_constr add) with Not_found -> error "ring addition should be declared as a morphism" in + let add_m_lem = EConstr.Unsafe.to_constr add_m_lem in let mul_m, mul_m_lem = - try Rewrite.default_morphism signature mul + try Rewrite.default_morphism signature (EConstr.of_constr mul) with Not_found -> error "ring multiplication should be declared as a morphism" in + let mul_m_lem = EConstr.Unsafe.to_constr mul_m_lem in let op_morph = match opp with | Some opp -> (let opp_m,opp_m_lem = - try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp + let r = EConstr.of_constr r in + let req = EConstr.of_constr req in + try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) (EConstr.of_constr opp) with Not_found -> error "ring opposite should be declared as a morphism" in + let opp_m_lem = EConstr.Unsafe.to_constr opp_m_lem in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose @@ -895,11 +912,15 @@ let field_equality evd r inv req = mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) | _ -> let _setoid = setoid_of_relation (Global.env ()) evd r req in + let r = EConstr.of_constr r in + let req = EConstr.of_constr req in let signature = [Some (r,Some req)],Some(r,Some req) in + let inv = EConstr.of_constr inv in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv with Not_found -> error "field inverse should be declared as a morphism" in + let inv_m_lem = EConstr.Unsafe.to_constr inv_m_lem in inv_m_lem let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv = -- 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 --- plugins/btauto/refl_btauto.ml | 2 +- plugins/cc/cctac.ml | 1 + plugins/decl_mode/decl_proof_instr.ml | 5 ++++- plugins/extraction/extraction.ml | 4 ++-- plugins/firstorder/unify.ml | 3 ++- plugins/fourier/fourierR.ml | 1 + plugins/quote/quote.ml | 2 +- 7 files changed, 12 insertions(+), 6 deletions(-) (limited to 'plugins') diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 27398cf65a..4d2859fb07 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -15,7 +15,7 @@ let get_inductive dir s = Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) let decomp_term sigma (c : Term.constr) = - Term.kind_of_term (Termops.strip_outer_cast sigma (EConstr.of_constr c)) + Term.kind_of_term (EConstr.Unsafe.to_constr (Termops.strip_outer_cast sigma (EConstr.of_constr c))) let lapp c v = Term.mkApp (Lazy.force c, v) diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index a12ef00ec3..6295e004e1 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -87,6 +87,7 @@ let rec decompose_term env sigma t= (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) | _ -> let t = Termops.strip_outer_cast sigma (EConstr.of_constr t) in + let t = EConstr.Unsafe.to_constr t in if closed0 t then Symb t else raise Not_found (* decompose equality in members and type *) diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 5de2c41517..e73166be28 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -786,7 +786,7 @@ let rec consider_match may_intro introduced available expected gls = let consider_tac c hyps gls = let c = EConstr.of_constr c in - match kind_of_term (strip_outer_cast (project gls) c) with + match EConstr.kind (project gls) (strip_outer_cast (project gls) c) with Var id -> consider_match false [] [id] hyps gls | _ -> @@ -811,6 +811,9 @@ let rec take_tac wits gls = (* tactics for define *) +let subst_term sigma c t = + EConstr.Unsafe.to_constr (subst_term sigma c t) + let rec build_function sigma args body = match args with st::rest -> diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index e9fd407225..4601571306 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -42,11 +42,11 @@ let none = Evd.empty let type_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_type_of ~polyprop env none (EConstr.of_constr (strip_outer_cast none (EConstr.of_constr c))) + Retyping.get_type_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) let sort_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_sort_family_of ~polyprop env none (EConstr.of_constr (strip_outer_cast none (EConstr.of_constr c))) + Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) (*S Generation of flags and signatures. *) diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index fb237f29bf..205cb282d1 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -21,7 +21,8 @@ exception UFAIL of constr*constr to the equation set. Raises UFAIL with a pair of terms *) -let strip_outer_cast t = strip_outer_cast Evd.empty (EConstr.of_constr t) (** FIXME *) +let strip_outer_cast t = + EConstr.Unsafe.to_constr (strip_outer_cast Evd.empty (EConstr.of_constr t)) (** FIXME *) let unif t1 t2= let evd = Evd.empty in (** FIXME *) diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index dbb5cc2de7..f9802ee5e1 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -471,6 +471,7 @@ let rec fourier () = let sigma = Tacmach.New.project gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; let goal = Termops.strip_outer_cast sigma (EConstr.of_constr concl) in + let goal = EConstr.Unsafe.to_constr goal in let fhyp=Id.of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, et le but à prouver devient False *) diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 09e77598a4..04a747fb46 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -183,7 +183,7 @@ type inversion_scheme = { let i_can't_do_that () = error "Quote: not a simple fixpoint" -let decomp_term gl c = kind_of_term (Termops.strip_outer_cast (Tacmach.New.project gl) (EConstr.of_constr c)) +let decomp_term gl c = kind_of_term (EConstr.Unsafe.to_constr (Termops.strip_outer_cast (Tacmach.New.project gl) (EConstr.of_constr c))) (*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive -- cgit v1.2.3 From e09f3b44bb381854b647a6d9debdeddbfc49177e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 22:16:08 +0100 Subject: Proofview.Goal primitive now return EConstrs. --- plugins/btauto/refl_btauto.ml | 2 ++ plugins/cc/cctac.ml | 5 ++++- plugins/decl_mode/decl_proof_instr.ml | 2 +- plugins/fourier/fourierR.ml | 2 +- plugins/omega/coq_omega.ml | 1 + plugins/quote/quote.ml | 1 + plugins/ssrmatching/ssrmatching.ml4 | 2 +- 7 files changed, 11 insertions(+), 4 deletions(-) (limited to 'plugins') diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 4d2859fb07..93bd88fe4b 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -221,6 +221,7 @@ module Btauto = struct Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in + let concl = EConstr.Unsafe.to_constr concl in let t = decomp_term (Tacmach.New.project gl) concl in match t with | Term.App (c, [|typ; p; _|]) when c === eq -> @@ -235,6 +236,7 @@ module Btauto = struct let tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in + let concl = EConstr.Unsafe.to_constr concl in let sigma = Tacmach.New.project gl in let eq = Lazy.force eq in let bool = Lazy.force Bool.typ in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 6295e004e1..130f01e97d 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -230,7 +230,7 @@ let make_prb gls depth additionnal_terms = let build_projection intype (cstr:pconstructor) special default gls= let ci= (snd(fst cstr)) in - let body=Equality.build_selector (pf_env gls) (project gls) ci (EConstr.mkRel 1) (EConstr.of_constr intype) (EConstr.of_constr special) (EConstr.of_constr default) in + let body=Equality.build_selector (pf_env gls) (project gls) ci (EConstr.mkRel 1) (EConstr.of_constr intype) (EConstr.of_constr special) default in let body = EConstr.Unsafe.to_constr body in let id=pf_get_new_id (Id.of_string "t") gls in mkLambda(Name id,intype,body) @@ -321,6 +321,7 @@ let rec proof_tac p : unit Proofview.tactic = let special=mkRel (1+nargs-argind) in refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> + let default = EConstr.of_constr default in let proj = Tacmach.New.of_old (build_projection intype cstr special default) gl in @@ -388,6 +389,7 @@ let discriminate_tac (cstr,u as cstru) p = let pred = mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in + let concl = EConstr.Unsafe.to_constr concl in let injt=app_global _f_equal [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = @@ -498,6 +500,7 @@ let mk_eq f c1 c2 k = let f_equal = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in + let concl = EConstr.Unsafe.to_constr concl in let cut_eq c1 c2 = try (* type_of can raise an exception *) Tacticals.New.tclTHENS diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index e73166be28..c3254010aa 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -41,7 +41,7 @@ let clear ids { it = goal; sigma } = let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in let env = Goal.V82.env sigma goal in let sign = Goal.V82.hyps sigma goal in - let cl = EConstr.Unsafe.to_constr (Goal.V82.concl sigma goal) in + let cl = Goal.V82.concl sigma goal in let evdref = ref (Evd.clear_metas sigma) in let (hyps, concl) = try Evarutil.clear_hyps_in_evi env evdref sign cl ids diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index f9802ee5e1..bffca62231 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -470,7 +470,7 @@ let rec fourier () = let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; - let goal = Termops.strip_outer_cast sigma (EConstr.of_constr concl) in + let goal = Termops.strip_outer_cast sigma concl in let goal = EConstr.Unsafe.to_constr goal in let fhyp=Id.of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index f39549514c..72290e681a 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1857,6 +1857,7 @@ let destructure_goal = in Tacticals.New.tclTHEN goal_tac destructure_hyps in + let concl = EConstr.Unsafe.to_constr concl in (loop concl) end } diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 04a747fb46..5f8a0b2d50 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -452,6 +452,7 @@ let quote f lid = let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in let ivs = compute_ivs f cl gl in let concl = Proofview.Goal.concl gl in + let concl = EConstr.Unsafe.to_constr concl in let quoted_terms = quote_terms ivs [concl] in let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index aa91494eb8..d34c9325ed 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1078,7 +1078,7 @@ END let thin id sigma goal = let ids = Id.Set.singleton id in let env = Goal.V82.env sigma goal in - let cl = EConstr.Unsafe.to_constr (Goal.V82.concl sigma goal) in + let cl = Goal.V82.concl sigma goal in let evdref = ref (Evd.clear_metas sigma) in let ans = try Some (Evarutil.clear_hyps_in_evi env evdref (Environ.named_context_val env) cl ids) -- 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. --- plugins/btauto/refl_btauto.ml | 1 + plugins/decl_mode/decl_proof_instr.ml | 4 ++-- plugins/extraction/extraction.ml | 22 ++++++++++++-------- plugins/firstorder/instances.ml | 2 +- plugins/firstorder/unify.ml | 4 ++-- plugins/funind/functional_principles_proofs.ml | 28 +++++++++++++++----------- plugins/funind/functional_principles_types.ml | 1 + plugins/funind/invfun.ml | 12 ++++++----- plugins/funind/recdef.ml | 3 ++- plugins/omega/coq_omega.ml | 10 ++++----- plugins/romega/const_omega.ml | 2 +- plugins/setoid_ring/newring.ml | 4 ++-- 12 files changed, 54 insertions(+), 39 deletions(-) (limited to 'plugins') diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 93bd88fe4b..a0b04ce3b5 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -182,6 +182,7 @@ module Btauto = struct let var = EConstr.of_constr var in (* Compute an assignment that dissatisfies the goal *) let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in + let var = EConstr.Unsafe.to_constr var in let rec to_list l = match decomp_term (Tacmach.project gl) l with | Term.App (c, _) when c === (Lazy.force CoqList._nil) -> [] diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index c3254010aa..7123ebcaf5 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -1103,7 +1103,7 @@ let thesis_for obj typ per_info env= ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in - compose_prod rc (Reductionops.whd_beta Evd.empty (EConstr.of_constr hd2)) + compose_prod rc (EConstr.Unsafe.to_constr (Reductionops.whd_beta Evd.empty (EConstr.of_constr hd2))) let rec build_product_dep pat_info per_info args body gls = match args with @@ -1233,7 +1233,7 @@ let hrec_for fix_id per_info gls obj_id = try List.for_all2 Term.eq_constr params per_info.per_params with Invalid_argument _ -> false end; let hd2 = applist (mkVar fix_id,args@[obj]) in - EConstr.of_constr (compose_lam rc (Reductionops.whd_beta gls.sigma (EConstr.of_constr hd2))) + EConstr.of_constr (compose_lam rc (EConstr.Unsafe.to_constr (Reductionops.whd_beta gls.sigma (EConstr.of_constr hd2)))) let warn_missing_case = CWarnings.create ~name:"declmode-missing-case" ~category:"declmode" diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 4601571306..61547f96d9 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -70,11 +70,17 @@ type scheme = TypeScheme | Default type flag = info * scheme +let whd_all env t = + EConstr.Unsafe.to_constr (whd_all env none (EConstr.of_constr t)) + +let whd_betaiotazeta t = + EConstr.Unsafe.to_constr (whd_betaiotazeta none (EConstr.of_constr t)) + (*s [flag_of_type] transforms a type [t] into a [flag]. Really important function. *) let rec flag_of_type env t : flag = - let t = whd_all env none (EConstr.of_constr t) in + let t = whd_all env t in match kind_of_term t with | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) @@ -105,14 +111,14 @@ let push_rel_assum (n, t) env = (*s [type_sign] gernerates a signature aimed at treating a type application. *) let rec type_sign env c = - match kind_of_term (whd_all env none (EConstr.of_constr c)) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] let rec type_scheme_nb_args env c = - match kind_of_term (whd_all env none (EConstr.of_constr c)) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in if is_info_scheme env t then n+1 else n @@ -138,7 +144,7 @@ let make_typvar n vl = next_ident_away id' vl let rec type_sign_vl env c = - match kind_of_term (whd_all env none (EConstr.of_constr c)) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in if not (is_info_scheme env t) then Kill Kprop::s, vl @@ -146,7 +152,7 @@ let rec type_sign_vl env c = | _ -> [],[] let rec nb_default_params env c = - match kind_of_term (whd_all env none (EConstr.of_constr c)) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let n = nb_default_params (push_rel_assum (n,t) env) d in if is_default env t then n+1 else n @@ -217,7 +223,7 @@ let parse_ind_args si args relmax = let rec extract_type env db j c args = - match kind_of_term (whd_betaiotazeta none (EConstr.of_constr c)) with + match kind_of_term (whd_betaiotazeta c) with | App (d, args') -> (* We just accumulate the arguments. *) extract_type env db j d (Array.to_list args' @ args) @@ -319,7 +325,7 @@ and extract_type_app env db (r,s) args = and extract_type_scheme env db c p = if Int.equal p 0 then extract_type env db 0 c [] else - let c = whd_betaiotazeta none (EConstr.of_constr c) in + let c = whd_betaiotazeta c in match kind_of_term c with | Lambda (n,t,d) -> extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) @@ -492,7 +498,7 @@ and extract_really_ind env kn mib = *) and extract_type_cons env db dbmap c i = - match kind_of_term (whd_all env none (EConstr.of_constr c)) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let env' = push_rel_assum (n,t) env in let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index a320b47aa3..24d4346d9a 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -107,7 +107,7 @@ let mk_open_instance id idc gl m t= let typ=pf_unsafe_type_of gl (EConstr.of_constr idc) in (* since we know we will get a product, reduction is not too expensive *) - let (nam,_,_)=destProd (whd_all env evmap (EConstr.of_constr typ)) in + let (nam,_,_)=destProd (EConstr.Unsafe.to_constr (whd_all env evmap (EConstr.of_constr typ))) in match nam with Name id -> id | Anonymous -> dummy_bvid in diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 205cb282d1..5520c7e35d 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -42,8 +42,8 @@ let unif t1 t2= Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta Evd.empty (EConstr.of_constr t1)) - and nt2=head_reduce (whd_betaiotazeta Evd.empty (EConstr.of_constr t2)) in + let nt1=head_reduce (EConstr.Unsafe.to_constr (whd_betaiotazeta evd (EConstr.of_constr t1))) + and nt2=head_reduce (EConstr.Unsafe.to_constr (whd_betaiotazeta evd (EConstr.of_constr t2))) in match (kind_of_term nt1),(kind_of_term nt2) with Meta i,Meta j-> if not (Int.equal i j) then diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 2e3992be94..188368082c 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -321,6 +321,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = in let new_type_of_hyp = Reductionops.nf_betaiota Evd.empty (EConstr.of_constr new_type_of_hyp) in + let new_type_of_hyp = EConstr.Unsafe.to_constr new_type_of_hyp in let new_ctxt,new_end_of_type = decompose_prod_n_assum ctxt_size new_type_of_hyp in @@ -619,6 +620,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = ) in let new_body = pf_nf_betaiota g' (EConstr.of_constr (mkApp(fun_body,[| new_term_value |]))) in + let new_body = EConstr.Unsafe.to_constr new_body in let new_infos = {dyn_infos with info = new_body; @@ -752,6 +754,7 @@ let build_proof pf_nf_betaiota g' (EConstr.of_constr (mkApp(dyn_infos.info,[|mkVar id|]))) in + let new_term = EConstr.Unsafe.to_constr new_term in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = build_proof do_finalize @@ -796,6 +799,7 @@ let build_proof | Lambda _ -> let new_term = Reductionops.nf_beta Evd.empty (EConstr.of_constr dyn_infos.info) in + let new_term = EConstr.Unsafe.to_constr new_term in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> @@ -1097,11 +1101,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let get_body const = match Global.body_of_constant const with | Some body -> - Tacred.cbv_norm_flags + EConstr.Unsafe.to_constr (Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) - (EConstr.of_constr body) + (EConstr.of_constr body)) | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in @@ -1152,9 +1156,9 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let bodies_with_all_params = Array.map (fun body -> - Reductionops.nf_betaiota Evd.empty + EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty (EConstr.of_constr (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params))) + List.rev_map var_of_decl princ_params)))) ) bodies in @@ -1190,12 +1194,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = - Reductionops.nf_betaiota Evd.empty (EConstr.of_constr ( - applist(body,List.rev_map var_of_decl full_params))) + EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty (EConstr.of_constr ( + applist(body,List.rev_map var_of_decl full_params)))) in match kind_of_term body_with_full_params with | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota Evd.empty + EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty (EConstr.of_constr ( (applist (substl @@ -1203,7 +1207,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) - )),num + ))),num | _ -> error "Not a mutual block" in let info = @@ -1279,8 +1283,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota Evd.empty - (EConstr.of_constr (applist(fix_body,List.rev_map mkVar args_id))); + EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty + (EConstr.of_constr (applist(fix_body,List.rev_map mkVar args_id)))); eq_hyps = [] } in @@ -1339,11 +1343,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota Evd.empty + EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty (EConstr.of_constr (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) - ))); + )))); eq_hyps = [] } in diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 4d88f9f915..b4eb778708 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -409,6 +409,7 @@ let get_funs_constant mp dp = (Evd.from_env (Global.env ())) (EConstr.of_constr body) in + let body = EConstr.Unsafe.to_constr body in body | None -> error ( "Cannot define a principle over an axiom ") in diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index d29d4694f3..c02b64c1f5 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -252,7 +252,6 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta (EConstr.of_constr princ_type) in - let princ_type = EConstr.of_constr princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in @@ -429,7 +428,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in - (nf_zeta (EConstr.of_constr p))::bindings,id::avoid) + (EConstr.Unsafe.to_constr (nf_zeta (EConstr.of_constr p)))::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -662,7 +661,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in - let princ_type = pf_unsafe_type_of g (EConstr.of_constr graph_principle) in + let princ_type = pf_unsafe_type_of g graph_principle in let princ_type = EConstr.of_constr princ_type in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function @@ -754,14 +753,15 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = g in let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in let params = List.map mkVar params_names in tclTHENSEQ [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas))])); + (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (EConstr.mkVar hres,NoBindings) (Some (EConstr.mkVar graph_principle_id,NoBindings))))) + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -796,6 +796,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let _ = Typing.e_type_of (Global.env ()) evd (EConstr.of_constr type_of_lemma) in let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in + let type_of_lemma = EConstr.Unsafe.to_constr type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) @@ -863,6 +864,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in + let type_of_lemma = EConstr.Unsafe.to_constr type_of_lemma in observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); type_of_lemma,type_info ) diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 5cee3cb204..c71174fefb 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -695,7 +695,7 @@ let mkDestructEq : let changefun patvars = { run = fun sigma -> let redfun = pattern_occs [Locus.AllOccurrencesBut [1], EConstr.of_constr expr] in let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) in - Sigma (EConstr.of_constr c, sigma, p) + Sigma (c, sigma, p) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case (EConstr.of_constr expr))]), to_revert @@ -1503,6 +1503,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in let eq' = nf_zeta env_eq' (EConstr.of_constr eq') in + let eq' = EConstr.Unsafe.to_constr eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 72290e681a..51790f4c90 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -568,7 +568,7 @@ let abstract_path typ path t = mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = - let newc = context (fun i t -> pf_nf gl (EConstr.of_constr t)) (List.rev path) (pf_concl gl) in + let newc = context (fun i t -> EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr t))) (List.rev path) (pf_concl gl) in let newc = EConstr.of_constr newc in Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl @@ -1386,7 +1386,7 @@ let destructure_omega gl tac_def (id,c) = else try match destructurate_prop c with | Kapp(Eq,[typ;t1;t2]) - when begin match destructurate_type (pf_nf gl (EConstr.of_constr typ)) with Kapp(Z,[]) -> true | _ -> false end -> + when begin match destructurate_type (EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr typ))) with Kapp(Z,[]) -> true | _ -> false end -> let t = mk_plus t1 (mk_inv t2) in normalize_equation id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def @@ -1661,7 +1661,7 @@ let rec decidability gl t = | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type (pf_nf gl (EConstr.of_constr typ)) with + begin match destructurate_type (EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr typ))) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable @@ -1791,7 +1791,7 @@ let destructure_hyps = with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin - match destructurate_type (pf_nf (EConstr.of_constr typ)) with + match destructurate_type (EConstr.Unsafe.to_constr (pf_nf (EConstr.of_constr typ))) with | Kapp(Nat,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim @@ -1808,7 +1808,7 @@ let destructure_hyps = ] | _ -> loop lit end else begin - match destructurate_type (pf_nf (EConstr.of_constr typ)) with + match destructurate_type (EConstr.Unsafe.to_constr (pf_nf (EConstr.of_constr typ))) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index f2d91bad37..5c68078d7d 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -353,7 +353,7 @@ let parse_term t = let parse_rel gl t = try match destructurate t with | Kapp("eq",[typ;t1;t2]) - when destructurate (Tacmach.pf_nf gl (EConstr.of_constr typ)) = Kapp("Z",[]) -> Req (t1,t2) + when destructurate (EConstr.Unsafe.to_constr (Tacmach.pf_nf gl (EConstr.of_constr typ))) = Kapp("Z",[]) -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 4492b854b4..b720b2e0a8 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -83,8 +83,8 @@ let lookup_map map = let protect_red map env sigma c = let c = EConstr.Unsafe.to_constr c in - kl (create_clos_infos all env) - (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; + EConstr.of_constr (kl (create_clos_infos all env) + (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c));; let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None -- cgit v1.2.3 From a327ae04966aa1c7786ae32157516e934068ea89 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Nov 2016 21:33:14 +0100 Subject: Quote API using EConstr. --- plugins/quote/g_quote.ml4 | 7 ++- plugins/quote/quote.ml | 119 +++++++++++++++++++++----------------- plugins/setoid_ring/g_newring.ml4 | 2 +- plugins/setoid_ring/newring.ml | 3 +- plugins/setoid_ring/newring.mli | 2 +- 5 files changed, 74 insertions(+), 59 deletions(-) (limited to 'plugins') diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index e7e6ecef98..79c4296155 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -22,7 +22,8 @@ let loc = Loc.ghost let cont = Id.of_string "cont" let x = Id.of_string "x" -let make_cont (k : Val.t) (c : Constr.t) = +let make_cont (k : Val.t) (c : EConstr.t) = + let c = EConstr.Unsafe.to_constr c in let c = Tacinterp.Value.of_constr c in let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in @@ -32,8 +33,8 @@ TACTIC EXTEND quote [ "quote" ident(f) ] -> [ quote f [] ] | [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] | [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) c f [] ] + [ gen_quote (make_cont k) (EConstr.of_constr c) f [] ] | [ "quote" ident(f) "[" ne_ident_list(lc) "]" "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) c f lc ] + [ gen_quote (make_cont k) (EConstr.of_constr c) f lc ] END diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 5f8a0b2d50..2ad97c75b3 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -105,6 +105,7 @@ open CErrors open Util open Names open Term +open EConstr open Pattern open Patternops open Constr_matching @@ -116,7 +117,8 @@ open Proofview.Notations We do that lazily, because this code can be linked before the constants are loaded in the environment *) -let constant dir s = Coqlib.gen_constant "Quote" ("quote"::dir) s +let constant dir s = + EConstr.of_constr (Coqlib.gen_constant "Quote" ("quote"::dir) s) let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") @@ -165,7 +167,7 @@ exchange ?1 and ?2 in the example above) module ConstrSet = Set.Make( struct - type t = constr + type t = Constr.constr let compare = constr_ord end) @@ -183,7 +185,7 @@ type inversion_scheme = { let i_can't_do_that () = error "Quote: not a simple fixpoint" -let decomp_term gl c = kind_of_term (EConstr.Unsafe.to_constr (Termops.strip_outer_cast (Tacmach.New.project gl) (EConstr.of_constr c))) +let decomp_term sigma c = EConstr.kind sigma (Termops.strip_outer_cast sigma c) (*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive @@ -195,8 +197,8 @@ let coerce_meta_out id = let coerce_meta_in n = Id.of_string ("M" ^ string_of_int n) -let compute_lhs typ i nargsi = - match kind_of_term typ with +let compute_lhs sigma typ i nargsi = + match EConstr.kind sigma typ with | Ind((sp,0),u) -> let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in mkApp (mkConstructU (((sp,0),i+1),u), argsi) @@ -205,60 +207,61 @@ let compute_lhs typ i nargsi = (*s This function builds the pattern from the RHS. Recursive calls are replaced by meta-variables ?i corresponding to those in the LHS *) -let compute_rhs bodyi index_of_f = +let compute_rhs env sigma bodyi index_of_f = let rec aux c = - match kind_of_term c with - | App (j, args) when isRel j && Int.equal (destRel j) index_of_f (* recursive call *) -> - let i = destRel (Array.last args) in + match EConstr.kind sigma c with + | App (j, args) when isRel sigma j && Int.equal (destRel sigma j) index_of_f (* recursive call *) -> + let i = destRel sigma (Array.last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> - PApp (pattern_of_constr (Global.env()) Evd.empty (EConstr.of_constr f), Array.map aux args) + PApp (pattern_of_constr env sigma f, Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> pattern_of_constr (Global.env())(*FIXME*) Evd.empty (EConstr.of_constr c) + | _ -> pattern_of_constr env sigma c in aux bodyi (*s Now the function [compute_ivs] itself *) let compute_ivs f cs gl = - let cst = try destConst f with DestKO -> i_can't_do_that () in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let cst = try destConst sigma f with DestKO -> i_can't_do_that () in let body = Environ.constant_value_in (Global.env()) cst in - match decomp_term gl body with + let body = EConstr.of_constr body in + match decomp_term sigma body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> - let (args3, body3) = decompose_lam body2 in + let (args3, body3) = decompose_lam sigma body2 in let nargs3 = List.length args3 in - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in let is_conv = Reductionops.is_conv env sigma in - begin match decomp_term gl body3 with + begin match decomp_term sigma body3 with | Case(_,p,c,lci) -> (*

Case c of c1 ... cn end *) let n_lhs_rhs = ref [] and v_lhs = ref (None : constr option) and c_lhs = ref (None : constr option) in Array.iteri (fun i ci -> - let argsi, bodyi = decompose_lam ci in + let argsi, bodyi = decompose_lam sigma ci in let nargsi = List.length argsi in (* REL (narg3 + nargsi + 1) is f *) (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) (* REL 1 to REL nargsi are argsi (reverse order) *) (* First we test if the RHS is the RHS for constants *) - if isRel bodyi && Int.equal (destRel bodyi) 1 then - c_lhs := Some (compute_lhs (snd (List.hd args3)) + if isRel sigma bodyi && Int.equal (destRel sigma bodyi) 1 then + c_lhs := Some (compute_lhs sigma (snd (List.hd args3)) i nargsi) (* Then we test if the RHS is the RHS for variables *) - else begin match decompose_app bodyi with + else begin match decompose_app sigma bodyi with | vmf, [_; _; a3; a4 ] - when isRel a3 && isRel a4 && is_conv (EConstr.of_constr vmf) - (EConstr.of_constr (Lazy.force coq_varmap_find)) -> - v_lhs := Some (compute_lhs + when isRel sigma a3 && isRel sigma a4 && is_conv vmf + (Lazy.force coq_varmap_find) -> + v_lhs := Some (compute_lhs sigma (snd (List.hd args3)) i nargsi) (* Third case: this is a normal LHS-RHS *) | _ -> n_lhs_rhs := - (compute_lhs (snd (List.hd args3)) i nargsi, - compute_rhs bodyi (nargs3 + nargsi + 1)) + (compute_lhs sigma (snd (List.hd args3)) i nargsi, + compute_rhs env sigma bodyi (nargs3 + nargsi + 1)) :: !n_lhs_rhs end) lci; @@ -266,8 +269,8 @@ let compute_ivs f cs gl = if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that (); (* The Cases predicate is a lambda; we assume no dependency *) - let p = match kind_of_term p with - | Lambda (_,_,p) -> Termops.pop (EConstr.of_constr p) + let p = match EConstr.kind sigma p with + | Lambda (_,_,p) -> EConstr.of_constr (Termops.pop p) | _ -> p in @@ -297,11 +300,11 @@ binary search trees (see file \texttt{Quote.v}) *) (* First the function to distinghish between constants (closed terms) and variables (open terms) *) -let rec closed_under cset t = - (ConstrSet.mem t cset) || - (match (kind_of_term t) with - | Cast(c,_,_) -> closed_under cset c - | App(f,l) -> closed_under cset f && Array.for_all (closed_under cset) l +let rec closed_under sigma cset t = + (ConstrSet.mem (EConstr.Unsafe.to_constr t) cset) || + (match EConstr.kind sigma t with + | Cast(c,_,_) -> closed_under sigma cset c + | App(f,l) -> closed_under sigma cset f && Array.for_all (closed_under sigma cset) l | _ -> false) (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete @@ -361,7 +364,7 @@ let path_of_int n = let rec subterm gl (t : constr) (t' : constr) = (pf_conv_x gl t t') || - (match (kind_of_term t) with + (match EConstr.kind (project gl) t with | App (f,args) -> Array.exists (fun t -> subterm gl t t') args | Cast(t,_,_) -> (subterm gl t t') | _ -> false) @@ -370,9 +373,10 @@ let rec subterm gl (t : constr) (t' : constr) = (* Since it's a partial order the algoritm of Sort.list won't work !! *) let rec sort_subterm gl l = + let sigma = project gl in let rec insert c = function | [] -> [c] - | (h::t as l) when eq_constr c h -> l (* Avoid doing the same work twice *) + | (h::t as l) when EConstr.eq_constr sigma c h -> l (* Avoid doing the same work twice *) | h::t -> if subterm gl c h then c::h::t else h::(insert c t) in match l with @@ -380,11 +384,15 @@ let rec sort_subterm gl l = | h::t -> insert h (sort_subterm gl t) module Constrhash = Hashtbl.Make - (struct type t = constr - let equal = eq_constr - let hash = hash_constr + (struct type t = Constr.constr + let equal = Term.eq_constr + let hash = Term.hash_constr end) +let subst_meta subst c = + let subst = List.map (fun (i, c) -> i, EConstr.Unsafe.to_constr c) subst in + EConstr.of_constr (Termops.subst_meta subst (EConstr.Unsafe.to_constr c)) + (*s Now we are able to do the inversion itself. We destructurate the term and use an imperative hashtable to store leafs that are already encountered. @@ -392,7 +400,7 @@ module Constrhash = Hashtbl.Make [ivs : inversion_scheme]\\ [lc: constr list]\\ [gl: goal sigma]\\ *) -let quote_terms ivs lc = +let quote_terms env sigma ivs lc = Coqlib.check_required_library ["Coq";"quote";"Quote"]; let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) @@ -402,34 +410,34 @@ let quote_terms ivs lc = match l with | (lhs, rhs)::tail -> begin try - let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs (EConstr.of_constr c)) in - let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux (EConstr.Unsafe.to_constr c_i))) s1 + let s1 = Id.Map.bindings (matches env sigma rhs c) in + let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 in - Termops.subst_meta s2 lhs + subst_meta s2 lhs with PatternMatchingFailure -> auxl tail end | [] -> begin match ivs.variable_lhs with | None -> begin match ivs.constant_lhs with - | Some c_lhs -> Termops.subst_meta [1, c] c_lhs + | Some c_lhs -> subst_meta [1, c] c_lhs | None -> anomaly (Pp.str "invalid inversion scheme for quote") end | Some var_lhs -> begin match ivs.constant_lhs with - | Some c_lhs when closed_under ivs.constants c -> - Termops.subst_meta [1, c] c_lhs + | Some c_lhs when closed_under sigma ivs.constants c -> + subst_meta [1, c] c_lhs | _ -> begin - try Constrhash.find varhash c + try Constrhash.find varhash (EConstr.Unsafe.to_constr c) with Not_found -> let newvar = - Termops.subst_meta [1, (path_of_int !counter)] + subst_meta [1, (path_of_int !counter)] var_lhs in begin incr counter; varlist := c :: !varlist; - Constrhash.add varhash c newvar; + Constrhash.add varhash (EConstr.Unsafe.to_constr c) newvar; newvar end end @@ -448,27 +456,32 @@ let quote_terms ivs lc = let quote f lid = Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let f = Tacmach.New.pf_global f gl in + let f = EConstr.of_constr f in let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in let ivs = compute_ivs f cl gl in let concl = Proofview.Goal.concl gl in - let concl = EConstr.Unsafe.to_constr concl in - let quoted_terms = quote_terms ivs [concl] in + let quoted_terms = quote_terms env sigma ivs [concl] in let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false in match ivs.variable_lhs with - | None -> Tactics.convert_concl (EConstr.of_constr (mkApp (f, [| p |]))) DEFAULTcast - | Some _ -> Tactics.convert_concl (EConstr.of_constr (mkApp (f, [| vm; p |]))) DEFAULTcast + | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast + | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast end } let gen_quote cont c f lid = Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let f = Tacmach.New.pf_global f gl in + let f = EConstr.of_constr f in let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in let ivs = compute_ivs f cl gl in - let quoted_terms = quote_terms ivs [c] in + let quoted_terms = quote_terms env sigma ivs [c] in let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 0987c44ae2..89ec4c1c52 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -30,7 +30,7 @@ END TACTIC EXTEND closed_term [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> - [ closed_term t l ] + [ closed_term (EConstr.of_constr t) l ] END open Pptactic diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index b720b2e0a8..2f6c00c9d6 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -97,9 +97,10 @@ let protect_tac_in map id = let closed_term t l = let open Quote_plugin in + Proofview.tclEVARMAP >>= fun sigma -> let l = List.map Universes.constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in - if Quote.closed_under cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) + if Quote.closed_under sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) (* TACTIC EXTEND echo | [ "echo" constr(t) ] -> diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index f417c87cde..89538eb24c 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -19,7 +19,7 @@ val protect_tac_in : string -> Id.t -> unit Proofview.tactic val protect_tac : string -> unit Proofview.tactic -val closed_term : constr -> global_reference list -> unit Proofview.tactic +val closed_term : EConstr.constr -> global_reference list -> unit Proofview.tactic val process_ring_mods : constr_expr ring_mod list -> -- 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. --- plugins/cc/cctac.ml | 138 ++++++++++++++++++++++++-------------------- plugins/cc/cctac.mli | 2 +- plugins/cc/g_congruence.ml4 | 4 +- 3 files changed, 77 insertions(+), 67 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 130f01e97d..0d48b65d01 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -13,6 +13,7 @@ open Names open Inductiveops open Declarations open Term +open EConstr open Vars open Tacmach open Tactics @@ -27,6 +28,10 @@ open Proofview.Notations 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 reference dir s = lazy (Coqlib.gen_reference "CC" dir s) let _f_equal = reference ["Init";"Logic"] "f_equal" @@ -39,27 +44,26 @@ let _False = reference ["Init";"Logic"] "False" let _True = reference ["Init";"Logic"] "True" let _I = reference ["Init";"Logic"] "I" -let whd env= - let infos=CClosure.create_clos_infos CClosure.betaiotazeta env in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) +let whd env sigma t = + Reductionops.clos_whd_flags CClosure.betaiotazeta env sigma t -let whd_delta env= - let infos=CClosure.create_clos_infos CClosure.all env in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) +let whd_delta env sigma t = + Reductionops.clos_whd_flags CClosure.all env sigma t (* decompose member of equality in an applicative format *) (** FIXME: evar leak *) -let sf_of env sigma c = e_sort_of env (ref sigma) (EConstr.of_constr c) +let sf_of env sigma c = e_sort_of env (ref sigma) c let rec decompose_term env sigma t= - match kind_of_term (whd env t) with + match EConstr.kind sigma (whd env sigma t) with App (f,args)-> let tf=decompose_term env sigma f in let targs=Array.map (decompose_term env sigma) args in Array.fold_left (fun s t->Appli (s,t)) tf targs - | Prod (_,a,_b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr _b) -> - let b = Termops.pop (EConstr.of_constr _b) in + | Prod (_,a,_b) when noccurn sigma 1 _b -> + let b = Termops.pop _b in + let b = EConstr.of_constr b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in Appli(Appli(Product (sort_a,sort_b) , @@ -77,28 +81,27 @@ let rec decompose_term env sigma t= | Ind c -> let (mind,i_ind),u = c in let canon_mind = mind_of_kn (canonical_mind mind) in - let canon_ind = canon_mind,i_ind in (Symb (mkIndU (canon_ind,u))) + let canon_ind = canon_mind,i_ind in (Symb (Constr.mkIndU (canon_ind,u))) | Const (c,u) -> let canon_const = constant_of_kn (canonical_con c) in - (Symb (mkConstU (canon_const,u))) + (Symb (Constr.mkConstU (canon_const,u))) | Proj (p, c) -> let canon_const kn = constant_of_kn (canonical_con kn) in let p' = Projection.map canon_const p in - (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) + (Appli (Symb (Constr.mkConst (Projection.constant p')), decompose_term env sigma c)) | _ -> - let t = Termops.strip_outer_cast sigma (EConstr.of_constr t) in - let t = EConstr.Unsafe.to_constr t in - if closed0 t then Symb t else raise Not_found + let t = Termops.strip_outer_cast sigma t in + if closed0 sigma t then Symb (EConstr.to_constr sigma t) else raise Not_found (* decompose equality in members and type *) -open Globnames +open Termops let atom_of_constr env sigma term = - let wh = (whd_delta env term) in - let kot = kind_of_term wh in + let wh = whd_delta env sigma term in + let kot = EConstr.kind sigma wh in match kot with App (f,args)-> - if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 + if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -106,15 +109,16 @@ let atom_of_constr env sigma term = | _ -> `Other (decompose_term env sigma term) let rec pattern_of_constr env sigma c = - match kind_of_term (whd env c) with + match EConstr.kind sigma (whd env sigma c) with App (f,args)-> let pf = decompose_term env sigma f in let pargs,lrels = List.split (Array.map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Int.Set.union Int.Set.empty lrels - | Prod (_,a,_b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr _b) -> - let b = Termops.pop (EConstr.of_constr _b) in + | Prod (_,a,_b) when noccurn sigma 1 _b -> + let b = Termops.pop _b in + let b = EConstr.of_constr b in let pa,sa = pattern_of_constr env sigma a in let pb,sb = pattern_of_constr env sigma b in let sort_b = sf_of env sigma b in @@ -132,19 +136,19 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= - try destApp (whd_delta env term) with DestKO -> raise Not_found in - if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 + try destApp sigma (whd_delta env sigma term) with DestKO -> raise Not_found in + if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in let valid1 = if not (Int.equal (Int.Set.cardinal rels1) nrels) then Creates_variables else if non_trivial patt1 then Normal - else Trivial args.(0) + else Trivial (EConstr.to_constr sigma args.(0)) and valid2 = if not (Int.equal (Int.Set.cardinal rels2) nrels) then Creates_variables else if non_trivial patt2 then Normal - else Trivial args.(0) in + else Trivial (EConstr.to_constr sigma args.(0)) in if valid1 != Creates_variables || valid2 != Creates_variables then nrels,valid1,patt1,valid2,patt2 @@ -152,28 +156,28 @@ let patterns_of_constr env sigma nrels term= else raise Not_found let rec quantified_atom_of_constr env sigma nrels term = - match kind_of_term (whd_delta env term) with + match EConstr.kind sigma (whd_delta env sigma term) with Prod (id,atom,ff) -> - if is_global (Lazy.force _False) ff then + if is_global sigma (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff + quantified_atom_of_constr (Environ.push_rel (local_assum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts let litteral_of_constr env sigma term= - match kind_of_term (whd_delta env term) with + match EConstr.kind sigma (whd_delta env sigma term) with | Prod (id,atom,ff) -> - if is_global (Lazy.force _False) ff then + if is_global sigma (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) else begin try - quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff + quantified_atom_of_constr (Environ.push_rel (local_assum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -197,8 +201,8 @@ let make_prb gls depth additionnal_terms = (fun decl -> let id = NamedDecl.get_id decl in begin - let cid=mkVar id in - match litteral_of_constr env sigma (NamedDecl.get_type decl) with + let cid=Constr.mkVar id in + match litteral_of_constr env sigma (EConstr.of_constr (NamedDecl.get_type decl)) with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> @@ -217,7 +221,7 @@ let make_prb gls depth additionnal_terms = | `Nrule patts -> add_quant state id false patts end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it)); begin - match atom_of_constr env sigma (Evarutil.nf_evar sigma (pf_concl gls)) with + match atom_of_constr env sigma (EConstr.of_constr (pf_concl gls)) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter @@ -230,8 +234,7 @@ let make_prb gls depth additionnal_terms = let build_projection intype (cstr:pconstructor) special default gls= let ci= (snd(fst cstr)) in - let body=Equality.build_selector (pf_env gls) (project gls) ci (EConstr.mkRel 1) (EConstr.of_constr intype) (EConstr.of_constr special) default in - let body = EConstr.Unsafe.to_constr body in + let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in mkLambda(Name id,intype,body) @@ -240,10 +243,10 @@ let build_projection intype (cstr:pconstructor) special default gls= let _M =mkMeta let app_global f args k = - Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (EConstr.of_constr (mkApp (fc, args)))) + Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (EConstr.of_constr fc, args))) let new_app_global f args k = - Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (EConstr.of_constr (mkApp (fc, args)))) + Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (EConstr.of_constr fc, args))) let new_refine c = Proofview.V82.tactic (refine c) let refine c = refine c @@ -259,20 +262,24 @@ let refresh_type env evm ty = (Some false) env evm ty let refresh_universes ty k = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in - let evm, ty = refresh_type env evm (EConstr.of_constr ty) in - Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k ty) + let evm, ty = refresh_type env evm ty in + let ty = EConstr.of_constr ty in + Sigma.Unsafe.of_pair (k ty, evm) end } +let constr_of_term c = EConstr.of_constr (constr_of_term c) + let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> - let type_of t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr t) in + let type_of t = EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl t) in try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check (EConstr.of_constr c) | SymAx c -> + let c = EConstr.of_constr c in let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in refresh_universes (type_of l) (fun typ -> @@ -321,7 +328,6 @@ let rec proof_tac p : unit Proofview.tactic = let special=mkRel (1+nargs-argind) in refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> - let default = EConstr.of_constr default in let proj = Tacmach.New.of_old (build_projection intype cstr special default) gl in @@ -336,12 +342,11 @@ let refute_tac c t1 t2 p = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in - let false_t = EConstr.of_constr false_t in let k intype = let neweq= new_app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] - in refresh_universes (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr tt1)) k + in refresh_universes (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl tt1)) k end } let refine_exact_check c gl = @@ -359,7 +364,7 @@ let convert_to_goal_tac c t1 t2 p = let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] - in refresh_universes (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr tt2)) k + in refresh_universes (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl tt2)) k end } let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -367,8 +372,6 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = let tt2=constr_of_term t2 in let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in let false_t=mkApp (c2,[|mkVar h|]) in - let false_t = EConstr.of_constr false_t in - let tt2 = EConstr.of_constr tt2 in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] @@ -381,20 +384,21 @@ let discriminate_tac (cstr,u as cstru) p = let concl = Proofview.Goal.concl gl in let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in let identity = Universes.constr_of_global (Lazy.force _I) in + let identity = EConstr.of_constr identity in let trivial = Universes.constr_of_global (Lazy.force _True) in + let trivial = EConstr.of_constr trivial in let evm = Tacmach.New.project gl in - let evm, intype = refresh_type env evm (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr t1))) in + let evm, intype = refresh_type env evm (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl t1)) in + let intype = EConstr.of_constr intype in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in - let concl = EConstr.Unsafe.to_constr concl in let injt=app_global _f_equal [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = injt (fun injt -> - let injt = EConstr.Unsafe.to_constr injt in app_global _eq_rect [|outtype;trivial;pred;identity;concl;injt|] k) in let neweq=new_app_global _eq [|intype;t1;t2|] in @@ -410,7 +414,7 @@ let build_term_to_complete uf meta pac = let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (List.init pac.arity meta) in let all_args = List.rev_append real_args dummy_args in - applistc (mkConstructU cinfo.ci_constr) all_args + applist (mkConstructU cinfo.ci_constr, all_args) let cc_tactic depth additionnal_terms = Proofview.Goal.nf_enter { enter = begin fun gl -> @@ -448,7 +452,7 @@ let cc_tactic depth additionnal_terms = str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") - (Termops.print_constr_env env) + (EConstr.Unsafe.to_constr %> Termops.print_constr_env env) terms_to_complete ++ str ")\"," end ++ @@ -459,10 +463,13 @@ let cc_tactic depth additionnal_terms = let ta=term uf dis.lhs and tb=term uf dis.rhs in match dis.rule with Goal -> proof_tac p - | Hyp id -> refute_tac id ta tb p + | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p | HeqG id -> + let id = EConstr.of_constr id in convert_to_goal_tac id ta tb p | HeqnH (ida,idb) -> + let ida = EConstr.of_constr ida in + let idb = EConstr.of_constr idb in convert_to_hyp_tac ida ta idb tb p end } @@ -487,20 +494,23 @@ let congruence_tac depth l = let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> + let fc = EConstr.of_constr fc in Proofview.Goal.enter { enter = begin fun gl -> let open Tacmach.New in - let evm, ty = pf_apply type_of gl (EConstr.of_constr c1) in - let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm (EConstr.of_constr ty) in + let evm, ty = pf_apply type_of gl c1 in + let ty = EConstr.of_constr ty in + let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in + let ty = EConstr.of_constr ty in let term = mkApp (fc, [| ty; c1; c2 |]) in - let evm, _ = type_of (pf_env gl) evm (EConstr.of_constr term) in + let evm, _ = type_of (pf_env gl) evm term in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) - (k (EConstr.of_constr term)) + (k term) end }) let f_equal = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in - let concl = EConstr.Unsafe.to_constr concl in + let sigma = Tacmach.New.project gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) Tacticals.New.tclTHENS @@ -509,9 +519,9 @@ let f_equal = with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE - begin match kind_of_term concl with - | App (r,[|_;t;t'|]) when Globnames.is_global (Lazy.force _eq) r -> - begin match kind_of_term t, kind_of_term t' with + begin match EConstr.kind sigma concl with + | App (r,[|_;t;t'|]) when is_global sigma (Lazy.force _eq) r -> + begin match EConstr.kind sigma t, EConstr.kind sigma t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 []) diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 7c1d9f1c07..de6eb982ee 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -7,7 +7,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Term +open EConstr open Proof_type val proof_tac: Ccproof.proof -> unit Proofview.tactic diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 6f6811334d..b787e824f8 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -18,9 +18,9 @@ DECLARE PLUGIN "cc_plugin" TACTIC EXTEND cc [ "congruence" ] -> [ congruence_tac 1000 [] ] |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] - |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] + |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 (List.map EConstr.of_constr l) ] |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> - [ congruence_tac n l ] + [ congruence_tac n (List.map EConstr.of_constr l) ] END TACTIC EXTEND f_equal -- cgit v1.2.3 From ffb59901f568351401f2f3d1f3334031658b8880 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 14:22:54 +0100 Subject: Setoid_ring API using EConstr. --- plugins/setoid_ring/g_newring.ml4 | 20 +++-- plugins/setoid_ring/newring.ml | 183 +++++++++++++++++++++----------------- plugins/setoid_ring/newring.mli | 41 ++------- 3 files changed, 117 insertions(+), 127 deletions(-) (limited to 'plugins') diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 89ec4c1c52..13cf8330b5 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -77,9 +77,7 @@ END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> - [ let l = match l with None -> [] | Some l -> l in - let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in - add_theory id (ic t) set k cst (pre,post) power sign div] + [ let l = match l with None -> [] | Some l -> l in add_theory id t l] | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> @@ -92,7 +90,11 @@ END TACTIC EXTEND ring_lookup | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> - [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t] + [ + let lH = List.map EConstr.of_constr lH in + let lrt = List.map EConstr.of_constr lrt in + let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t + ] END let pr_field_mod = function @@ -114,9 +116,7 @@ END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> - [ let l = match l with None -> [] | Some l -> l in - let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in - add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] + [ let l = match l with None -> [] | Some l -> l in add_field_theory id t l ] | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> @@ -129,5 +129,9 @@ END TACTIC EXTEND field_lookup | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> - [ let (t,l) = List.sep_last lt in field_lookup f lH l t ] + [ + let lH = List.map EConstr.of_constr lH in + let lt = List.map EConstr.of_constr lt in + let (t,l) = List.sep_last lt in field_lookup f lH l t + ] END diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 2f6c00c9d6..63eccaa400 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -11,6 +11,7 @@ open CErrors open Util open Names open Term +open EConstr open Vars open CClosure open Environ @@ -42,9 +43,9 @@ let tag_arg tag_rec map subs i c = | Prot -> mk_atom c | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c -let global_head_of_constr c = - let f, args = decompose_app c in - try global_of_constr f +let global_head_of_constr sigma c = + let f, args = decompose_app sigma c in + try fst (Termops.global_of_constr sigma f) with Not_found -> anomaly (str "global_head_of_constr") let global_of_constr_nofail c = @@ -52,6 +53,7 @@ let global_of_constr_nofail c = with Not_found -> VarRef (Id.of_string "dummy") let rec mk_clos_but f_map subs t = + let open Term in match f_map (global_of_constr_nofail t) with | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t | None -> @@ -61,6 +63,7 @@ let rec mk_clos_but f_map subs t = | _ -> mk_atom t) and mk_clos_app_but f_map subs f args n = + let open Term in if n >= Array.length args then mk_atom(mkApp(f, args)) else let fargs, args' = Array.chop n args in @@ -81,10 +84,11 @@ let lookup_map map = with Not_found -> user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") -let protect_red map env sigma c = - let c = EConstr.Unsafe.to_constr c in - EConstr.of_constr (kl (create_clos_infos all env) - (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c));; +let protect_red map env sigma c0 = + let evars ev = Evarutil.safe_evar_value sigma ev in + let c = EConstr.Unsafe.to_constr c0 in + EConstr.of_constr (kl (create_clos_infos ~evars all env) + (mk_clos_but (lookup_map map sigma c0) (Esubst.subs_id 0) c));; let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None @@ -137,14 +141,16 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" let ic c = let env = Global.env() in let sigma = Evd.from_env env in - Constrintern.interp_open_constr env sigma c + let sigma, c = Constrintern.interp_open_constr env sigma c in + (sigma, EConstr.of_constr c) let ic_unsafe c = (*FIXME remove *) let env = Global.env() in let sigma = Evd.from_env env in - fst (Constrintern.interp_constr env sigma c) + EConstr.of_constr (fst (Constrintern.interp_constr env sigma c)) let decl_constant na ctx c = + let open Constr in let vars = Universes.universes_of_constr c in let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in mkConst(declare_constant (Id.of_string na) @@ -197,6 +203,7 @@ let get_res = let exec_tactic env evd n f args = let fold arg (i, vars, lfun) = + let arg = EConstr.Unsafe.to_constr arg in let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar (Loc.ghost, id)) in (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun) @@ -212,7 +219,8 @@ let exec_tactic env evd n f args = let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in - Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd) + let nf c = nf (constr_of c) in + Array.map nf !tactic_res, snd (Evd.universe_context evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -222,7 +230,7 @@ let stdlib_modules = ] let coq_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)) let coq_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) @@ -238,21 +246,22 @@ let lapp f args = mkApp(Lazy.force f,args) let plapp evd f args = let fc = Evarutil.e_new_global evd (Lazy.force f) in + let fc = EConstr.of_constr fc in mkApp(fc,args) -let dest_rel0 t = - match kind_of_term t with +let dest_rel0 sigma t = + match EConstr.kind sigma t with | App(f,args) when Array.length args >= 2 -> let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in - if closed0 rel then + if closed0 sigma rel then (rel,args.(Array.length args - 2),args.(Array.length args - 1)) else error "ring: cannot find relation (not closed)" | _ -> error "ring: cannot find relation" -let rec dest_rel t = - match kind_of_term t with - | Prod(_,_,c) -> dest_rel c - | _ -> dest_rel0 t +let rec dest_rel sigma t = + match EConstr.kind sigma t with + | Prod(_,_,c) -> dest_rel sigma c + | _ -> dest_rel0 sigma t (****************************************************************************) (* Library linking *) @@ -267,7 +276,7 @@ let plugin_modules = ] let my_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)) let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) @@ -311,13 +320,13 @@ let coq_mkhypo = my_reference "mkhypo" let coq_hypo = my_reference "hypo" (* Equality: do not evaluate but make recursive call on both sides *) -let map_with_eq arg_map c = - let (req,_,_) = dest_rel c in +let map_with_eq arg_map sigma c = + let (req,_,_) = dest_rel sigma c in interp_map - ((global_head_of_constr req,(function -1->Prot|_->Rec)):: + ((global_head_of_constr sigma req,(function -1->Prot|_->Rec)):: List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) -let map_without_eq arg_map _ = +let map_without_eq arg_map _ _ = interp_map (List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) let _ = add_map "ring" @@ -346,9 +355,9 @@ let ring_for_carrier r = Cmap.find r !from_carrier let find_ring_structure env sigma l = match l with | t::cl' -> - let ty = Retyping.get_type_of env sigma (EConstr.of_constr t) in + let ty = Retyping.get_type_of env sigma t in let check c = - let ty' = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") @@ -381,7 +390,7 @@ let subst_th (subst,th) = let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && eq' == th.ring_req && - eq_constr set' th.ring_setoid && + Term.eq_constr set' th.ring_setoid && ext' == th.ring_ext && morph' == th.ring_morph && th' == th.ring_th && @@ -417,18 +426,11 @@ let theory_to_obj : ring_info -> obj = let setoid_of_relation env evd a r = - let a = EConstr.of_constr a in - let r = EConstr.of_constr r in try let evm = !evd in let evm, refl = Rewrite.get_reflexive_proof env evm a r in let evm, sym = Rewrite.get_symmetric_proof env evm a r in let evm, trans = Rewrite.get_transitive_proof env evm a r in - let refl = EConstr.Unsafe.to_constr refl in - let sym = EConstr.Unsafe.to_constr sym in - let trans = EConstr.Unsafe.to_constr trans in - let a = EConstr.Unsafe.to_constr a in - let r = EConstr.Unsafe.to_constr r in evd := evm; lapp coq_mk_Setoid [|a ; r ; refl; sym; trans |] with Not_found -> @@ -494,44 +496,37 @@ let op_smorph r add mul req m1 m2 = (* (setoid,op_morph) *) let ring_equality env evd (r,add,mul,opp,req) = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + let pr_constr c = pr_constr (EConstr.to_constr !evd c) in + match EConstr.kind !evd req with + | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> let setoid = plapp evd coq_eq_setoid [|r|] in let op_morph = match opp with Some opp -> plapp evd coq_eq_morph [|r;add;mul;opp|] | None -> plapp evd coq_eq_smorph [|r;add;mul|] in - let setoid = Typing.e_solve_evars env evd (EConstr.of_constr setoid) in - let op_morph = Typing.e_solve_evars env evd (EConstr.of_constr op_morph) in + let setoid = Typing.e_solve_evars env evd setoid in + let op_morph = Typing.e_solve_evars env evd op_morph in + let setoid = EConstr.of_constr setoid in + let op_morph = EConstr.of_constr op_morph in (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in - let signature = - let r = EConstr.of_constr r in - let req = EConstr.of_constr req in - [Some (r,Some req);Some (r,Some req)],Some(r,Some req) - in -(* let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in *) + let signature = [Some (r,Some req);Some (r,Some req)],Some(r,Some req) in let add_m, add_m_lem = - try Rewrite.default_morphism signature (EConstr.of_constr add) + try Rewrite.default_morphism signature add with Not_found -> error "ring addition should be declared as a morphism" in - let add_m_lem = EConstr.Unsafe.to_constr add_m_lem in let mul_m, mul_m_lem = - try Rewrite.default_morphism signature (EConstr.of_constr mul) + try Rewrite.default_morphism signature mul with Not_found -> error "ring multiplication should be declared as a morphism" in - let mul_m_lem = EConstr.Unsafe.to_constr mul_m_lem in let op_morph = match opp with | Some opp -> (let opp_m,opp_m_lem = - let r = EConstr.of_constr r in - let req = EConstr.of_constr req in - try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) (EConstr.of_constr opp) + try Rewrite.default_morphism ([Some(r,Some req)],Some(r,Some req)) opp with Not_found -> error "ring opposite should be declared as a morphism" in - let opp_m_lem = EConstr.Unsafe.to_constr opp_m_lem in let op_morph = op_morph r add mul opp req add_m_lem mul_m_lem opp_m_lem in Flags.if_verbose @@ -558,16 +553,17 @@ let build_setoid_params env evd r add mul opp req eqth = | None -> ring_equality env evd (r,add,mul,opp,req) let dest_ring env sigma th_spec = - let th_typ = Retyping.get_type_of env sigma (EConstr.of_constr th_spec) in - match kind_of_term th_typ with + let th_typ = Retyping.get_type_of env sigma th_spec in + let th_typ = EConstr.of_constr th_typ in + match EConstr.kind sigma th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) -> + when eq_constr_nounivs sigma f (Lazy.force coq_almost_ring_theory) -> (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) - when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) -> + when eq_constr_nounivs sigma f (Lazy.force coq_semi_ring_theory) -> (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr_nounivs f (Lazy.force coq_ring_theory) -> + when eq_constr_nounivs sigma f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" @@ -589,21 +585,24 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = TacArg(Loc.ghost,TacCall(Loc.ghost,t,[])) let make_hyp env evd c = - let t = Retyping.get_type_of env !evd (EConstr.of_constr c) in + let t = Retyping.get_type_of env !evd c in + let t = EConstr.of_constr t in plapp evd coq_mkhypo [|t;c|] let make_hyp_list env evd lH = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in + let carrier = EConstr.of_constr carrier in let l = List.fold_right (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH (plapp evd coq_nil [|carrier|]) in - let l' = Typing.e_solve_evars env evd (EConstr.of_constr l) in + let l' = Typing.e_solve_evars env evd l in Evarutil.nf_evars_universes !evd l' let interp_power env evd pow = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in + let carrier = EConstr.of_constr carrier in match pow with | None -> let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in @@ -619,6 +618,7 @@ let interp_power env evd pow = let interp_sign env evd sign = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in + let carrier = EConstr.of_constr carrier in match sign with | None -> plapp evd coq_None [|carrier|] | Some spec -> @@ -628,6 +628,7 @@ let interp_sign env evd sign = let interp_div env evd div = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in + let carrier = EConstr.of_constr carrier in match div with | None -> plapp evd coq_None [|carrier|] | Some spec -> @@ -635,7 +636,7 @@ let interp_div env evd div = plapp evd coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = +let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); let env = Global.env() in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in @@ -665,6 +666,9 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = match post with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in + let r = EConstr.to_constr sigma r in + let req = EConstr.to_constr sigma req in + let sth = EConstr.to_constr sigma sth in let _ = Lib.add_leaf name (theory_to_obj @@ -712,20 +716,25 @@ let process_ring_mods l = let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) +let add_theory id rth l = + let (sigma, rth) = ic rth in + let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in + add_theory0 id (sigma, rth) set k cst (pre,post) power sign div + (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) -let make_args_list rl t = +let make_args_list sigma rl t = match rl with - | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] + | [] -> let (_,t1,t2) = dest_rel0 sigma t in [t1;t2] | _ -> rl let make_term_list env evd carrier rl = let l = List.fold_right (fun x l -> plapp evd coq_cons [|carrier;x;l|]) rl (plapp evd coq_nil [|carrier|]) - in Typing.e_solve_evars env evd (EConstr.of_constr l) + in Typing.e_solve_evars env evd l let carg = Tacinterp.Value.of_constr let tacarg expr = @@ -751,10 +760,10 @@ let ring_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try (* find_ring_strucure can raise an exception *) + let rl = make_args_list sigma rl t in let evdref = ref sigma in - let rl = make_args_list rl t in let e = find_ring_structure env sigma rl in - let rl = carg (make_term_list env evdref e.ring_carrier rl) in + let rl = carg (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let ring = ltac_ring_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) @@ -814,21 +823,23 @@ let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" let dest_field env evd th_spec = - let th_typ = Retyping.get_type_of env !evd (EConstr.of_constr th_spec) in - match kind_of_term th_typ with + let open Termops in + let th_typ = Retyping.get_type_of env !evd th_spec in + let th_typ = EConstr.of_constr th_typ in + match EConstr.kind !evd th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global (Lazy.force afield_theory) f -> + when is_global !evd (Lazy.force afield_theory) f -> let rth = plapp evd af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global (Lazy.force field_theory) f -> + when is_global !evd (Lazy.force field_theory) f -> let rth = plapp evd f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when is_global (Lazy.force sfield_theory) f -> + when is_global !evd (Lazy.force sfield_theory) f -> let rth = plapp evd sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) @@ -843,9 +854,9 @@ let find_field_structure env sigma l = check_required_library (cdir@["Field_tac"]); match l with | t::cl' -> - let ty = Retyping.get_type_of env sigma (EConstr.of_constr t) in + let ty = Retyping.get_type_of env sigma t in let check c = - let ty' = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let ty' = Retyping.get_type_of env sigma c in if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") @@ -908,31 +919,31 @@ let ftheory_to_obj : field_info -> obj = classify_function = (fun x -> Substitute x) } let field_equality evd r inv req = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> - mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) + match EConstr.kind !evd req with + | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> + let c = Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr in + let c = EConstr.of_constr c in + mkApp(c,[|r;r;inv|]) | _ -> let _setoid = setoid_of_relation (Global.env ()) evd r req in - let r = EConstr.of_constr r in - let req = EConstr.of_constr req in let signature = [Some (r,Some req)],Some(r,Some req) in - let inv = EConstr.of_constr inv in let inv_m, inv_m_lem = try Rewrite.default_morphism signature inv with Not_found -> error "field inverse should be declared as a morphism" in - let inv_m_lem = EConstr.Unsafe.to_constr inv_m_lem in inv_m_lem -let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv = +let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign odiv = + let open Constr in check_required_library (cdir@["Field_tac"]); + let (sigma,fth) = ic fth in let env = Global.env() in let evd = ref sigma in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = dest_field env evd fth in let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in + let _ = add_theory0 name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in let (pow_tac, pspec) = interp_power env evd power in let sspec = interp_sign env evd sign in let dspec = interp_div env evd odiv in @@ -947,7 +958,7 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power let lemma4 = params.(6) in let cond_lemma = match inj with - | Some thm -> mkApp(params.(8),[|thm|]) + | Some thm -> mkApp(params.(8),[|EConstr.to_constr sigma thm|]) | None -> params.(7) in let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") ctx lemma1 in @@ -969,6 +980,8 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power match post with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in + let r = EConstr.to_constr sigma r in + let req = EConstr.to_constr sigma req in let _ = Lib.add_leaf name (ftheory_to_obj @@ -1008,6 +1021,10 @@ let process_field_mods l = let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) +let add_field_theory id t mods = + let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods mods in + add_field_theory0 id t set k cst_tac inj (pre,post) power sign div + let ltac_field_structure e = let req = carg e.field_req in let cst_tac = tacarg e.field_cst_tac in @@ -1027,10 +1044,10 @@ let field_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try + let rl = make_args_list sigma rl t in let evdref = ref sigma in - let rl = make_args_list rl t in let e = find_field_structure env sigma rl in - let rl = carg (make_term_list env evdref e.field_carrier rl) in + let rl = carg (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let field = ltac_field_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index 89538eb24c..4367d021c0 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -8,6 +8,7 @@ open Names open Constr +open EConstr open Libnames open Globnames open Constrexpr @@ -21,26 +22,10 @@ val protect_tac : string -> unit Proofview.tactic val closed_term : EConstr.constr -> global_reference list -> unit Proofview.tactic -val process_ring_mods : - constr_expr ring_mod list -> - constr coeff_spec * (constr * constr) option * - cst_tac_spec option * raw_tactic_expr option * - raw_tactic_expr option * - (cst_tac_spec * constr_expr) option * - constr_expr option * constr_expr option - val add_theory : Id.t -> - Evd.evar_map * constr -> - (constr * constr) option -> - constr coeff_spec -> - cst_tac_spec option -> - raw_tactic_expr option * raw_tactic_expr option -> - (cst_tac_spec * constr_expr) option -> - constr_expr option -> - constr_expr option -> unit - -val ic : constr_expr -> Evd.evar_map * constr + constr_expr -> + constr_expr ring_mod list -> unit val from_name : ring_info Spmap.t ref @@ -49,26 +34,10 @@ val ring_lookup : constr list -> constr list -> constr -> unit Proofview.tactic -val process_field_mods : - constr_expr field_mod list -> - constr coeff_spec * - (constr * constr) option * constr option * - cst_tac_spec option * raw_tactic_expr option * - raw_tactic_expr option * - (cst_tac_spec * constr_expr) option * - constr_expr option * constr_expr option - val add_field_theory : Id.t -> - Evd.evar_map * constr -> - (constr * constr) option -> - constr coeff_spec -> - cst_tac_spec option -> - constr option -> - raw_tactic_expr option * raw_tactic_expr option -> - (cst_tac_spec * constr_expr) option -> - constr_expr option -> - constr_expr option -> unit + constr_expr -> + constr_expr field_mod list -> unit val field_from_name : field_info Spmap.t ref -- 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. --- plugins/cc/cctac.ml | 2 -- plugins/decl_mode/decl_interp.ml | 2 +- plugins/firstorder/formula.ml | 4 +++- plugins/firstorder/unify.ml | 4 +++- plugins/funind/functional_principles_proofs.ml | 29 +++++++++++++------------- plugins/funind/functional_principles_types.ml | 20 ++++++++++-------- plugins/funind/invfun.ml | 8 +++---- plugins/funind/merge.ml | 7 ++++--- plugins/funind/recdef.ml | 3 ++- plugins/quote/quote.ml | 2 +- plugins/setoid_ring/newring.ml | 5 ----- 11 files changed, 44 insertions(+), 42 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 0d48b65d01..7a99c45a8b 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -63,7 +63,6 @@ let rec decompose_term env sigma t= Array.fold_left (fun s t->Appli (s,t)) tf targs | Prod (_,a,_b) when noccurn sigma 1 _b -> let b = Termops.pop _b in - let b = EConstr.of_constr b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in Appli(Appli(Product (sort_a,sort_b) , @@ -118,7 +117,6 @@ let rec pattern_of_constr env sigma c = List.fold_left Int.Set.union Int.Set.empty lrels | Prod (_,a,_b) when noccurn sigma 1 _b -> let b = Termops.pop _b in - let b = EConstr.of_constr b in let pa,sa = pattern_of_constr env sigma a in let pb,sb = pattern_of_constr env sigma b in let sort_b = sf_of env sigma b in diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index ddf0137354..ae057b4581 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -374,7 +374,7 @@ let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = match st'.st_it with Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} | This _ -> {st_it = This st.st_it;st_label=st.st_label} in - let thyps = fst (match_hyps blend nam2 (Termops.pop (EConstr.of_constr rest1)) hyps) in + let thyps = fst (match_hyps blend nam2 (Vars.lift (-1) rest1) hyps) in tparams,{pat_vars=tpatvars; pat_aliases=taliases; pat_constr=pat_pat; diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 96b991e1fd..87bac2fe39 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -76,11 +76,13 @@ type kind_of_formula= | Forall of constr*constr | Atom of constr +let pop t = Vars.lift (-1) t + let kind_of_formula gl term = let normalize=special_nf gl in let cciterm=special_whd gl term in match match_with_imp_term (project gl) (EConstr.of_constr cciterm) with - Some (a,b)-> Arrow(EConstr.Unsafe.to_constr a,(pop b)) + Some (a,b)-> Arrow(EConstr.Unsafe.to_constr a,(pop (EConstr.Unsafe.to_constr b))) |_-> match match_with_forall_term (project gl) (EConstr.of_constr cciterm) with Some (_,a,b)-> Forall(EConstr.Unsafe.to_constr a,EConstr.Unsafe.to_constr b) diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index 5520c7e35d..7cbfb8e7de 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -24,6 +24,8 @@ exception UFAIL of constr*constr let strip_outer_cast t = EConstr.Unsafe.to_constr (strip_outer_cast Evd.empty (EConstr.of_constr t)) (** FIXME *) +let pop t = Vars.lift (-1) t + let unif t1 t2= let evd = Evd.empty in (** FIXME *) let bige=Queue.create () @@ -62,7 +64,7 @@ let unif t1 t2= | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> - Queue.add (a,c) bige;Queue.add (pop (EConstr.of_constr b),pop (EConstr.of_constr d)) bige + Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> Queue.add (pa,pb) bige; Queue.add (ca,cb) bige; diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 188368082c..cc29d68f59 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -95,6 +95,7 @@ let list_chop ?(msg="") n l = with Failure (msg') -> failwith (msg ^ msg') +let pop t = Vars.lift (-1) t let make_refl_eq constructor type_of_t t = (* let refl_equal_term = Lazy.force refl_equal in *) @@ -289,7 +290,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = Termops.pop (EConstr.of_constr end_of_type) in (*the equation will be removed *) + let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 @@ -311,9 +312,9 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop (EConstr.of_constr end_of_type),ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) + (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) with Not_found -> - (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) + (Term.mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) 1 (new_end_of_type,0,witness_fun) @@ -416,7 +417,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = let coq_I = Coqlib.build_coq_I () in let rec scan_type context type_of_hyp : tactic = if isLetIn type_of_hyp then - let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in + let real_type_of_hyp = Term.it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = @@ -429,13 +430,13 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = then begin let (x,t_x,t') = destProd type_of_hyp in - let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in + let actual_real_type_of_hyp = Term.it_mkProd_or_LetIn t' context in if is_property ptes_infos t_x actual_real_type_of_hyp then begin let pte,pte_args = (destApp t_x) in let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = Termops.pop (EConstr.of_constr t') in - let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in + let popped_t' = pop t' in + let real_type_of_hyp = Term.it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST @@ -486,9 +487,9 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) - let popped_t' = Termops.pop (EConstr.of_constr t') in + let popped_t' = pop t' in let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context + Term.it_mkProd_or_LetIn popped_t' context in let prove_trivial = let nb_intro = List.length context in @@ -515,9 +516,9 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ] else if is_trivial_eq t_x then (* t_x := t = t => we remove this precond *) - let popped_t' = Termops.pop (EConstr.of_constr t') in + let popped_t' = pop t' in let real_type_of_hyp = - it_mkProd_or_LetIn popped_t' context + Term.it_mkProd_or_LetIn popped_t' context in let hd,args = destApp t_x in let get_args hd args = @@ -616,8 +617,8 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let fun_body = mkLambda(Anonymous, pf_unsafe_type_of g' term, - Termops.replace_term (project g') term (EConstr.mkRel 1) (EConstr.of_constr dyn_infos.info) - ) + EConstr.Unsafe.to_constr (Termops.replace_term (project g') term (EConstr.mkRel 1) (EConstr.of_constr dyn_infos.info) + )) in let new_body = pf_nf_betaiota g' (EConstr.of_constr (mkApp(fun_body,[| new_term_value |]))) in let new_body = EConstr.Unsafe.to_constr new_body in @@ -988,7 +989,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (nb_params + nb_args) t,evd in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in - let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in + let lemma_type = Term.it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) let f_id = Label.to_id (con_label (fst (destConst f))) in let prove_replacement = diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index b4eb778708..8683f68c64 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -23,6 +23,8 @@ let observe s = if do_observe () then Feedback.msg_debug s +let pop t = Vars.lift (-1) t + (* Transform an inductive induction principle into a functional one @@ -111,7 +113,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map (fun c -> Termops.pop (EConstr.of_constr c)) (array_get_start args)) in + let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); res in @@ -169,25 +171,25 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop (EConstr.of_constr new_b)), filter_map (eq_constr (mkRel 1)) (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b + then (pop new_b), filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b else ( bind_fun(new_x,new_t,new_b), list_union_eq eq_constr binders_to_remove_from_t - (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) + (List.map pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b + new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin @@ -198,25 +200,25 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop (EConstr.of_constr new_b)),filter_map (eq_constr (mkRel 1)) (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b + then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b else ( mkLetIn(new_x,new_v,new_t,new_b), list_union_eq eq_constr (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) - (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) + (List.map pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b + new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map (fun c -> Termops.pop (EConstr.of_constr c)) binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index c02b64c1f5..ca066c4cca 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -399,8 +399,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes match ctxt with | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") | hres::res::decl::ctxt -> - let res = Termops.it_mkLambda_or_LetIn - (Termops.it_mkProd_or_LetIn concl [hres;res]) + let res = Term.it_mkLambda_or_LetIn + (Term.it_mkProd_or_LetIn concl [hres;res]) (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt) in res @@ -793,7 +793,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; - let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = Term.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let _ = Typing.e_type_of (Global.env ()) evd (EConstr.of_constr type_of_lemma) in let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in let type_of_lemma = EConstr.Unsafe.to_constr type_of_lemma in @@ -861,7 +861,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = - Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + Term.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in let type_of_lemma = EConstr.Unsafe.to_constr type_of_lemma in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 3688b8c15f..2840193a94 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -32,7 +32,8 @@ module RelDecl = Context.Rel.Declaration (** {2 Useful operations on constr and glob_constr} *) -let rec popn i c = if i<=0 then c else EConstr.of_constr (pop (popn (i-1) c)) +let pop c = Vars.lift (-1) c +let rec popn i c = if i<=0 then c else pop (popn (i-1) c) (** Substitutions in constr *) let compare_constr_nosub t1 t2 = @@ -986,13 +987,13 @@ let relprinctype_to_funprinctype relprinctype nfuns = (* first remove indarg and indarg_in_concl *) let relinfo_noindarg = { relinfo with indarg_in_concl = false; indarg = None; - concl = EConstr.of_constr (remove_last_arg (pop relinfo.concl)); } in + concl = EConstr.of_constr (remove_last_arg (pop (EConstr.Unsafe.to_constr relinfo.concl))); } in (* the nfuns last induction arguments are functional ones: remove them *) let relinfo_argsok = { relinfo_noindarg with nargs = relinfo_noindarg.nargs - nfuns; (* args is in reverse order, so remove fst *) args = remove_n_fst_list nfuns relinfo_noindarg.args; - concl = popn nfuns relinfo_noindarg.concl; + concl = EConstr.of_constr (popn nfuns (EConstr.Unsafe.to_constr relinfo_noindarg.concl)); } in let new_branches = List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index c71174fefb..23b308efbe 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -408,6 +408,7 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = args.(1),args.(2) in let new_b' = Termops.replace_term (project g') (EConstr.of_constr teq_lhs) (EConstr.of_constr teq_rhs) (EConstr.of_constr new_b) in + let new_b' = EConstr.Unsafe.to_constr new_b' in let new_infos = { infos with info = new_b'; @@ -1253,7 +1254,7 @@ let clear_goals = | Prod(Name id as na,t',b) -> let b' = clear_goal b in if noccurn 1 b' && (is_rec_res id) - then Termops.pop (EConstr.of_constr b') + then Vars.lift (-1) b' else if b' == b then t else mkProd(na,t',b') | _ -> Term.map_constr clear_goal t diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 2ad97c75b3..87276f5df4 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -270,7 +270,7 @@ let compute_ivs f cs gl = (* The Cases predicate is a lambda; we assume no dependency *) let p = match EConstr.kind sigma p with - | Lambda (_,_,p) -> EConstr.of_constr (Termops.pop p) + | Lambda (_,_,p) -> Termops.pop p | _ -> p in diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 63eccaa400..131ecad335 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -246,7 +246,6 @@ let lapp f args = mkApp(Lazy.force f,args) let plapp evd f args = let fc = Evarutil.e_new_global evd (Lazy.force f) in - let fc = EConstr.of_constr fc in mkApp(fc,args) let dest_rel0 sigma t = @@ -591,7 +590,6 @@ let make_hyp env evd c = let make_hyp_list env evd lH = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in - let carrier = EConstr.of_constr carrier in let l = List.fold_right (fun c l -> plapp evd coq_cons [|carrier; (make_hyp env evd c); l|]) lH @@ -602,7 +600,6 @@ let make_hyp_list env evd lH = let interp_power env evd pow = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in - let carrier = EConstr.of_constr carrier in match pow with | None -> let t = ArgArg(Loc.ghost, Lazy.force ltac_inv_morph_nothing) in @@ -618,7 +615,6 @@ let interp_power env evd pow = let interp_sign env evd sign = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in - let carrier = EConstr.of_constr carrier in match sign with | None -> plapp evd coq_None [|carrier|] | Some spec -> @@ -628,7 +624,6 @@ let interp_sign env evd sign = let interp_div env evd div = let carrier = Evarutil.e_new_global evd (Lazy.force coq_hypo) in - let carrier = EConstr.of_constr carrier in match div with | None -> plapp evd coq_None [|carrier|] | Some spec -> -- 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 --- plugins/cc/cctac.ml | 4 ---- plugins/extraction/extraction.ml | 2 +- plugins/funind/functional_principles_proofs.ml | 1 + plugins/funind/glob_term_to_relation.ml | 1 + plugins/funind/indfun.ml | 1 + plugins/funind/invfun.ml | 2 ++ plugins/micromega/coq_micromega.ml | 2 +- plugins/setoid_ring/newring.ml | 14 ++++++-------- plugins/ssrmatching/ssrmatching.ml4 | 7 ++++--- 9 files changed, 17 insertions(+), 17 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7a99c45a8b..a4ed4798ae 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -264,7 +264,6 @@ let refresh_universes ty k = let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in let evm, ty = refresh_type env evm ty in - let ty = EConstr.of_constr ty in Sigma.Unsafe.of_pair (k ty, evm) end } @@ -387,7 +386,6 @@ let discriminate_tac (cstr,u as cstru) p = let trivial = EConstr.of_constr trivial in let evm = Tacmach.New.project gl in let evm, intype = refresh_type env evm (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl t1)) in - let intype = EConstr.of_constr intype in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in @@ -496,9 +494,7 @@ let mk_eq f c1 c2 k = Proofview.Goal.enter { enter = begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in - let ty = EConstr.of_constr ty in let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in - let ty = EConstr.of_constr ty in let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm term in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 61547f96d9..7b7e746f20 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -42,7 +42,7 @@ let none = Evd.empty let type_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_type_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) + EConstr.Unsafe.to_constr (Retyping.get_type_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c))) let sort_of env c = let polyprop = (lang() == Haskell) in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index cc29d68f59..c98cdc4678 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -985,6 +985,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let (type_ctxt,type_of_f),evd = let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in + let t = EConstr.Unsafe.to_constr t in decompose_prod_n_assum (nb_params + nb_args) t,evd in diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 38cd21684a..0725bb11c1 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1273,6 +1273,7 @@ let do_build_inductive Array.fold_right2 (fun id c (evd,env) -> let evd,t = Typing.type_of env evd (EConstr.mkConstU c) in + let t = EConstr.Unsafe.to_constr t in evd, Environ.push_named (LocalAssum (id,t)) (* try *) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 37a76bec1c..1b899c152f 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -373,6 +373,7 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in let princ_type = Typing.e_type_of ~refresh:true env evd (EConstr.of_constr uprinc) in + let princ_type = EConstr.Unsafe.to_constr princ_type in Functional_principles_types.generate_functional_principle evd interactive_proof diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index ca066c4cca..27528c2dcc 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -135,6 +135,7 @@ let generate_type evd g_to_f f graph i = in evd:=evd'; let graph_arity = Typing.e_type_of (Global.env ()) evd (EConstr.of_constr graph) in + let graph_arity = EConstr.Unsafe.to_constr graph_arity in let ctxt,_ = decompose_prod_assum graph_arity in let fun_ctxt,res_type = match ctxt with @@ -203,6 +204,7 @@ let find_induction_principle evd f = | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr rect_lemma) in + let typ = EConstr.Unsafe.to_constr typ in evd:=evd'; rect_lemma,typ diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index f96b189c52..ced5724669 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -898,7 +898,7 @@ struct let has_typ gl t1 typ = let ty = Retyping.get_type_of (Tacmach.pf_env gl) (Tacmach.project gl) t1 in - Constr.equal ty typ + EConstr.eq_constr (Tacmach.project gl) ty (EConstr.of_constr typ) let is_convertible gl t1 t2 = diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 131ecad335..c0eeff8d78 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -344,6 +344,8 @@ let _ = add_map "ring" (****************************************************************************) (* Ring database *) +let pr_constr c = pr_constr (EConstr.Unsafe.to_constr c) + module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" @@ -357,12 +359,12 @@ let find_ring_structure env sigma l = let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then + if not (Reductionops.is_conv env sigma ty ty') then user_err ~hdr:"ring" (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; - (try ring_for_carrier ty + (try ring_for_carrier (EConstr.to_constr sigma ty) with Not_found -> user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ @@ -495,7 +497,6 @@ let op_smorph r add mul req m1 m2 = (* (setoid,op_morph) *) let ring_equality env evd (r,add,mul,opp,req) = - let pr_constr c = pr_constr (EConstr.to_constr !evd c) in match EConstr.kind !evd req with | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> let setoid = plapp evd coq_eq_setoid [|r|] in @@ -553,7 +554,6 @@ let build_setoid_params env evd r add mul opp req eqth = let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in - let th_typ = EConstr.of_constr th_typ in match EConstr.kind sigma th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) when eq_constr_nounivs sigma f (Lazy.force coq_almost_ring_theory) -> @@ -585,7 +585,6 @@ let interp_cst_tac env sigma rk kind (zero,one,add,mul,opp) cst_tac = let make_hyp env evd c = let t = Retyping.get_type_of env !evd c in - let t = EConstr.of_constr t in plapp evd coq_mkhypo [|t;c|] let make_hyp_list env evd lH = @@ -820,7 +819,6 @@ let sf_sr = my_reference"SF_SR" let dest_field env evd th_spec = let open Termops in let th_typ = Retyping.get_type_of env !evd th_spec in - let th_typ = EConstr.of_constr th_typ in match EConstr.kind !evd th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) when is_global !evd (Lazy.force afield_theory) f -> @@ -852,12 +850,12 @@ let find_field_structure env sigma l = let ty = Retyping.get_type_of env sigma t in let check c = let ty' = Retyping.get_type_of env sigma c in - if not (Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty')) then + if not (Reductionops.is_conv env sigma ty ty') then user_err ~hdr:"field" (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; - (try field_for_carrier ty + (try field_for_carrier (EConstr.to_constr sigma ty) with Not_found -> user_err ~hdr:"field" (str"cannot find a declared field structure over"++ diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index d34c9325ed..9798fa11c6 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1390,9 +1390,10 @@ let ssrpatterntac _ist (arg_ist,arg) gl = let concl0 = pf_concl gl in let (t, uc), concl_x = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in - let gl, tty = pf_type_of gl (EConstr.of_constr t) in - let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in - let concl = EConstr.of_constr concl in + let t = EConstr.of_constr t in + let concl_x = EConstr.of_constr concl_x in + let gl, tty = pf_type_of gl t in + let concl = EConstr.mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) -- 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. --- plugins/cc/ccalgo.ml | 8 ++++---- plugins/cc/cctac.ml | 3 ++- plugins/cc/g_congruence.ml4 | 4 ++-- plugins/decl_mode/ppdecl_proof.ml | 2 ++ plugins/funind/g_indfun.ml4 | 8 +++++--- plugins/nsatz/g_nsatz.ml4 | 2 +- plugins/quote/g_quote.ml4 | 5 ++--- plugins/setoid_ring/g_newring.ml4 | 14 +++----------- plugins/setoid_ring/newring.ml | 5 ++--- plugins/ssrmatching/ssrmatching.ml4 | 2 +- 10 files changed, 24 insertions(+), 29 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 102efe55bc..0a980c03b7 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -497,10 +497,10 @@ let rec inst_pattern subst = function args t let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ - Termops.print_constr (constr_of_term (term uf i)) ++ str "]" + Termops.print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" let pr_term t = str "[" ++ - Termops.print_constr (constr_of_term t) ++ str "]" + Termops.print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" let rec add_term state t= let uf=state.uf in @@ -615,7 +615,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr prf ++ str " : " ++ + (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")); add_equality state prf s t end @@ -623,7 +623,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr prf ++ str " : " ++ + (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")); add_disequality state (Hyp prf) s t end diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index a4ed4798ae..62892973d4 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -414,6 +414,7 @@ let build_term_to_complete uf meta pac = let cc_tactic depth additionnal_terms = Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in Coqlib.check_required_library Coqlib.logic_module_name; let _ = debug (fun () -> Pp.str "Reading subgoal ...") in let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in @@ -448,7 +449,7 @@ let cc_tactic depth additionnal_terms = str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") - (EConstr.Unsafe.to_constr %> Termops.print_constr_env env) + (Termops.print_constr_env env sigma) terms_to_complete ++ str ")\"," end ++ diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index b787e824f8..6f6811334d 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -18,9 +18,9 @@ DECLARE PLUGIN "cc_plugin" TACTIC EXTEND cc [ "congruence" ] -> [ congruence_tac 1000 [] ] |[ "congruence" integer(n) ] -> [ congruence_tac n [] ] - |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 (List.map EConstr.of_constr l) ] + |[ "congruence" "with" ne_constr_list(l) ] -> [ congruence_tac 1000 l ] |[ "congruence" integer(n) "with" ne_constr_list(l) ] -> - [ congruence_tac n (List.map EConstr.of_constr l) ] + [ congruence_tac n l ] END TACTIC EXTEND f_equal diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml index 59a0bb5a2d..93b98263e6 100644 --- a/plugins/decl_mode/ppdecl_proof.ml +++ b/plugins/decl_mode/ppdecl_proof.ml @@ -206,6 +206,8 @@ let pr_glob_proof_instr pconstr1 pconstr2 ptac (instr : glob_proof_instr) = instr let pr_proof_instr pconstr1 pconstr2 ptac (instr : proof_instr) = + let pconstr1 c = pconstr1 (EConstr.of_constr c) in + let pconstr2 c = pconstr2 (EConstr.of_constr c) in pr_gen_proof_instr (fun st -> pr_statement pconstr1 st) pconstr2 diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index a6f971703d..560242bf27 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -58,7 +58,7 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = | None -> mt () | Some b -> let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in - spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed (EConstr.Unsafe.to_constr %> prc) (EConstr.Unsafe.to_constr %> prlc) b) + spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) ARGUMENT EXTEND fun_ind_using @@ -108,8 +108,9 @@ TACTIC EXTEND newfunind let c = match cl with | [] -> assert false | [c] -> c - | c::cl -> applist(c,cl) + | c::cl -> EConstr.applist(c,cl) in + let c = EConstr.Unsafe.to_constr c in Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] END (***** debug only ***) @@ -119,8 +120,9 @@ TACTIC EXTEND snewfunind let c = match cl with | [] -> assert false | [c] -> c - | c::cl -> applist(c,cl) + | c::cl -> EConstr.applist(c,cl) in + let c = EConstr.Unsafe.to_constr c in Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] END diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 5f906a8dad..a6749c3474 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -13,5 +13,5 @@ DECLARE PLUGIN "nsatz_plugin" DECLARE PLUGIN "nsatz_plugin" TACTIC EXTEND nsatz_compute -| [ "nsatz_compute" constr(lt) ] -> [ Nsatz.nsatz_compute lt ] +| [ "nsatz_compute" constr(lt) ] -> [ Nsatz.nsatz_compute (EConstr.Unsafe.to_constr lt) ] END diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index 79c4296155..40c1028e5b 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -23,7 +23,6 @@ let cont = Id.of_string "cont" let x = Id.of_string "x" let make_cont (k : Val.t) (c : EConstr.t) = - let c = EConstr.Unsafe.to_constr c in let c = Tacinterp.Value.of_constr c in let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in @@ -33,8 +32,8 @@ TACTIC EXTEND quote [ "quote" ident(f) ] -> [ quote f [] ] | [ "quote" ident(f) "[" ne_ident_list(lc) "]"] -> [ quote f lc ] | [ "quote" ident(f) "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) (EConstr.of_constr c) f [] ] + [ gen_quote (make_cont k) c f [] ] | [ "quote" ident(f) "[" ne_ident_list(lc) "]" "in" constr(c) "using" tactic(k) ] -> - [ gen_quote (make_cont k) (EConstr.of_constr c) f lc ] + [ gen_quote (make_cont k) c f lc ] END diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 13cf8330b5..b1882ae8ac 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -30,7 +30,7 @@ END TACTIC EXTEND closed_term [ "closed_term" constr(t) "[" ne_reference_list(l) "]" ] -> - [ closed_term (EConstr.of_constr t) l ] + [ closed_term t l ] END open Pptactic @@ -90,11 +90,7 @@ END TACTIC EXTEND ring_lookup | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> - [ - let lH = List.map EConstr.of_constr lH in - let lrt = List.map EConstr.of_constr lrt in - let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t - ] + [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t ] END let pr_field_mod = function @@ -129,9 +125,5 @@ END TACTIC EXTEND field_lookup | [ "field_lookup" tactic(f) "[" constr_list(lH) "]" ne_constr_list(lt) ] -> - [ - let lH = List.map EConstr.of_constr lH in - let lt = List.map EConstr.of_constr lt in - let (t,l) = List.sep_last lt in field_lookup f lH l t - ] + [ let (t,l) = List.sep_last lt in field_lookup f lH l t ] END diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index c0eeff8d78..ce2c558aeb 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -183,7 +183,7 @@ let dummy_goal env sigma = {Evd.it = gl; Evd.sigma = sigma} let constr_of v = match Value.to_constr v with - | Some c -> c + | Some c -> EConstr.Unsafe.to_constr c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -203,7 +203,6 @@ let get_res = let exec_tactic env evd n f args = let fold arg (i, vars, lfun) = - let arg = EConstr.Unsafe.to_constr arg in let id = Id.of_string ("x" ^ string_of_int i) in let x = Reference (ArgVar (Loc.ghost, id)) in (succ i, x :: vars, Id.Map.add id (Value.of_constr arg) lfun) @@ -730,7 +729,7 @@ let make_term_list env evd carrier rl = (plapp evd coq_nil [|carrier|]) in Typing.e_solve_evars env evd l -let carg = Tacinterp.Value.of_constr +let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 9798fa11c6..9dcc6c4cc0 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1030,7 +1030,7 @@ let interp_constr = interp_wit wit_constr let interp_open_constr ist gl gc = interp_wit wit_open_constr ist gl gc let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c -let interp_term ist gl (_, c) = (interp_open_constr ist gl c) +let interp_term ist gl (_, c) = on_snd EConstr.Unsafe.to_constr (interp_open_constr ist gl c) let pr_ssrterm _ _ _ = pr_term let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with | Tok.KEYWORD "(" -> '(' -- 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. --- plugins/decl_mode/g_decl_mode.ml4 | 2 +- plugins/setoid_ring/newring.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 index 9e2c9f5973..18a35c6cfb 100644 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ b/plugins/decl_mode/g_decl_mode.ml4 @@ -25,7 +25,7 @@ open Ppdecl_proof let pr_goal gs = let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in let env = Goal.V82.env sigma g in - let concl = EConstr.Unsafe.to_constr (Goal.V82.concl sigma g) in + let concl = Goal.V82.concl sigma g in let goal = Printer.pr_context_of env sigma ++ cut () ++ str "============================" ++ cut () ++ diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index ce2c558aeb..358ea56852 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -343,7 +343,7 @@ let _ = add_map "ring" (****************************************************************************) (* Ring database *) -let pr_constr c = pr_constr (EConstr.Unsafe.to_constr c) +let pr_constr c = pr_econstr c module Cmap = Map.Make(Constr) -- cgit v1.2.3 From a5499688bd76def8de3d8e1089a49c7a08430903 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Nov 2016 14:54:40 +0100 Subject: Funind API using EConstr. --- plugins/funind/functional_principles_proofs.ml | 364 ++++++++++++------------ plugins/funind/functional_principles_proofs.mli | 6 +- plugins/funind/functional_principles_types.ml | 6 +- plugins/funind/functional_principles_types.mli | 2 +- plugins/funind/g_indfun.ml4 | 3 - plugins/funind/glob_term_to_relation.ml | 2 +- plugins/funind/indfun.ml | 45 +-- plugins/funind/indfun.mli | 4 +- plugins/funind/indfun_common.ml | 56 +++- plugins/funind/indfun_common.mli | 23 +- plugins/funind/invfun.ml | 212 +++++++------- plugins/funind/recdef.ml | 342 ++++++++++++---------- plugins/funind/recdef.mli | 2 +- 13 files changed, 576 insertions(+), 491 deletions(-) (limited to 'plugins') diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index c98cdc4678..656924e38c 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -2,6 +2,7 @@ open Printer open CErrors open Util open Term +open EConstr open Vars open Namegen open Names @@ -18,6 +19,12 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration +let local_assum (na, t) = + RelDecl.LocalAssum (na, EConstr.Unsafe.to_constr t) + +let local_def (na, b, t) = + RelDecl.LocalDef (na, EConstr.Unsafe.to_constr b, EConstr.Unsafe.to_constr t) + (* let msgnl = Pp.msgnl *) (* @@ -132,16 +139,16 @@ let refine c = let thin l = Proofview.V82.of_tactic (Tactics.clear l) -let eq_constr u v = eq_constr_nounivs u v +let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v -let is_trivial_eq t = +let is_trivial_eq sigma t = let res = try begin - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - eq_constr t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> - eq_constr t1 t2 && eq_constr a1 a2 + match EConstr.kind sigma t with + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 | _ -> false end with e when CErrors.noncritical e -> false @@ -149,34 +156,33 @@ let is_trivial_eq t = (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res -let rec incompatible_constructor_terms t1 t2 = - let c1,arg1 = decompose_app t1 - and c2,arg2 = decompose_app t2 +let rec incompatible_constructor_terms sigma t1 t2 = + let c1,arg1 = decompose_app sigma t1 + and c2,arg2 = decompose_app sigma t2 in - (not (eq_constr t1 t2)) && - isConstruct c1 && isConstruct c2 && + (not (eq_constr sigma t1 t2)) && + isConstruct sigma c1 && isConstruct sigma c2 && ( - not (eq_constr c1 c2) || - List.exists2 incompatible_constructor_terms arg1 arg2 + not (eq_constr sigma c1 c2) || + List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) -let is_incompatible_eq t = +let is_incompatible_eq sigma t = let res = try - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - incompatible_constructor_terms t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> - (eq_constr u1 u2 && - incompatible_constructor_terms t1 t2) + match EConstr.kind sigma t with + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> + (eq_constr sigma u1 u2 && + incompatible_constructor_terms sigma t1 t2) | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); + if res then observe (str "is_incompatible_eq " ++ Printer.pr_leconstr t); res let change_hyp_with_using msg hyp_id t tac : tactic = - let t = EConstr.of_constr t in fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS @@ -204,47 +210,44 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = (List.map mkVar context_hyps) in let to_refine = applist(mkVar h_id,List.rev context_hyps') in - let to_refine = EConstr.of_constr to_refine in refine to_refine g ) ] -let find_rectype env c = - let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in - match kind_of_term t with +let find_rectype env sigma c = + let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + match EConstr.kind sigma t with | Ind ind -> (t, l) | Construct _ -> (t,l) | _ -> raise Not_found -let isAppConstruct ?(env=Global.env ()) t = +let isAppConstruct ?(env=Global.env ()) sigma t = try - let t',l = find_rectype (Global.env ()) t in - observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); + let t',l = find_rectype env sigma t in + observe (str "isAppConstruct : " ++ Printer.pr_leconstr t ++ str " -> " ++ Printer.pr_leconstr (applist (t',l))); true with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = let nochange ?t' msg = begin - observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); + observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_leconstr t ); failwith "NoChange"; end in - let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) (EConstr.of_constr c1) (EConstr.of_constr c2) in - if not (noccurn 1 end_of_type) + let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) c1 c2 in + if not (noccurn sigma 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) - if not (isApp t) then nochange "not an equality"; - let f_eq,args = destApp t in + if not (isApp sigma t) then nochange "not an equality"; + let f_eq,args = destApp sigma t in let constructor,t1,t2,t1_typ = try if (eq_constr f_eq (Lazy.force eq)) @@ -261,32 +264,32 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = else nochange "not an equality" with e when CErrors.noncritical e -> nochange "not an equality" in - if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; + if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel t2 + if isRel sigma t2 then - let t2 = destRel t2 in + let t2 = destRel sigma t2 in begin try let t1' = Int.Map.find t2 sub in if not (eq_constr t1 t1') then nochange "twice bound variable"; sub with Not_found -> - assert (closed0 t1); + assert (closed0 sigma t1); Int.Map.add t2 t1 sub end - else if isAppConstruct t1 && isAppConstruct t2 + else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then begin - let c1,args1 = find_rectype env t1 - and c2,args2 = find_rectype env t2 + let c1,args1 = find_rectype env sigma t1 + and c2,args2 = find_rectype env sigma t2 in if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; List.fold_left2 compute_substitution sub args1 args2 end else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2) "cannot solve (diff)" + if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in @@ -312,19 +315,18 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) + (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, EConstr.of_constr (RelDecl.get_type decl), witness_fun)) with Not_found -> - (Term.mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) + (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) 1 (new_end_of_type,0,witness_fun) context in let new_type_of_hyp = - Reductionops.nf_betaiota Evd.empty (EConstr.of_constr new_type_of_hyp) in - let new_type_of_hyp = EConstr.Unsafe.to_constr new_type_of_hyp in + Reductionops.nf_betaiota sigma new_type_of_hyp in let new_ctxt,new_end_of_type = - decompose_prod_n_assum ctxt_size new_type_of_hyp + decompose_prod_n_assum sigma ctxt_size new_type_of_hyp in let prove_new_hyp : tactic = tclTHEN @@ -333,7 +335,6 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = let all_ids = pf_ids_of_hyps g in let new_ids,_ = list_chop ctxt_size all_ids in let to_refine = applist(witness_fun,List.rev_map mkVar new_ids) in - let to_refine = EConstr.of_constr to_refine in let evm, _ = pf_apply Typing.type_of g to_refine in tclTHEN (Refiner.tclEVARS evm) (refine to_refine) g ) @@ -358,21 +359,21 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = new_ctxt,new_end_of_type,simpl_eq_tac -let is_property (ptes_info:ptes_info) t_x full_type_of_hyp = - if isApp t_x +let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = + if isApp sigma t_x then - let pte,args = destApp t_x in - if isVar pte && Array.for_all closed0 args + let pte,args = destApp sigma t_x in + if isVar sigma pte && Array.for_all (closed0 sigma) args then try - let info = Id.Map.find (destVar pte) ptes_info in + let info = Id.Map.find (destVar sigma pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false else false -let isLetIn t = - match kind_of_term t with +let isLetIn sigma t = + match EConstr.kind sigma t with | LetIn _ -> true | _ -> false @@ -392,8 +393,9 @@ let rewrite_until_var arg_num eq_ids : tactic = will break the Guard when trying to save the Lemma. *) let test_var g = - let _,args = destApp (pf_concl g) in - not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) + let sigma = project g in + let _,args = destApp sigma (EConstr.of_constr (pf_concl g)) in + not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) in let rec do_rewrite eq_ids g = if test_var g @@ -403,7 +405,7 @@ let rewrite_until_var arg_num eq_ids : tactic = | [] -> anomaly (Pp.str "Cannot find a way to prove recursive property"); | eq_id::eq_ids -> tclTHEN - (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (EConstr.mkVar eq_id)))) + (tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar eq_id)))) (do_rewrite eq_ids) g in @@ -412,31 +414,31 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = Coqlib.build_coq_False () in - let coq_True = Coqlib.build_coq_True () in - let coq_I = Coqlib.build_coq_I () in + let coq_False = EConstr.of_constr (Coqlib.build_coq_False ()) in + let coq_True = EConstr.of_constr (Coqlib.build_coq_True ()) in + let coq_I = EConstr.of_constr (Coqlib.build_coq_I ()) in let rec scan_type context type_of_hyp : tactic = - if isLetIn type_of_hyp then - let real_type_of_hyp = Term.it_mkProd_or_LetIn type_of_hyp context in + if isLetIn sigma type_of_hyp then + let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = - decompose_prod_n_assum (List.length context) reduced_type_of_hyp + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in tclTHENLIST [ h_reduce_with_zeta (Locusops.onHyp hyp_id); scan_type new_context new_typ_of_hyp ] - else if isProd type_of_hyp + else if isProd sigma type_of_hyp then begin - let (x,t_x,t') = destProd type_of_hyp in - let actual_real_type_of_hyp = Term.it_mkProd_or_LetIn t' context in - if is_property ptes_infos t_x actual_real_type_of_hyp then + let (x,t_x,t') = destProd sigma type_of_hyp in + let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then begin - let pte,pte_args = (destApp t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in + let pte,pte_args = (destApp sigma t_x) in + let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in let popped_t' = pop t' in - let real_type_of_hyp = Term.it_mkProd_or_LetIn popped_t' context in + let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in tclTHENLIST @@ -453,8 +455,6 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = List.rev_map mkVar (rec_pte_id::context_hyps_ids) ) in - let to_refine = EConstr.of_constr to_refine in - let t_x = EConstr.of_constr t_x in (* observe_tac "rec hyp " *) (tclTHENS (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) @@ -474,22 +474,22 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = scan_type context popped_t' ] end - else if eq_constr t_x coq_False then + else if eq_constr sigma t_x coq_False then begin (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) (* str " since it has False in its preconds " *) (* ); *) raise TOREMOVE; (* False -> .. useless *) end - else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr t_x coq_True (* Trivial => we remove this precons *) + else if is_incompatible_eq sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) let popped_t' = pop t' in let real_type_of_hyp = - Term.it_mkProd_or_LetIn popped_t' context + it_mkProd_or_LetIn popped_t' context in let prove_trivial = let nb_intro = List.length context in @@ -504,7 +504,6 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = List.rev (coq_I::List.map mkVar context_hyps) ) in - let to_refine = (EConstr.of_constr to_refine) in refine to_refine g ) ] @@ -514,15 +513,15 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ((* observe_tac "prove_trivial" *) prove_trivial); scan_type context popped_t' ] - else if is_trivial_eq t_x + else if is_trivial_eq sigma t_x then (* t_x := t = t => we remove this precond *) let popped_t' = pop t' in let real_type_of_hyp = - Term.it_mkProd_or_LetIn popped_t' context + it_mkProd_or_LetIn popped_t' context in - let hd,args = destApp t_x in + let hd,args = destApp sigma t_x in let get_args hd args = - if eq_constr hd (Lazy.force eq) + if eq_constr sigma hd (Lazy.force eq) then (Lazy.force refl_equal,args.(0),args.(1)) else (jmeq_refl (),args.(0),args.(1)) in @@ -545,14 +544,14 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (scan_type new_context new_t') with Failure "NoChange" -> (* Last thing todo : push the rel in the context and continue *) - scan_type (LocalAssum (x,t_x) :: context) t' + scan_type (local_assum (x,t_x) :: context) t' end end else tclIDTAC in try - scan_type [] (Typing.unsafe_type_of env sigma (EConstr.mkVar hyp_id)), [hyp_id] + scan_type [] (EConstr.of_constr (Typing.unsafe_type_of env sigma (mkVar hyp_id))), [hyp_id] with TOREMOVE -> thin [hyp_id],[] @@ -602,26 +601,25 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = tclMAP (fun id -> Proofview.V82.of_tactic (introduction ~check:false id)) dyn_infos.rec_hyps; observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) - let new_term_value_eq = pf_unsafe_type_of g' (EConstr.mkVar heq_id) in + let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in + let new_term_value_eq = EConstr.of_constr new_term_value_eq in (* compute the new value of the body *) let new_term_value = - match kind_of_term new_term_value_eq with + match EConstr.kind (project g') new_term_value_eq with | App(f,[| _;_;args2 |]) -> args2 | _ -> observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq + pr_leconstr_env (pf_env g') (project g') new_term_value_eq ); anomaly (Pp.str "cannot compute new term value") in - let term = EConstr.of_constr term in let fun_body = mkLambda(Anonymous, - pf_unsafe_type_of g' term, - EConstr.Unsafe.to_constr (Termops.replace_term (project g') term (EConstr.mkRel 1) (EConstr.of_constr dyn_infos.info) - )) + EConstr.of_constr (pf_unsafe_type_of g' term), + Termops.replace_term (project g') term (mkRel 1) dyn_infos.info + ) in - let new_body = pf_nf_betaiota g' (EConstr.of_constr (mkApp(fun_body,[| new_term_value |]))) in - let new_body = EConstr.Unsafe.to_constr new_body in + let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in let new_infos = {dyn_infos with info = new_body; @@ -649,7 +647,6 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in - let c = EConstr.of_constr c in let evm, _ = pf_apply Typing.type_of g c in tclTHENLIST[ Refiner.tclEVARS evm; @@ -702,8 +699,9 @@ let build_proof : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = fun g -> + let sigma = project g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with + match EConstr.kind sigma dyn_infos.info with | Case(ci,ct,t,cb) -> let do_finalize_t dyn_info' = fun g -> @@ -711,18 +709,18 @@ let build_proof let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in let g_nb_prod = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in - let type_of_term = pf_unsafe_type_of g (EConstr.of_constr t) in + let type_of_term = pf_unsafe_type_of g t in + let type_of_term = EConstr.of_constr type_of_term in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in - let term_eq = EConstr.of_constr term_eq in tclTHENSEQ [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map EConstr.mkVar dyn_infos.rec_hyps))); + Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],EConstr.of_constr t] None); + Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); (fun g -> observe_tac "toto" ( - tclTHENSEQ [Proofview.V82.of_tactic (Simple.case (EConstr.of_constr t)); + tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> let g'_nb_prod = nb_prod (project g') (EConstr.of_constr (pf_concl g')) in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in @@ -744,7 +742,7 @@ let build_proof build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin - match kind_of_term( pf_concl g) with + match EConstr.kind sigma (EConstr.of_constr ( pf_concl g)) with | Prod _ -> tclTHEN (Proofview.V82.of_tactic intro) @@ -753,9 +751,8 @@ let build_proof let id = pf_last_hyp g' |> get_id in let new_term = pf_nf_betaiota g' - (EConstr.of_constr (mkApp(dyn_infos.info,[|mkVar id|]))) + (mkApp(dyn_infos.info,[|mkVar id|])) in - let new_term = EConstr.Unsafe.to_constr new_term in let new_infos = {dyn_infos with info = new_term} in let do_prove new_hyps = build_proof do_finalize @@ -775,9 +772,9 @@ let build_proof | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> do_finalize dyn_infos g | App(_,_) -> - let f,args = decompose_app dyn_infos.info in + let f,args = decompose_app sigma dyn_infos.info in begin - match kind_of_term f with + match EConstr.kind sigma f with | App _ -> assert false (* we have collected all the app in decompose_app *) | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> @@ -799,8 +796,7 @@ let build_proof do_finalize dyn_infos g | Lambda _ -> let new_term = - Reductionops.nf_beta Evd.empty (EConstr.of_constr dyn_infos.info) in - let new_term = EConstr.Unsafe.to_constr new_term in + Reductionops.nf_beta sigma dyn_infos.info in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> @@ -852,7 +848,7 @@ let build_proof | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ Printer.pr_leconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -918,11 +914,10 @@ let prove_rec_hyp_for_struct fix_info = (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) (fun g -> - let _,pte_args = destApp (pf_concl g) in + let _,pte_args = destApp (project g) (EConstr.of_constr (pf_concl g)) in let rec_hyp_proof = mkApp(mkVar fix_info.name,array_get_start pte_args) in - let rec_hyp_proof = EConstr.of_constr rec_hyp_proof in refine rec_hyp_proof g )) @@ -936,7 +931,7 @@ let generalize_non_dep hyp g = (* observe (str "rec id := " ++ Ppconstr.pr_id hyp); *) let hyps = [hyp] in let env = Global.env () in - let hyp_typ = pf_unsafe_type_of g (EConstr.mkVar hyp) in + let hyp_typ = pf_unsafe_type_of g (mkVar hyp) in let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> @@ -951,7 +946,7 @@ let generalize_non_dep hyp g = in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar to_revert) ))) + ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) ((* observe_tac "thin" *) (thin to_revert)) g @@ -959,18 +954,19 @@ let id_of_decl = RelDecl.get_name %> Nameops.out_name let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN - (Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar idl))) + (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) (thin idl) let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) - let f_def = Global.lookup_constant (fst (destConst f)) in + let f_def = Global.lookup_constant (fst (destConst evd f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = Option.get (Global.body_of_constant_body f_def) in - let params,f_body_with_params = decompose_lam_n nb_params f_body in - let (_,num),(_,_,bodies) = destFix f_body_with_params in + let f_body = EConstr.of_constr f_body in + let params,f_body_with_params = decompose_lam_n evd nb_params f_body in + let (_,num),(_,_,bodies) = destFix evd f_body_with_params in let fnames_with_params = let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in @@ -983,16 +979,15 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let eq_rhs = nf_betaiotazeta (mkApp(compose_lam params f_body_with_params_and_other_fun,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i)))) in (* observe (str "eq_rhs " ++ pr_lconstr eq_rhs); *) let (type_ctxt,type_of_f),evd = - let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) + let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f in - let t = EConstr.Unsafe.to_constr t in - decompose_prod_n_assum + decompose_prod_n_assum evd (nb_params + nb_args) t,evd in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in - let lemma_type = Term.it_mkProd_or_LetIn eqn type_ctxt in + let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) - let f_id = Label.to_id (con_label (fst (destConst f))) in + let f_id = Label.to_id (con_label (fst (destConst evd f))) in let prove_replacement = tclTHENSEQ [ @@ -1001,7 +996,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (EConstr.mkVar rec_id))); + observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); (Proofview.V82.of_tactic intros_reflexivity)] g ) ] @@ -1014,7 +1009,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (mk_equation_id f_id) (Decl_kinds.Global, Flags.is_universe_polymorphism (), (Decl_kinds.Proof Decl_kinds.Theorem)) evd - lemma_type + (EConstr.Unsafe.to_constr lemma_type) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None))); @@ -1026,10 +1021,10 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in + let finfos = find_Function_infos (fst (destConst !evd f)) (*FIXME*) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> - let f_id = Label.to_id (con_label (fst (destConst f))) in + let f_id = Label.to_id (con_label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) @@ -1038,7 +1033,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (fst (destConst f)) in + let finfos = find_Function_infos (fst (destConst !evd f)) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with @@ -1054,8 +1049,9 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in + let res = EConstr.of_constr res in evd:=evd'; - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr res) in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in res in let nb_intro_to_do = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in @@ -1066,7 +1062,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let just_introduced = nLastDecls nb_intro_to_do g' in let open Context.Named.Declaration in let just_introduced_id = List.map get_id just_introduced in - tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.of_constr equation_lemma))) + tclTHEN (Proofview.V82.of_tactic (Equality.rewriteLR equation_lemma)) (revert just_introduced_id) g' ) g @@ -1103,15 +1099,15 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let get_body const = match Global.body_of_constant const with | Some body -> - EConstr.Unsafe.to_constr (Tacred.cbv_norm_flags + Tacred.cbv_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) - (EConstr.of_constr body)) + (EConstr.of_constr body) | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam fbody in + let f_ctxt,f_body = decompose_lam (project g) fbody in let f_ctxt_length = List.length f_ctxt in let diff_params = princ_info.nparams - f_ctxt_length in let full_params,princ_params,fbody_with_full_params = @@ -1146,35 +1142,35 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam princ_params ); observe (str "fbody_with_full_params := " ++ - pr_lconstr fbody_with_full_params + pr_leconstr fbody_with_full_params ); let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in let fix_offset = List.length princ_params in let ptes_to_fix,infos = - match kind_of_term fbody_with_full_params with + match EConstr.kind (project g) fbody_with_full_params with | Fix((idxs,i),(names,typess,bodies)) -> let bodies_with_all_params = Array.map (fun body -> - EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty - (EConstr.of_constr (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, - List.rev_map var_of_decl princ_params)))) + Reductionops.nf_betaiota (project g) + (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, + List.rev_map var_of_decl princ_params)) ) bodies in let info_array = Array.mapi (fun i types -> - let types = Term.prod_applist types (List.rev_map var_of_decl princ_params) in + let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; name = Nameops.out_name (fresh_id names.(i)); types = types; offset = fix_offset; nb_realargs = List.length - (fst (decompose_lam bodies.(i))) - fix_offset; + (fst (decompose_lam (project g) bodies.(i))) - fix_offset; body_with_param = bodies_with_all_params.(i); num_in_block = i } @@ -1186,7 +1182,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (fun i (acc_map,acc_info) decl -> let pte = RelDecl.get_name decl in let infos = info_array.(i) in - let type_args,_ = decompose_prod infos.types in + let type_args,_ = decompose_prod (project g) infos.types in let nargs = List.length type_args in let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in @@ -1196,20 +1192,20 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = - EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty (EConstr.of_constr ( - applist(body,List.rev_map var_of_decl full_params)))) + Reductionops.nf_betaiota (project g) ( + applist(body,List.rev_map var_of_decl full_params)) in - match kind_of_term body_with_full_params with + match EConstr.kind (project g) body_with_full_params with | Fix((_,num),(_,_,bs)) -> - EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty - (EConstr.of_constr ( + Reductionops.nf_betaiota (project g) + ( (applist (substl (List.rev (Array.to_list all_funs_with_full_params)) bs.(num), List.rev_map var_of_decl princ_params)) - ))),num + ),num | _ -> error "Not a mutual block" in let info = @@ -1238,7 +1234,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam | _, this_fix_info::others_infos -> let other_fix_infos = List.map - (fun fi -> fi.name,fi.idx + 1 ,EConstr.of_constr fi.types) + (fun fi -> fi.name,fi.idx + 1 ,fi.types) (pre_info@others_infos) in if List.is_empty other_fix_infos @@ -1262,11 +1258,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let intros_after_fixes : tactic = fun gl -> - let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in - let pte,pte_args = (decompose_app pte_app) in + let ctxt,pte_app = (decompose_prod_assum (project gl) (EConstr.of_constr (pf_concl gl))) in + let pte,pte_args = (decompose_app (project gl) pte_app) in try let pte = - try destVar pte + try destVar (project gl) pte with DestKO -> anomaly (Pp.str "Property is not a variable") in let fix_info = Id.Map.find pte ptes_to_fix in @@ -1285,8 +1281,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty - (EConstr.of_constr (applist(fix_body,List.rev_map mkVar args_id)))); + Reductionops.nf_betaiota (project g) + (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] } in @@ -1345,15 +1341,15 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - EConstr.Unsafe.to_constr (Reductionops.nf_betaiota Evd.empty - (EConstr.of_constr (applist(fbody_with_full_params, + Reductionops.nf_betaiota Evd.empty + (applist(fbody_with_full_params, (List.rev_map var_of_decl princ_params)@ (List.rev_map mkVar args_id) - )))); + )); eq_hyps = [] } in - let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in + let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in tclTHENSEQ [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); let do_prove = @@ -1431,18 +1427,18 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = let backtrack_eqs_until_hrec hrec eqs : tactic = fun gls -> - let eqs = List.map EConstr.mkVar eqs in + let eqs = List.map mkVar eqs in let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (pf_unsafe_type_of gls (EConstr.mkVar hrec)) in - let f_app = Array.last (snd (destApp hrec_concl)) in - let f = (fst (destApp f_app)) in + let _,hrec_concl = decompose_prod (project gls) (EConstr.of_constr (pf_unsafe_type_of gls (mkVar hrec))) in + let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in + let f = (fst (destApp (project gls) f_app)) in let rec backtrack : tactic = fun g -> - let f_app = Array.last (snd (destApp (pf_concl g))) in - match kind_of_term f_app with - | App(f',_) when eq_constr f' f -> tclIDTAC g + let f_app = Array.last (snd (destApp (project g) (EConstr.of_constr (pf_concl g)))) in + match EConstr.kind (project g) f_app with + | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g in backtrack gls @@ -1459,7 +1455,7 @@ let rec rewrite_eqs_in_eqs eqs = observe_tac (Format.sprintf "rewrite %s in %s " (Id.to_string eq) (Id.to_string id)) (tclTRY (Proofview.V82.of_tactic (Equality.general_rewrite_in true Locus.AllOccurrences - true (* dep proofs also: *) true id (EConstr.mkVar eq) false))) + true (* dep proofs also: *) true id (mkVar eq) false))) gl ) eqs @@ -1473,11 +1469,11 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (EConstr.mkVar hrec))) + (Proofview.V82.of_tactic (apply (mkVar hrec))) [ tclTHENSEQ [ (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (EConstr.of_constr (Lazy.force acc_inv)))); + (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); (fun g -> if is_mes then @@ -1493,7 +1489,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (EConstr.of_constr (Lazy.force refl_equal)) sigma}] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ) ) @@ -1506,20 +1502,20 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = gls -let is_valid_hypothesis predicates_name = +let is_valid_hypothesis sigma predicates_name = let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in let is_pte typ = - if isApp typ + if isApp sigma typ then - let pte,_ = destApp typ in - if isVar pte - then Id.Set.mem (destVar pte) predicates_name + let pte,_ = destApp sigma typ in + if isVar sigma pte + then Id.Set.mem (destVar sigma pte) predicates_name else false else false in let rec is_valid_hypothesis typ = is_pte typ || - match kind_of_term typ with + match EConstr.kind sigma typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' | _ -> false in @@ -1584,7 +1580,7 @@ let prove_principle_for_gen Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map EConstr.mkVar l))) (Proofview.V82.of_tactic (clear l)) + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = @@ -1592,12 +1588,12 @@ let prove_principle_for_gen (tclCOMPLETE (tclTHEN (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (EConstr.of_constr (mkApp (delayed_force well_founded,[|input_type;relation|]))) + (mkApp (delayed_force well_founded,[|input_type;relation|])) (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) ( (* observe_tac *) (* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (EConstr.of_constr (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])))) + Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) ) ) ) @@ -1632,7 +1628,7 @@ let prove_principle_for_gen [ Proofview.V82.of_tactic (generalize [lemma]); Proofview.V82.of_tactic (Simple.intro hid); - Proofview.V82.of_tactic (Elim.h_decompose_and (EConstr.mkVar hid)); + Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid)); (fun g -> let new_hyps = pf_ids_of_hyps g in tcc_list := List.rev (List.subtract Id.equal new_hyps (hid::hyps)); @@ -1656,7 +1652,7 @@ let prove_principle_for_gen ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by (Name acc_rec_arg_id) - (EConstr.of_constr (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))) + (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) (Proofview.V82.tactic prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); @@ -1665,10 +1661,10 @@ let prove_principle_for_gen (* observe_tac "h_fix " *) (Proofview.V82.of_tactic (fix (Some fix_id) (List.length args_ids + 1))); (* (fun g -> observe (Printer.pr_goal (sig_it g) ++ fnl() ++ pr_lconstr_env (pf_env g ) (pf_unsafe_type_of g (mkVar fix_id) )); tclIDTAC g); *) h_intros (List.rev (acc_rec_arg_id::args_ids)); - Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.of_constr (mkConst eq_ref))); + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> let body = - let _,args = destApp (pf_concl gl') in + let _,args = destApp (project gl') (EConstr.of_constr (pf_concl gl')) in Array.last args in let body_info rec_hyps = @@ -1711,7 +1707,7 @@ let prove_principle_for_gen ) ); - is_valid = is_valid_hypothesis predicates_names + is_valid = is_valid_hypothesis (project gl') predicates_names } in let ptes_info : pte_info Id.Map.t = diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 34ce669672..769d726d70 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -4,7 +4,7 @@ open Term val prove_princ_for_struct : Evd.evar_map ref -> bool -> - int -> constant array -> constr array -> int -> Tacmach.tactic + int -> constant array -> EConstr.constr array -> int -> Tacmach.tactic val prove_principle_for_gen : @@ -12,8 +12,8 @@ val prove_principle_for_gen : constr option ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) - types -> (* the type of the recursive argument *) - constr -> (* the wf relation used to prove the function *) + EConstr.types -> (* the type of the recursive argument *) + EConstr.constr -> (* the wf relation used to prove the function *) Tacmach.tactic diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 8683f68c64..d964002f9f 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -63,7 +63,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = else args in Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), - compose_prod real_args (mkSort new_sort)) + Term.compose_prod real_args (mkSort new_sort)) in let new_predicates = List.map_i @@ -254,7 +254,7 @@ let change_property_sort evd toSort princ princName = let args,ty = decompose_prod (get_type decl) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); - compose_prod args (mkSort toSort) + Term.compose_prod args (mkSort toSort) ) in let evd,princName_as_constr = @@ -298,7 +298,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin hook ; (* let _tim1 = System.get_time () in *) - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map mkConstU funs) mutr_nparams))); + ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map EConstr.mkConstU funs) mutr_nparams))); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 3fa2644ca9..45ad332fc5 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -27,7 +27,7 @@ val generate_functional_principle : (* The tactic to use to make the proof w.r the number of params *) - (constr array -> int -> Tacmach.tactic) -> + (EConstr.constr array -> int -> Tacmach.tactic) -> unit val compute_new_princ_type_from_rel : constr array -> sorts array -> diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 560242bf27..27a892ca70 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -98,7 +98,6 @@ ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat END let functional_induction b c x pat = - let x = Option.map (Miscops.map_with_bindings EConstr.Unsafe.to_constr) x in Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) @@ -110,7 +109,6 @@ TACTIC EXTEND newfunind | [c] -> c | c::cl -> EConstr.applist(c,cl) in - let c = EConstr.Unsafe.to_constr c in Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] END (***** debug only ***) @@ -122,7 +120,6 @@ TACTIC EXTEND snewfunind | [c] -> c | c::cl -> EConstr.applist(c,cl) in - let c = EConstr.Unsafe.to_constr c in Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] END diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 0725bb11c1..fc5a287ae0 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -952,7 +952,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in mkGProd(n,t,new_b),id_to_exclude with Continue -> - let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in + let jmeq = Globnames.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in let ind,args' = Inductive.find_inductive env ty' in let mib,_ = Global.lookup_inductive (fst ind) in diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1b899c152f..e22fed391e 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -2,6 +2,7 @@ open CErrors open Util open Names open Term +open EConstr open Pp open Indfun_common open Libnames @@ -18,8 +19,8 @@ let is_rec_info sigma scheme_info = let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (RelDecl.get_type decl))) in - let free_rels_in_br = Termops.free_rels sigma (EConstr.of_constr new_branche) in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (EConstr.of_constr (RelDecl.get_type decl)))) in + let free_rels_in_br = Termops.free_rels sigma new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br ) @@ -32,20 +33,21 @@ let choose_dest_or_ind scheme_info args = let functional_induction with_clean c princl pat = let res = - let f,args = decompose_app c in fun g -> + let sigma = Tacmach.project g in + let f,args = decompose_app sigma c in let princ,bindings, princ_type,g' = match princl with | None -> (* No principle is given let's find the good one *) begin - match kind_of_term f with + match EConstr.kind sigma f with | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> user_err (str "Cannot find induction information on "++ - Printer.pr_lconstr (mkConst c') ) + Printer.pr_leconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma @@ -73,15 +75,16 @@ let functional_induction with_clean c princl pat = (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) user_err (str "Cannot find induction principle for " - ++Printer.pr_lconstr (mkConst c') ) + ++Printer.pr_leconstr (mkConst c') ) in - (princ,NoBindings, Tacmach.pf_unsafe_type_of g' (EConstr.of_constr princ),g') + let princ = EConstr.of_constr princ in + (princ,NoBindings,EConstr.of_constr (Tacmach.pf_unsafe_type_of g' princ),g') | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> - princ,binding,Tacmach.pf_unsafe_type_of g (EConstr.of_constr princ),g + princ,binding,EConstr.of_constr (Tacmach.pf_unsafe_type_of g princ),g in - let princ_type = EConstr.of_constr princ_type in + let sigma = Tacmach.project g' in let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in let args_as_induction_constr = let c_list = @@ -90,15 +93,13 @@ let functional_induction with_clean c princl pat = in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((EConstr.of_constr c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) + List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in - let princ = EConstr.of_constr princ in - let bindings = Miscops.map_bindings EConstr.of_constr bindings in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right - (fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc) + (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) args Id.Set.empty in @@ -247,7 +248,8 @@ let derive_inversion fix_names = let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - evd, destConst c::l + let c = EConstr.of_constr c in + evd, destConst evd c::l ) fix_names (evd',[]) @@ -267,7 +269,8 @@ let derive_inversion fix_names = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) in - evd,(fst (destInd id))::l + let id = EConstr.of_constr id in + evd,(fst (destInd evd id))::l ) fix_names (evd',[]) @@ -334,7 +337,7 @@ let error_error names e = let generate_principle (evd:Evd.evar_map ref) pconstants on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof - (continue_proof : int -> Names.constant array -> Term.constr array -> int -> + (continue_proof : int -> Names.constant array -> EConstr.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function (((_, name),_),_,_,_,_),_ -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in @@ -408,7 +411,8 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - evd,((destConst c)::l) + let c = EConstr.of_constr c in + evd,((destConst evd c)::l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl @@ -422,7 +426,8 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - evd,((destConst c)::l) + let c = EConstr.of_constr c in + evd,((destConst evd c)::l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl @@ -432,7 +437,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = + (_: int) (_:Names.constant array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation @@ -840,7 +845,7 @@ let make_graph (f_ref:global_reference) = | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - raise (UserError (None,str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr (mkConst c)) ) end | _ -> raise (UserError (None, str "Not a function reference") ) in diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 1c27bdface..ba89fe4a78 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -12,8 +12,8 @@ val do_generate_principle : val functional_induction : bool -> - Term.constr -> - (Term.constr * Term.constr bindings) option -> + EConstr.constr -> + (EConstr.constr * EConstr.constr bindings) option -> Tacexpr.or_and_intro_pattern option -> Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index 08b40a1f7e..2889d8d03a 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -130,8 +130,8 @@ let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(coq_constant "eq") -let refl_equal = lazy(coq_constant "eq_refl") +let eq = lazy(EConstr.of_constr (coq_constant "eq")) +let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl")) (*****************************************************************) (* Copy of the standart save mechanism but without the much too *) @@ -475,13 +475,13 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq" + EConstr.of_constr (Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq") with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl" + EConstr.of_constr (Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl") with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -489,10 +489,10 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> (coq_constant "well_founded") -let acc_rel = function () -> (coq_constant "Acc") -let acc_inv_id = function () -> (coq_constant "Acc_inv") -let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") +let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded") +let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") +let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") +let well_founded_ltof = function () -> EConstr.of_constr (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) @@ -501,9 +501,45 @@ let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (G | VarRef id -> EvalVarRef id | _ -> assert false;; -let list_rewrite (rev:bool) (eqs: (constr*bool) list) = - let eqs = List.map (Util.on_fst EConstr.of_constr) eqs in +let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = tclREPEAT (List.fold_right (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + +let decompose_lam_n sigma n = + let open EConstr in + if n < 0 then CErrors.error "decompose_lam_n: integer parameter must be positive"; + let rec lamdec_rec l n c = + if Int.equal n 0 then l,c + else match EConstr.kind sigma c with + | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c + | Cast (c,_,_) -> lamdec_rec l n c + | _ -> CErrors.error "decompose_lam_n: not enough abstractions" + in + lamdec_rec [] n + +let lamn n env b = + let open EConstr in + let rec lamrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | _ -> assert false + in + lamrec (n,env,b) + +(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) +let compose_lam l b = lamn (List.length l) l b + +(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) +let prodn n env b = + let open EConstr in + let rec prodrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | _ -> assert false + in + prodrec (n,env,b) + +(* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) +let compose_prod l b = prodn (List.length l) l b diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index e5c756f564..5836d65190 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -40,11 +40,11 @@ val chop_rprod_n : int -> Glob_term.glob_constr -> (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr val def_of_const : Term.constr -> Term.constr -val eq : Term.constr Lazy.t -val refl_equal : Term.constr Lazy.t +val eq : EConstr.constr Lazy.t +val refl_equal : EConstr.constr Lazy.t val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) -val jmeq : unit -> Term.constr -val jmeq_refl : unit -> Term.constr +val jmeq : unit -> EConstr.constr +val jmeq_refl : unit -> EConstr.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> unit Lemmas.declaration_hook CEphemeron.key -> unit @@ -107,10 +107,15 @@ val is_strict_tcc : unit -> bool val h_intros: Names.Id.t list -> Proof_type.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t -val acc_inv_id : Term.constr Util.delayed +val acc_inv_id : EConstr.constr Util.delayed val ltof_ref : Globnames.global_reference Util.delayed -val well_founded_ltof : Term.constr Util.delayed -val acc_rel : Term.constr Util.delayed -val well_founded : Term.constr Util.delayed +val well_founded_ltof : EConstr.constr Util.delayed +val acc_rel : EConstr.constr Util.delayed +val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference -val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic +val list_rewrite : bool -> (EConstr.constr*bool) list -> Proof_type.tactic + +val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> + (Names.Name.t * EConstr.t) list * EConstr.t +val compose_lam : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t +val compose_prod : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 27528c2dcc..be82010d9d 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -12,6 +12,7 @@ open CErrors open Util open Names open Term +open EConstr open Vars open Pp open Globnames @@ -25,6 +26,12 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration +let local_assum (na, t) = + RelDecl.LocalAssum (na, EConstr.Unsafe.to_constr t) + +let local_def (na, b, t) = + RelDecl.LocalDef (na, EConstr.Unsafe.to_constr b, EConstr.Unsafe.to_constr t) + (* Some pretty printing function for debugging purpose *) let pr_binding prc = @@ -108,11 +115,11 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - Universes.constr_of_global (Coqlib.build_coq_eq ()) + EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) with _ -> assert false let make_eq_refl () = try - Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq_refl ())) with _ -> assert false @@ -131,16 +138,16 @@ let make_eq_refl () = let generate_type evd g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) let evd',graph = - Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd graph))) + Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd !evd graph))) in + let graph = EConstr.of_constr graph in evd:=evd'; - let graph_arity = Typing.e_type_of (Global.env ()) evd (EConstr.of_constr graph) in - let graph_arity = EConstr.Unsafe.to_constr graph_arity in - let ctxt,_ = decompose_prod_assum graph_arity in + let graph_arity = Typing.e_type_of (Global.env ()) evd graph in + let ctxt,_ = decompose_prod_assum !evd graph_arity in let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") - | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl + | decl :: fun_ctxt -> fun_ctxt, EConstr.of_constr (RelDecl.get_type decl) in let rec args_from_decl i accu = function | [] -> accu @@ -180,12 +187,12 @@ let generate_type evd g_to_f f graph i = \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt + local_assum (Name res_id, lift 1 res_type) :: local_def (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f - then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + then local_assum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else local_assum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* @@ -194,7 +201,7 @@ let generate_type evd g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant,u = match kind_of_term f with + let f_as_constant,u = match EConstr.kind !evd f with | Const c' -> c' | _ -> error "Must be used with a function" in @@ -203,8 +210,8 @@ let find_induction_principle evd f = | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in - let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr rect_lemma) in - let typ = EConstr.Unsafe.to_constr typ in + let rect_lemma = EConstr.of_constr rect_lemma in + let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ @@ -248,12 +255,12 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind,u = destInd graphs_constr.(i) in + let graph_ind,u = destInd evd graphs_constr.(i) in let kn = fst graph_ind in let mib,_ = Global.lookup_inductive graph_ind in (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in - let princ_type = nf_zeta (EConstr.of_constr princ_type) in + let princ_type = nf_zeta princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in @@ -273,13 +280,13 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (RelDecl.get_type decl))))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (EConstr.of_constr (RelDecl.get_type decl)))))) ) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd eq_ind, 1) in + let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) let ind_number = ref 0 and min_constr_number = ref 0 in @@ -307,18 +314,20 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let constructor_args g = List.fold_right (fun hid acc -> - let type_of_hid = pf_unsafe_type_of g (EConstr.mkVar hid) in - match kind_of_term type_of_hid with + let type_of_hid = pf_unsafe_type_of g (mkVar hid) in + let type_of_hid = EConstr.of_constr type_of_hid in + let sigma = project g in + match EConstr.kind sigma type_of_hid with | Prod(_,_,t') -> begin - match kind_of_term t' with + match EConstr.kind sigma t' with | Prod(_,t'',t''') -> begin - match kind_of_term t'',kind_of_term t''' with + match EConstr.kind sigma t'',EConstr.kind sigma t''' with | App(eq,args), App(graph',_) when - (Term.eq_constr eq eq_ind) && - Array.exists (Constr.eq_constr_nounivs graph') graphs_constr -> + (EConstr.eq_constr sigma eq eq_ind) && + Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::acc) | _ -> mkVar hid :: acc @@ -386,10 +395,10 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* introducing the the result of the graph and the equality hypothesis *) observe_tac "introducing" (tclMAP (fun x -> Proofview.V82.of_tactic (Simple.intro x)) [res;hres]); (* replacing [res] with its value *) - observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.mkVar hres))); + observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); (* Conclusion *) observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (EConstr.of_constr (app_constructor g))) g) + Proofview.V82.of_tactic (exact_check (app_constructor g)) g) ] ) g @@ -401,8 +410,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes match ctxt with | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") | hres::res::decl::ctxt -> - let res = Term.it_mkLambda_or_LetIn - (Term.it_mkProd_or_LetIn concl [hres;res]) + let res = EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres;res]) (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt) in res @@ -430,7 +439,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.rev (fst (List.fold_left2 (fun (bindings,avoid) decl p -> let id = Namegen.next_ident_away (Nameops.out_name (RelDecl.get_name decl)) avoid in - (EConstr.Unsafe.to_constr (nf_zeta (EConstr.of_constr p)))::bindings,id::avoid) + (nf_zeta p)::bindings,id::avoid) ([],avoid) princ_infos.predicates (lemmas))) @@ -442,7 +451,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes observe_tac "principle" (Proofview.V82.of_tactic (assert_by (Name principle_id) princ_type - (exact_check (EConstr.of_constr f_principle)))); + (exact_check f_principle))); observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) observe_tac "idtac" tclIDTAC; @@ -451,8 +460,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes "functional_induction" ( (fun gl -> let term = mkApp (mkVar principle_id,Array.of_list bindings) in - let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl (EConstr.of_constr term) in - Proofview.V82.of_tactic (apply (EConstr.of_constr term)) gl') + let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl term in + Proofview.V82.of_tactic (apply term) gl') )) (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) ] @@ -469,7 +478,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | LocalAssum (id,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -493,44 +502,45 @@ let rec intros_with_rewrite g = and intros_with_rewrite_aux : tactic = fun g -> let eq_ind = make_eq () in - match kind_of_term (pf_concl g) with + let sigma = project g in + match EConstr.kind sigma (EConstr.of_constr (pf_concl g)) with | Prod(_,t,t') -> begin - match kind_of_term t with - | App(eq,args) when (Term.eq_constr eq eq_ind) -> - if Reductionops.is_conv (pf_env g) (project g) (EConstr.of_constr args.(1)) (EConstr.of_constr args.(2)) + match EConstr.kind sigma t with + | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> + if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) + else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) then tclTHENSEQ[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g - else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) + else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) then tclTHENSEQ[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g - else if isVar args.(1) + else if isVar sigma args.(1) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar args.(1)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.mkVar id))); + generalize_dependent_of (destVar sigma args.(1)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g - else if isVar args.(2) + else if isVar sigma args.(2) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar args.(2)) id; - tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (EConstr.mkVar id))); + generalize_dependent_of (destVar sigma args.(2)) id; + tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); intros_with_rewrite ] g @@ -539,15 +549,15 @@ and intros_with_rewrite_aux : tactic = let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ[ Proofview.V82.of_tactic (Simple.intro id); - tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.mkVar id))); + tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g end - | Ind _ when Term.eq_constr t (Coqlib.build_coq_False ()) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Coqlib.build_coq_False ())) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ - Proofview.V82.of_tactic (simplest_case (EConstr.of_constr v)); + Proofview.V82.of_tactic (simplest_case v); intros_with_rewrite ] g | LetIn _ -> @@ -581,10 +591,10 @@ and intros_with_rewrite_aux : tactic = let rec reflexivity_with_destruct_cases g = let destruct_case () = try - match kind_of_term (snd (destApp (pf_concl g))).(2) with + match EConstr.kind (project g) (snd (destApp (project g) (EConstr.of_constr (pf_concl g)))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ - Proofview.V82.of_tactic (simplest_case (EConstr.of_constr v)); + Proofview.V82.of_tactic (simplest_case v); Proofview.V82.of_tactic intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] @@ -598,11 +608,11 @@ let rec reflexivity_with_destruct_cases g = match sc with None -> tclIDTAC g | Some id -> - match kind_of_term (pf_unsafe_type_of g (EConstr.mkVar id)) with - | App(eq,[|_;t1;t2|]) when Term.eq_constr eq eq_ind -> - if Equality.discriminable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) + match EConstr.kind (project g) (EConstr.of_constr (pf_unsafe_type_of g (mkVar id))) with + | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> + if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g - else if Equality.injectable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) + else if Equality.injectable (pf_env g) (project g) t1 t2 then tclTHENSEQ [Proofview.V82.of_tactic (Equality.injHyp None id);thin [id];intros_with_rewrite] g else tclIDTAC g | _ -> tclIDTAC g @@ -657,7 +667,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (EConstr.of_constr (Termops.it_mkLambda_or_LetIn concl ctxt))) + (fun (_,(ctxt,concl)) -> nf_zeta (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) @@ -698,7 +708,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in let infos = - try find_Function_infos (fst (destConst funcs.(j))) + try find_Function_infos (fst (destConst (project g) funcs.(j))) with Not_found -> error "No graph found" in if infos.is_general @@ -710,7 +720,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = in tclTHENSEQ[ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) ids; - Proofview.V82.of_tactic (Equality.rewriteLR (EConstr.of_constr (mkConst eq_lemma))); + Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_lemma)); (* Don't forget to $\zeta$ normlize the term since the principles have been $\zeta$-normalized *) Proofview.V82.of_tactic (reduce @@ -720,11 +730,11 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = }) Locusops.onConcl) ; - Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar ids)); + Proofview.V82.of_tactic (generalize (List.map mkVar ids)); thin ids ] else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -795,11 +805,10 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; - let type_of_lemma = Term.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let _ = Typing.e_type_of (Global.env ()) evd (EConstr.of_constr type_of_lemma) in - let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in - let type_of_lemma = EConstr.Unsafe.to_constr type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); + let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in + let type_of_lemma = nf_zeta type_of_lemma in + observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) funs_constr @@ -818,7 +827,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( Array.of_list (List.map (fun entry -> - (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type ) + (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type )) ) (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs)) ) @@ -839,7 +848,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( lem_id (Decl_kinds.Global,Flags.is_universe_polymorphism (),((Decl_kinds.Proof Decl_kinds.Theorem))) !evd - typ + (EConstr.Unsafe.to_constr typ) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") @@ -849,7 +858,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst lem_cst_constr in + let lem_cst_constr = EConstr.of_constr lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with correctness_lemma = Some lem_cst}; ) @@ -863,18 +873,17 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = - Term.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in - let type_of_lemma = nf_zeta (EConstr.of_constr type_of_lemma) in - let type_of_lemma = EConstr.Unsafe.to_constr type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + let type_of_lemma = nf_zeta type_of_lemma in + observe (str "type_of_lemma := " ++ Printer.pr_leconstr type_of_lemma); type_of_lemma,type_info ) funs_constr graphs_constr in - let (kn,_) as graph_ind,u = (destInd graphs_constr.(0)) in + let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) !evd @@ -901,7 +910,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) sigma - (fst lemmas_types_infos.(i)) + (EConstr.Unsafe.to_constr (fst lemmas_types_infos.(i))) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") @@ -910,7 +919,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst lem_cst_constr in + let lem_cst_constr = EConstr.of_constr lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) @@ -925,10 +935,12 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = - let typ = pf_unsafe_type_of g (EConstr.mkVar hid) in - match kind_of_term typ with - | App(i,args) when isInd i -> - let ((kn',num) as ind'),u = destInd i in + let sigma = project g in + let typ = pf_unsafe_type_of g (mkVar hid) in + let typ = EConstr.of_constr typ in + match EConstr.kind sigma typ with + | App(i,args) when isInd sigma i -> + let ((kn',num) as ind'),u = destInd sigma i in if MutInd.equal kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = @@ -945,7 +957,7 @@ let revert_graph kn post_tac hid g = let f_args,res = Array.chop (Array.length args - 1) args in tclTHENSEQ [ - Proofview.V82.of_tactic (generalize [EConstr.of_constr (applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid]))]); + Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); post_tac hid @@ -976,20 +988,22 @@ let revert_graph kn post_tac hid g = let functional_inversion kn hid fconst f_correct : tactic = fun g -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in - let type_of_h = pf_unsafe_type_of g (EConstr.mkVar hid) in - match kind_of_term type_of_h with - | App(eq,args) when Term.eq_constr eq (make_eq ()) -> + let sigma = project g in + let type_of_h = pf_unsafe_type_of g (mkVar hid) in + let type_of_h = EConstr.of_constr type_of_h in + match EConstr.kind sigma type_of_h with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> let pre_tac,f_args,res = - match kind_of_term args.(1),kind_of_term args.(2) with - | App(f,f_args),_ when Term.eq_constr f fconst -> + match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with + | App(f,f_args),_ when EConstr.eq_constr sigma f fconst -> ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) - |_,App(f,f_args) when Term.eq_constr f fconst -> + |_,App(f,f_args) when EConstr.eq_constr sigma f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in tclTHENSEQ[ pre_tac hid; - Proofview.V82.of_tactic (generalize [EConstr.of_constr (applist(f_correct,(Array.to_list f_args)@[res;mkVar hid]))]); + Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); @@ -1028,23 +1042,25 @@ let invfun qhyp f g = Proofview.V82.of_tactic begin Tactics.try_intros_until (fun hid -> Proofview.V82.tactic begin fun g -> - let hyp_typ = pf_unsafe_type_of g (EConstr.mkVar hid) in - match kind_of_term hyp_typ with - | App(eq,args) when Term.eq_constr eq (make_eq ()) -> + let sigma = project g in + let hyp_typ = pf_unsafe_type_of g (mkVar hid) in + let hyp_typ = EConstr.of_constr hyp_typ in + match EConstr.kind sigma hyp_typ with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> begin - let f1,_ = decompose_app args.(1) in + let f1,_ = decompose_app sigma args.(1) in try - if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (fst (destConst f1)) in + if not (isConst sigma f1) then failwith ""; + let finfos = find_Function_infos (fst (destConst sigma f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct g with | Failure "" | Option.IsNone | Not_found -> try - let f2,_ = decompose_app args.(2) in - if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (fst (destConst f2)) in + let f2,_ = decompose_app sigma args.(2) in + if not (isConst sigma f2) then failwith ""; + let finfos = find_Function_infos (fst (destConst sigma f2)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 23b308efbe..a80a7b5e7c 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -6,7 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open Term +open EConstr open Vars open Namegen open Environ @@ -42,17 +45,22 @@ open Indfun_common open Sigma.Notations open Context.Rel.Declaration +let local_assum (na, t) = + LocalAssum (na, EConstr.Unsafe.to_constr t) + +let local_def (na, b, t) = + LocalDef (na, EConstr.Unsafe.to_constr b, EConstr.Unsafe.to_constr t) (* Ugly things which should not be here *) let coq_constant m s = - Coqlib.coq_constant "RecursiveDefinition" m s + EConstr.of_constr (Coqlib.coq_constant "RecursiveDefinition" m s) let arith_Nat = ["Arith";"PeanoNat";"Nat"] let arith_Lt = ["Arith";"Lt"] let coq_init_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s + EConstr.of_constr (Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s) let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in @@ -76,8 +84,8 @@ let def_of_const t = ) |_ -> assert false -let type_of_const t = - match (kind_of_term t) with +let type_of_const sigma t = + match (EConstr.kind sigma t) with Const sp -> Typeops.type_of_constant (Global.env()) sp |_ -> assert false @@ -98,9 +106,7 @@ let nf_zeta env = let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty @@ -116,8 +122,8 @@ let pf_get_new_ids idl g = [] let compute_renamed_type gls c = - rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] - (pf_unsafe_type_of gls (EConstr.of_constr c)) + EConstr.of_constr (rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] + (pf_unsafe_type_of gls c)) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" @@ -147,7 +153,7 @@ let coq_O = function () -> (coq_init_constant "O") let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> (constr_of_global (delayed_force max_ref)) +let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -166,7 +172,8 @@ let simpl_iter clause = clause (* Others ugly things ... *) -let (value_f:constr list -> global_reference -> constr) = +let (value_f:Constr.constr list -> global_reference -> Constr.constr) = + let open Term in fun al fterm -> let d0 = Loc.ghost in let rev_x_id_l = @@ -199,7 +206,7 @@ let (value_f:constr list -> global_reference -> constr) = let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = +let (declare_f : Id.t -> logical_kind -> Constr.constr list -> global_reference -> global_reference) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -286,7 +293,7 @@ let tclUSER tac is_mes l g = let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes - then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (EConstr.of_constr (delayed_force well_founded_ltof))) gl) + then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) @@ -301,9 +308,9 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = (* [check_not_nested forbidden e] checks that [e] does not contains any variable of [forbidden] *) -let check_not_nested forbidden e = +let check_not_nested sigma forbidden e = let rec check_not_nested e = - match kind_of_term e with + match EConstr.kind sigma e with | Rel _ -> () | Var x -> if Id.List.mem x forbidden @@ -327,7 +334,7 @@ let check_not_nested forbidden e = try check_not_nested e with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -374,15 +381,17 @@ type journey_info = -let rec add_vars forbidden e = - match kind_of_term e with +let add_vars sigma forbidden e = + let rec aux forbidden e = + match EConstr.kind sigma e with | Var x -> x::forbidden - | _ -> Term.fold_constr add_vars forbidden e - + | _ -> EConstr.fold sigma aux forbidden e + in + aux forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = fun g -> - let rev_context,b = decompose_lam_n nb_lam e in + let rev_context,b = decompose_lam_n (project g) nb_lam e in let ids = List.fold_left (fun acc (na,_) -> let pre_id = match na with @@ -402,20 +411,20 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = Proofview.V82.of_tactic (clear to_intros); h_intros to_intros; (fun g' -> - let ty_teq = pf_unsafe_type_of g' (EConstr.mkVar heq) in + let ty_teq = pf_unsafe_type_of g' (mkVar heq) in + let ty_teq = EConstr.of_constr ty_teq in let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with DestKO -> assert false in + let _,args = try destApp (project g') ty_teq with DestKO -> assert false in args.(1),args.(2) in - let new_b' = Termops.replace_term (project g') (EConstr.of_constr teq_lhs) (EConstr.of_constr teq_rhs) (EConstr.of_constr new_b) in - let new_b' = EConstr.Unsafe.to_constr new_b' in + let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in let new_infos = { infos with info = new_b'; eqs = heq::infos.eqs; forbidden_ids = if forbid_new_ids - then add_vars infos.forbidden_ids new_b' + then add_vars (project g') infos.forbidden_ids new_b' else infos.forbidden_ids } in finalize_tac new_infos g' @@ -424,8 +433,9 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = ) ] g -let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = - match kind_of_term expr_info.info with +let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = + let sigma = project g in + match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint" | Proj _ -> error "Function cannot treat projections" | LetIn(na,b,t,e) -> @@ -434,24 +444,24 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = jinfo.letiN (na,b,t,e) expr_info continuation_tac in travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} + {expr_info with info = b; is_final=false} g end | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") | Prod _ -> begin try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Lambda(n,t,b) -> begin try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -462,15 +472,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = travel jinfo continuation_tac_a {expr_info with info = a; is_main_branch = false; - is_final = false} + is_final = false} g end | App _ -> - let f,args = decompose_app expr_info.info in - if Term.eq_constr f (expr_info.f_constr) - then jinfo.app_reC (f,args) expr_info continuation_tac expr_info + let f,args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f (expr_info.f_constr) + then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g else begin - match kind_of_term f with + match EConstr.kind sigma f with | App _ -> assert false (* f is coming from a decompose_app *) | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ | Var _ -> @@ -478,15 +488,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = let new_continuation_tac = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) + expr_info.is_main_branch new_continuation_tac new_infos g + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr expr_info.info) end - | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} + | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info + new_continuation_tac expr_info g and travel_args jinfo is_final continuation_tac infos = let (f_args',args) = infos.info in match args with @@ -503,36 +513,37 @@ and travel_args jinfo is_final continuation_tac infos = {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = observe_tac - (str jinfo.message ++ Printer.pr_lconstr expr_info.info) + (str jinfo.message ++ Printer.pr_leconstr expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) let rec prove_lt hyple g = + let sigma = project g in begin try - let (varx,varz) = match decompose_app (pf_concl g) with - | _, x::z::_ when isVar x && isVar z -> x, z + let (varx,varz) = match decompose_app sigma (EConstr.of_constr (pf_concl g)) with + | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z | _ -> assert false in let h = List.find (fun id -> - match decompose_app (pf_unsafe_type_of g (EConstr.mkVar id)) with - | _, t::_ -> Term.eq_constr t varx + match decompose_app sigma (EConstr.of_constr (pf_unsafe_type_of g (mkVar id))) with + | _, t::_ -> EConstr.eq_constr sigma t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (EConstr.mkVar h))))) in + List.hd (List.tl (snd (decompose_app sigma (EConstr.of_constr (pf_unsafe_type_of g (mkVar h)))))) in observe_tclTHENLIST (str "prove_lt1")[ - Proofview.V82.of_tactic (apply (EConstr.of_constr (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|])))); + Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( observe_tclTHENLIST (str "prove_lt2")[ - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force lt_S_n))); + Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) ) @@ -550,15 +561,15 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in observe_tclTHENLIST (str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr s_max])); + Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); Proofview.V82.of_tactic (intro_then (fun id -> Proofview.V82.tactic begin observe_tac (str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (EConstr.mkVar id))) + (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) [ observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(EConstr.of_constr (mkApp(delayed_force lt_n_O,[|s_max|])))); + Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); Proofview.V82.of_tactic default_full_auto]; observe_tclTHENLIST (str "destruct_bounds_aux2")[ observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id])); @@ -589,7 +600,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = ] g | (_,v_bound)::l -> observe_tclTHENLIST (str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (EConstr.mkVar v_bound)); + Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); Proofview.V82.of_tactic (clear [v_bound]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 @@ -598,7 +609,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (fun p -> observe_tclTHENLIST (str "destruct_bounds_aux4")[ Proofview.V82.of_tactic (simplest_elim - (EConstr.of_constr (mkApp(delayed_force max_constr, [| bound; mkVar p|])))); + (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with @@ -623,7 +634,7 @@ let terminate_app f_and_args expr_info continuation_tac infos = observe_tclTHENLIST (str "terminate_app1")[ continuation_tac infos; observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos @@ -634,17 +645,18 @@ let terminate_others _ expr_info continuation_tac infos = observe_tclTHENLIST (str "terminate_others")[ continuation_tac infos; observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); observe_tac (str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos -let terminate_letin (na,b,t,e) expr_info continuation_tac info = +let terminate_letin (na,b,t,e) expr_info continuation_tac info g = + let sigma = project g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -655,7 +667,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = | Name id -> id::info.forbidden_ids else info.forbidden_ids in - continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} + continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in @@ -682,30 +694,31 @@ let mkDestructEq : (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.occur_term (project g) (EConstr.of_constr expr) (EConstr.of_constr (get_type decl))) + if Id.List.mem id not_on_hyp || not (Termops.occur_term (project g) expr (EConstr.of_constr (get_type decl))) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in - let type_of_expr = pf_unsafe_type_of g (EConstr.of_constr expr) in + let type_of_expr = pf_unsafe_type_of g expr in + let type_of_expr = EConstr.of_constr type_of_expr in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in - let new_hyps = List.map EConstr.of_constr new_hyps in pf_typel new_hyps (fun _ -> observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars = { run = fun sigma -> - let redfun = pattern_occs [Locus.AllOccurrencesBut [1], EConstr.of_constr expr] in + let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) in Sigma (c, sigma, p) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); - Proofview.V82.of_tactic (simplest_case (EConstr.of_constr expr))]), to_revert + Proofview.V82.of_tactic (simplest_case expr)]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = + let sigma = project g in let f_is_present = try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -719,7 +732,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_lconstr a') + observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr a') (try (tclTHENS destruct_tac @@ -728,16 +741,17 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + (observe_tac (str "is computable " ++ Printer.pr_leconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g -let terminate_app_rec (f,args) expr_info continuation_tac _ = - List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids)) +let terminate_app_rec (f,args) expr_info continuation_tac _ g = + let sigma = project g in + List.iter (check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try - let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in observe_tclTHENLIST (str "terminate_app_rec")[ continuation_tac new_infos; @@ -745,16 +759,16 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = then observe_tclTHENLIST (str "terminate_app_rec1")[ observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (str "destruct_bounds (3)") (destruct_bounds new_infos) ] else tclIDTAC - ] + ] g with Not_found -> observe_tac (str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (EConstr.of_constr (mkApp(mkVar expr_info.ih,Array.of_list args))))) + (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) [ observe_tclTHENLIST (str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); @@ -775,7 +789,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = then observe_tclTHENLIST (str "terminate_app_rec4")[ observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); observe_tac (str "destruct_bounds (2)") (destruct_bounds new_infos) ] @@ -788,7 +802,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ]; observe_tac (str "proving decreasing") ( tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (EConstr.of_constr (Lazy.force expr_info.acc_inv)))) + (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) [ observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); observe_tclTHENLIST (str "terminate_app_rec5") @@ -808,7 +822,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ); ] ]) - ]) + ]) g end let terminate_info = @@ -830,26 +844,28 @@ let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = + let sigma = project g in let x,z = - let _,args = decompose_app (pf_concl g) in + let _,args = decompose_app sigma (EConstr.of_constr (pf_concl g)) in (List.hd args,List.hd (List.tl args)) in tclFIRST[ Proofview.V82.of_tactic assumption; - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_n))); + Proofview.V82.of_tactic (apply (delayed_force le_n)); begin try let matching_fun = pf_is_matching g - (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in + (Pattern.PApp(Pattern.PRef (reference_of_constr (EConstr.Unsafe.to_constr (le ()))),[|Pattern.PVar (destVar sigma x);Pattern.PMeta None|])) in let (h,t) = List.find (fun (_,t) -> matching_fun (EConstr.of_constr t)) (pf_hyps_types g) in + let t = EConstr.of_constr t in let y = - let _,args = decompose_app t in + let _,args = decompose_app sigma t in List.hd (List.tl args) in observe_tclTHENLIST (str "prove_le")[ - Proofview.V82.of_tactic (apply(EConstr.of_constr (mkApp(le_trans (),[|x;y;z;mkVar h|])))); + Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); observe_tac (str "prove_le (rec)") (prove_le) ] with Not_found -> tclFAIL 0 (mt()) @@ -863,23 +879,24 @@ let rec make_rewrite_list expr_info max = function observe_tac (str "make_rewrite_list") (tclTHENS (observe_tac (str "rewrite heq on " ++ pr_id p ) ( (fun g -> + let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in Nameops.out_name k_na,Nameops.out_name def_na in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true - (EConstr.mkVar hp, + (mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, - EConstr.of_constr expr_info.f_constr;Loc.ghost,NamedHyp k, - EConstr.of_constr (f_S max)]) false) g) ) + expr_info.f_constr;Loc.ghost,NamedHyp k, + f_S max]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_n_Sm))); + Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); observe_tac (str "prove_le(2)") prove_le ] ] ) @@ -889,20 +906,21 @@ let make_rewrite expr_info l hp max = (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) (observe_tac (str "make_rewrite") (tclTHENS (fun g -> + let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in Nameops.out_name k_na,Nameops.out_name def_na in observe_tac (str "general_rewrite_bindings") (Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences true (* dep proofs also: *) true - (EConstr.mkVar hp, + (mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, - EConstr.of_constr expr_info.f_constr;Loc.ghost,NamedHyp k, - EConstr.of_constr (f_S (f_S max))]) false)) g) + expr_info.f_constr;Loc.ghost,NamedHyp k, + f_S (f_S max)]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ @@ -931,7 +949,7 @@ let rec compute_max rew_tac max l = | (_,p,_)::l -> observe_tclTHENLIST (str "compute_max")[ Proofview.V82.of_tactic (simplest_elim - (EConstr.of_constr (mkApp(delayed_force max_constr, [| max; mkVar p|])))); + (mkApp(delayed_force max_constr, [| max; mkVar p|]))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with @@ -950,7 +968,7 @@ let rec destruct_hex expr_info acc l = end | (v,hex)::l -> observe_tclTHENLIST (str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (EConstr.mkVar hex)); + Proofview.V82.of_tactic (simplest_case (mkVar hex)); Proofview.V82.of_tactic (clear [hex]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hp -> @@ -977,36 +995,37 @@ let rec intros_values_eq expr_info acc = let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_lconstr expr_info.info) + observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_lconstr expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_lconstr expr_info.info) (continuation_tac infos) + (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos -let equation_app_rec (f,args) expr_info continuation_tac info = +let equation_app_rec (f,args) expr_info continuation_tac info g = + let sigma = project g in begin try - let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tac (str "app_rec found") (continuation_tac new_infos) + observe_tac (str "app_rec found") (continuation_tac new_infos) g with Not_found -> if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (expr_info.f_terminate,Array.of_list args)))); + [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) - ] + ] g else observe_tclTHENLIST (str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (expr_info.f_terminate,Array.of_list args)))); + Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) - ] + ] g end let equation_info = @@ -1025,6 +1044,8 @@ let prove_eq = travel equation_info (* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F *) let compute_terminate_type nb_args func = + let open Term in + let open CVars in let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = @@ -1037,6 +1058,7 @@ let compute_terminate_type nb_args func = ) in let right = mkRel 5 in + let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in @@ -1049,7 +1071,7 @@ let compute_terminate_type nb_args func = delayed_force nat, (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in - let value = mkApp(constr_of_global (delayed_force coq_sig_ref), + let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value @@ -1089,9 +1111,9 @@ let termination_proof_header is_mes input_type ids args_id relation (str "first assert") (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) - (EConstr.of_constr (mkApp (delayed_force acc_rel, + (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) - )) + ) )) ) [ @@ -1101,7 +1123,7 @@ let termination_proof_header is_mes input_type ids args_id relation (str "second assert") (Proofview.V82.of_tactic (assert_before (Name wf_thm) - (EConstr.of_constr (mkApp (delayed_force well_founded,[|input_type;relation|]))) + (mkApp (delayed_force well_founded,[|input_type;relation|])) )) ) [ @@ -1110,7 +1132,7 @@ let termination_proof_header is_mes input_type ids args_id relation (* this gives the accessibility argument *) observe_tac (str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (EConstr.of_constr (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])))) + (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) ) ] ; @@ -1119,7 +1141,7 @@ let termination_proof_header is_mes input_type ids args_id relation [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (Proofview.V82.of_tactic (clear [id]))) + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1))); @@ -1133,25 +1155,27 @@ let termination_proof_header is_mes input_type ids args_id relation -let rec instantiate_lambda t l = +let rec instantiate_lambda sigma t l = match l with | [] -> t | a::l -> - let (_, _, body) = destLambda t in - instantiate_lambda (subst1 a body) l + let (_, _, body) = destLambda sigma t in + instantiate_lambda sigma (subst1 a body) l let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> + let sigma = project g in let ids = Termops.ids_of_named_context (pf_hyps g) in let func_body = (def_of_const (constr_of_global func)) in - let (f_name, _, body1) = destLambda func_body in + let func_body = EConstr.of_constr func_body in + let (f_name, _, body1) = destLambda sigma func_body in let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids | Anonymous -> anomaly (Pp.str "Anonymous function") in - let n_names_types,_ = decompose_lam_n nb_args body1 in + let n_names_types,_ = decompose_lam_n sigma nb_args body1 in let n_ids,ids = List.fold_left (fun (n_ids,ids) (n_name,_) -> @@ -1165,7 +1189,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in + let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in termination_proof_header is_mes input_type @@ -1207,17 +1231,17 @@ let get_current_subgoals_types () = let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in sigma, List.map (Goal.V82.abstract_type sigma) sgs -let build_and_l l = +let build_and_l sigma l = let and_constr = Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = - Term.mkApp(and_constr,[|p1;p2|]) in + mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in let rec is_well_founded t = - match kind_of_term t with + match EConstr.kind sigma t with | Prod(_,_,t') -> is_well_founded t' | App(_,_) -> - let (f,_) = decompose_app t in - Term.eq_constr f (well_founded ()) + let (f,_) = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) | _ -> false in @@ -1248,16 +1272,16 @@ let is_rec_res id = String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name with Invalid_argument _ -> false -let clear_goals = +let clear_goals sigma = let rec clear_goal t = - match kind_of_term t with + match EConstr.kind sigma t with | Prod(Name id as na,t',b) -> let b' = clear_goal b in - if noccurn 1 b' && (is_rec_res id) + if noccurn sigma 1 b' && (is_rec_res id) then Vars.lift (-1) b' else if b' == b then t else mkProd(na,t',b') - | _ -> Term.map_constr clear_goal t + | _ -> EConstr.map sigma clear_goal t in List.map clear_goal @@ -1265,9 +1289,9 @@ let clear_goals = let build_new_goal_type () = let sigma, sub_gls_types = get_current_subgoals_types () in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) - let sub_gls_types = clear_goals sub_gls_types in + let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) - let res = build_and_l sub_gls_types in + let res = build_and_l sigma sub_gls_types in sigma, res let is_opaque_constant c = @@ -1288,7 +1312,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp anomaly (Pp.str "open_new_goal with an unamed theorem") in let na = next_global_ident_away name [] in - if Termops.occur_existential sigma (EConstr.of_constr gls_type) then + if Termops.occur_existential sigma gls_type then CErrors.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = @@ -1299,8 +1323,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in - ref_ := Some lemma ; - let lemma = EConstr.of_constr lemma in + ref_ := Some (EConstr.Unsafe.to_constr lemma); let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in @@ -1315,7 +1338,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (fun g -> let ids = pf_ids_of_hyps g in tclTHEN - (Proofview.V82.of_tactic (Elim.h_decompose_and (EConstr.mkVar hid))) + (Proofview.V82.of_tactic (Elim.h_decompose_and (mkVar hid))) (fun g -> let ids' = pf_ids_of_hyps g in lid := List.rev (List.subtract Id.equal ids' ids); @@ -1326,8 +1349,9 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ); ] gls) (fun g -> - match kind_of_term (pf_concl g) with - | App(f,_) when Term.eq_constr f (well_founded ()) -> + let sigma = project g in + match EConstr.kind sigma (EConstr.of_constr (pf_concl g)) with + | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; @@ -1336,11 +1360,11 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp tclCOMPLETE( tclFIRST[ tclTHEN - (Proofview.V82.of_tactic (eapply_with_bindings (EConstr.mkVar (List.nth !lid !h_num), NoBindings))) + (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (EConstr.of_constr (Lazy.force refl_equal)) sigma}] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ] ) @@ -1353,7 +1377,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Lemmas.start_proof na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) - sigma gls_type + sigma (EConstr.Unsafe.to_constr gls_type) (Lemmas.mk_hook hook); if Indfun_common.is_strict_tcc () then @@ -1387,7 +1411,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp let com_terminate tcc_lemma_name - tcc_lemma_ref + (tcc_lemma_ref : Constr.t option ref) is_mes fonctional_ref input_type @@ -1424,22 +1448,25 @@ let com_terminate let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = + let sigma = project g in let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (project g) (EConstr.of_constr (fst (type_of_const terminate_constr))) (*FIXME*) in + let terminate_constr = EConstr.of_constr terminate_constr in + let nargs = nb_prod (project g) (EConstr.of_constr (fst (type_of_const sigma terminate_constr))) (*FIXME*) in let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); observe_tac (str "simplest_case") - (Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (terminate_constr, - Array.of_list (List.map mkVar x)))))); + (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, + Array.of_list (List.map mkVar x))))); observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference - -> constr -> unit) = + -> Constr.constr -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> + let open CVars in let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c @@ -1459,13 +1486,13 @@ let (com_eqn : int -> Id.t -> (fun x -> prove_eq (fun _ -> tclIDTAC) {nb_arg=nb_arg; - f_terminate = constr_of_global terminate_ref; - f_constr = f_constr; + f_terminate = EConstr.of_constr (constr_of_global terminate_ref); + f_constr = EConstr.of_constr f_constr; concl_tac = tclIDTAC; func=functional_ref; - info=(instantiate_lambda - (def_of_const (constr_of_global functional_ref)) - (f_constr::List.map mkVar x) + info=(instantiate_lambda Evd.empty + (EConstr.of_constr (def_of_const (constr_of_global functional_ref))) + (EConstr.of_constr f_constr::List.map mkVar x) ); is_main_branch = true; is_final = true; @@ -1491,6 +1518,8 @@ let (com_eqn : int -> Id.t -> let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = + let open Term in + let open CVars in let env = Global.env() in let evd = ref (Evd.from_env env) in let function_type = interp_type_evars env evd type_of_f in @@ -1498,8 +1527,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let ty = interp_type_evars env evd ~impls:rec_impls eq in let evm, nf = Evarutil.nf_evars_and_universes !evd in - let equation_lemma_type = nf_betaiotazeta (nf ty) in + let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in let function_type = nf function_type in + let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in @@ -1557,7 +1587,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod evm (EConstr.of_constr res)) relation; + functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) (nb_prod evm (EConstr.of_constr res)) (EConstr.of_constr relation); if Flags.is_verbose () then msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ @@ -1570,8 +1600,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num tcc_lemma_name tcc_lemma_constr is_mes functional_ref - rec_arg_type - relation rec_arg_num + (EConstr.of_constr rec_arg_type) + (EConstr.of_constr relation) rec_arg_num term_id using_lemmas (List.length res_vars) diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index f60eedbe6e..9c1081b9d2 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -15,6 +15,6 @@ bool -> int -> Constrexpr.constr_expr -> (Term.pconstant -> Term.constr option ref -> Term.pconstant -> - Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit + Term.pconstant -> int -> EConstr.types -> int -> EConstr.constr -> 'a) -> Constrexpr.constr_expr list -> unit -- 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. --- plugins/cc/ccalgo.ml | 8 ++++-- plugins/cc/cctac.ml | 10 +++---- plugins/decl_mode/decl_proof_instr.ml | 40 +++++++++++++++----------- plugins/derive/derive.ml | 1 + plugins/firstorder/instances.ml | 2 +- plugins/firstorder/rules.ml | 4 +-- plugins/firstorder/sequent.ml | 2 ++ plugins/funind/functional_principles_proofs.ml | 30 +++++++++---------- plugins/funind/functional_principles_types.ml | 4 +-- plugins/funind/glob_term_to_relation.ml | 11 +++++-- plugins/funind/indfun.ml | 4 +-- plugins/funind/invfun.ml | 15 ++++------ plugins/funind/recdef.ml | 21 +++++++------- plugins/micromega/coq_micromega.ml | 7 +++-- plugins/omega/coq_omega.ml | 12 +++++--- plugins/quote/quote.ml | 6 ++-- plugins/romega/refl_omega.ml | 2 ++ plugins/rtauto/refl_tauto.ml | 3 +- plugins/setoid_ring/newring.ml | 9 +++--- plugins/ssrmatching/ssrmatching.ml4 | 3 ++ 20 files changed, 106 insertions(+), 88 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml index 0a980c03b7..aedcb75750 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -452,8 +452,9 @@ and applist_projection c l = applistc (mkProj (p, hd)) tl) | _ -> applistc c l -let rec canonize_name c = - let func = canonize_name in +let rec canonize_name sigma c = + let c = EConstr.Unsafe.to_constr c in + let func c = canonize_name sigma (EConstr.of_constr c) in match kind_of_term c with | Const (kn,u) -> let canon_const = constant_of_kn (canonical_con kn) in @@ -509,7 +510,7 @@ let rec add_term state t= let b=next uf in let trm = constr_of_term t in let typ = pf_unsafe_type_of state.gls (EConstr.of_constr trm) in - let typ = canonize_name typ in + let typ = canonize_name (project state.gls) typ in let new_node= match t with Symb _ | Product (_,_) -> @@ -833,6 +834,7 @@ let complete_one_class state i= app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = pf_unsafe_type_of state.gls (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in + let _c = EConstr.Unsafe.to_constr _c in let _args = List.map (fun i -> constr_of_term (term state.uf i)) pac.args in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 62892973d4..2ab4dced4d 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -219,7 +219,7 @@ let make_prb gls depth additionnal_terms = | `Nrule patts -> add_quant state id false patts end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it)); begin - match atom_of_constr env sigma (EConstr.of_constr (pf_concl gls)) with + match atom_of_constr env sigma (pf_concl gls) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter @@ -271,7 +271,7 @@ let constr_of_term c = EConstr.of_constr (constr_of_term c) let rec proof_tac p : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> - let type_of t = EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl t) in + let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with Ax c -> exact_check (EConstr.of_constr c) @@ -343,7 +343,7 @@ let refute_tac c t1 t2 p = let neweq= new_app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] - in refresh_universes (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl tt1)) k + in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k end } let refine_exact_check c gl = @@ -361,7 +361,7 @@ let convert_to_goal_tac c t1 t2 p = let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] - in refresh_universes (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl tt2)) k + in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k end } let convert_to_hyp_tac c1 t1 c2 t2 p = @@ -385,7 +385,7 @@ let discriminate_tac (cstr,u as cstru) p = let trivial = Universes.constr_of_global (Lazy.force _True) in let trivial = EConstr.of_constr trivial in let evm = Tacmach.New.project gl in - let evm, intype = refresh_type env evm (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl t1)) in + let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl t1) in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 7123ebcaf5..6a0ec3968f 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -74,7 +74,7 @@ let tcl_change_info_gen info_gen = let concl = pf_concl gls in let hyps = Goal.V82.hyps (project gls) it in let extra = Goal.V82.extra (project gls) it in - let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps (EConstr.of_constr concl) (info_gen extra) in + let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in let sigma = Goal.V82.partial_solution sigma it ev in { it = [gl] ; sigma= sigma; } ) @@ -88,7 +88,7 @@ let tcl_erase_info gls = let special_whd gl= let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) + (fun t -> CClosure.whd_val infos (CClosure.inject (EConstr.Unsafe.to_constr t))) let special_nf gl= let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in @@ -342,7 +342,7 @@ let rec replace_in_list m l = function | c::q -> if Int.equal m (fst c) then l@q else c::replace_in_list m l q let enstack_subsubgoals env se stack gls= - let hd,params = decompose_app (special_whd gls se.se_type) in + let hd,params = decompose_app (special_whd gls (EConstr.of_constr se.se_type)) in match kind_of_term hd with Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *) let mib,oib= @@ -397,6 +397,7 @@ let rec nf_list evd = let find_subsubgoal c ctyp skip submetas gls = let env= pf_env gls in let concl = pf_concl gls in + let concl = EConstr.Unsafe.to_constr concl in let evd = mk_evd ((0,concl)::submetas) gls in let stack = Stack.create () in let max_meta = @@ -412,7 +413,7 @@ let find_subsubgoal c ctyp skip submetas gls = try let unifier = Unification.w_unify env se.se_evd Reduction.CUMUL - ~flags:(Unification.elim_flags ()) (EConstr.of_constr ctyp) (EConstr.of_constr se.se_type) in + ~flags:(Unification.elim_flags ()) ctyp (EConstr.of_constr se.se_type) in if n <= 0 then {se with se_evd=meta_assign se.se_meta @@ -433,7 +434,8 @@ let concl_refiner metas body gls = let concl = pf_concl gls in let evd = sig_sig gls in let env = pf_env gls in - let sort = family_of_sort (Typing.e_sort_of env (ref evd) (EConstr.of_constr concl)) in + let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in + let concl = EConstr.Unsafe.to_constr concl in let rec aux env avoid subst = function [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") | (n,typ)::rest -> @@ -504,7 +506,7 @@ let mk_stat_or_thesis info gls = function This c -> c | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> pf_concl gls + | Thesis Plain -> EConstr.Unsafe.to_constr (pf_concl gls) let just_tac _then cut info gls0 = let last_item = @@ -536,7 +538,7 @@ let instr_cut mkstat _thus _then cut gls0 = let c_stat = mkstat info gls0 stat.st_it in let thus_tac gls= if _thus then - thus_tac (mkVar c_id) c_stat [] gls + thus_tac (mkVar c_id) (EConstr.of_constr c_stat) [] gls else tclIDTAC gls in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) [tclTHEN tcl_erase_info (just_tac _then cut info); @@ -582,7 +584,7 @@ let instr_rew _thus rew_side cut gls0 = | Name id -> id,true in let thus_tac new_eq gls= if _thus then - thus_tac (mkVar c_id) new_eq [] gls + thus_tac (mkVar c_id) (EConstr.of_constr new_eq) [] gls else tclIDTAC gls in match rew_side with Lhs -> @@ -610,7 +612,7 @@ let instr_claim _thus st gls0 = | Name id -> id,true in let thus_tac gls= if _thus then - thus_tac (mkVar id) st.st_it [] gls + thus_tac (mkVar id) (EConstr.of_constr st.st_it) [] gls else tclIDTAC gls in let ninfo1 = {pm_stack= (if _thus then Focus_claim else Claim)::info.pm_stack} in @@ -704,7 +706,7 @@ let instr_suffices _then cut gls0 = let c_ctx,c_head = build_applist c_stat metas in let c_term = applist (mkVar c_id,List.map mkMeta metas) in let thus_tac gls= - thus_tac c_term c_head c_ctx gls in + thus_tac c_term (EConstr.of_constr c_head) c_ctx gls in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) [tclTHENLIST [ assume_tac ctx; @@ -891,8 +893,9 @@ let build_per_info etype casee gls = let concl=pf_concl gls in let env=pf_env gls in let ctyp=pf_unsafe_type_of gls (EConstr.of_constr casee) in - let is_dep = dependent (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl) in + let is_dep = dependent (project gls) (EConstr.of_constr casee) concl in let hd,args = decompose_app (special_whd gls ctyp) in + let ctyp = EConstr.Unsafe.to_constr ctyp in let (ind,u) = try destInd hd @@ -906,9 +909,10 @@ let build_per_info etype casee gls = let params,real_args = List.chop nparams args in let abstract_obj c body = let typ=pf_unsafe_type_of gls (EConstr.of_constr c) in + let typ = EConstr.Unsafe.to_constr typ in lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in let pred= List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl))) in + real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) concl)) in is_dep, {per_casee=casee; per_ctype=ctyp; @@ -963,6 +967,7 @@ let register_nodep_subcase id= function let suppose_tac hyps gls0 = let info = get_its_info gls0 in let thesis = pf_concl gls0 in + let thesis = EConstr.Unsafe.to_constr thesis in let id = pf_get_new_id (Id.of_string "subcase_") gls0 in let clause = build_product (project gls0) hyps thesis in let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in @@ -1132,7 +1137,7 @@ let rec build_product_dep pat_info per_info args body gls = with Not_found -> snd (st_assoc (Name id) pat_info.pat_aliases) in thesis_for obj typ per_info (pf_env gls) - | Plain -> pf_concl gls in + | Plain -> EConstr.Unsafe.to_constr (pf_concl gls) in mkProd (st.st_label,ptyp,lbody) | [] -> body @@ -1225,6 +1230,7 @@ let pop_stacks stacks = let hrec_for fix_id per_info gls obj_id = let obj=mkVar obj_id in let typ=pf_get_hyp_typ gls obj_id in + let typ = EConstr.Unsafe.to_constr typ in let rc,hd1=decompose_prod typ in let cind,all_args=decompose_app typ in let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind); @@ -1269,14 +1275,16 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let env=pf_env gls in let ctyp=pf_unsafe_type_of gls (EConstr.of_constr casee) in let hd,all_args = decompose_app (special_whd gls ctyp) in + let ctyp = EConstr.Unsafe.to_constr ctyp in let ind', u = destInd hd in let _ = assert (eq_ind ind' ind) in (* just in case *) let params,real_args = List.chop nparams all_args in let abstract_obj c body = let typ=pf_unsafe_type_of gls (EConstr.of_constr c) in + let typ = EConstr.Unsafe.to_constr typ in lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in let elim_pred = List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) (EConstr.of_constr concl))) in + real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) concl)) in let case_info = Inductiveops.make_case_info env ind RegularStyle in let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = @@ -1341,13 +1349,13 @@ let understand_my_constr env sigma c concl = | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None) | rc -> map_glob_constr frob rc in - Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType (EConstr.of_constr concl)) (frob rawc) + Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc) let my_refine c gls = let oc = { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in - Sigma.Unsafe.of_pair (EConstr.of_constr c, sigma) + Sigma.Unsafe.of_pair (c, sigma) end } in Proofview.V82.of_tactic (Tactics.New.refine oc) gls diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index e39d17b52d..f23f4ce7df 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -37,6 +37,7 @@ let start_deriving f suchthat lemma = let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in let evdref = ref sigma in let suchthat = Constrintern.interp_type_evars env' evdref suchthat in + let suchthat = EConstr.Unsafe.to_constr suchthat in TCons ( env' , !evdref , suchthat , (fun sigma _ -> TNil sigma)))))) in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 24d4346d9a..2881b53339 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -107,7 +107,7 @@ let mk_open_instance id idc gl m t= let typ=pf_unsafe_type_of gl (EConstr.of_constr idc) in (* since we know we will get a product, reduction is not too expensive *) - let (nam,_,_)=destProd (EConstr.Unsafe.to_constr (whd_all env evmap (EConstr.of_constr typ))) in + let (nam,_,_)=destProd (EConstr.Unsafe.to_constr (whd_all env evmap typ)) in match nam with Name id -> id | Anonymous -> dummy_bvid in diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index bed7a727f7..38dae0b204 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -38,14 +38,14 @@ let wrap n b continue seq gls= []->anomaly (Pp.str "Not the expected number of hyps") | nd::q-> let id = NamedDecl.get_id nd in - if occur_var env (project gls) id (EConstr.of_constr (pf_concl gls)) || + if occur_var env (project gls) id (pf_concl gls) || List.exists (occur_var_in_decl env (project gls) id) ctx then (aux (i-1) q (nd::ctx)) else add_formula Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then - add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in + add_formula Concl dummy_id (EConstr.Unsafe.to_constr (pf_concl gls)) seq1 gls else seq1 in continue seq2 gls let basename_of_global=function diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 91cd102a23..fb0c22c2b7 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -201,6 +201,7 @@ let extend_with_ref_list l seq gl = let f gr (seq,gl) = let gl, c = pf_eapply Evd.fresh_global gl gr in let typ=(pf_unsafe_type_of gl (EConstr.of_constr c)) in + let typ = EConstr.Unsafe.to_constr typ in (add_formula Hyp gr typ seq gl,gl) in List.fold_right f l (seq,gl) @@ -216,6 +217,7 @@ let extend_with_auto_hints l seq gl= (try let (gr, _) = Termops.global_of_constr (project gl) c in let typ=(pf_unsafe_type_of gl c) in + let typ = EConstr.Unsafe.to_constr typ in seqref:=add_formula Hint gr typ !seqref gl with Not_found->()) | _-> () in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 656924e38c..f4fa61a22f 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -394,7 +394,7 @@ let rewrite_until_var arg_num eq_ids : tactic = *) let test_var g = let sigma = project g in - let _,args = destApp sigma (EConstr.of_constr (pf_concl g)) in + let _,args = destApp sigma (pf_concl g) in not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) in let rec do_rewrite eq_ids g = @@ -551,7 +551,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = tclIDTAC in try - scan_type [] (EConstr.of_constr (Typing.unsafe_type_of env sigma (mkVar hyp_id))), [hyp_id] + scan_type [] (Typing.unsafe_type_of env sigma (mkVar hyp_id)), [hyp_id] with TOREMOVE -> thin [hyp_id],[] @@ -602,7 +602,6 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = observe_tac "after_introduction" (fun g' -> (* We get infos on the equations introduced*) let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in - let new_term_value_eq = EConstr.of_constr new_term_value_eq in (* compute the new value of the body *) let new_term_value = match EConstr.kind (project g') new_term_value_eq with @@ -615,7 +614,7 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = in let fun_body = mkLambda(Anonymous, - EConstr.of_constr (pf_unsafe_type_of g' term), + pf_unsafe_type_of g' term, Termops.replace_term (project g') term (mkRel 1) dyn_infos.info ) in @@ -708,9 +707,8 @@ let build_proof let t = dyn_info'.info in let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in + let g_nb_prod = nb_prod (project g) (pf_concl g) in let type_of_term = pf_unsafe_type_of g t in - let type_of_term = EConstr.of_constr type_of_term in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in @@ -722,7 +720,7 @@ let build_proof (fun g -> observe_tac "toto" ( tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> - let g'_nb_prod = nb_prod (project g') (EConstr.of_constr (pf_concl g')) in + let g'_nb_prod = nb_prod (project g') (pf_concl g') in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case @@ -742,7 +740,7 @@ let build_proof build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin - match EConstr.kind sigma (EConstr.of_constr ( pf_concl g)) with + match EConstr.kind sigma (pf_concl g) with | Prod _ -> tclTHEN (Proofview.V82.of_tactic intro) @@ -914,7 +912,7 @@ let prove_rec_hyp_for_struct fix_info = (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) (fun g -> - let _,pte_args = destApp (project g) (EConstr.of_constr (pf_concl g)) in + let _,pte_args = destApp (project g) (pf_concl g) in let rec_hyp_proof = mkApp(mkVar fix_info.name,array_get_start pte_args) in @@ -938,7 +936,7 @@ let generalize_non_dep hyp g = let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep - || Termops.occur_var env (project g) hyp (EConstr.of_constr hyp_typ) + || Termops.occur_var env (project g) hyp hyp_typ || Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) @@ -1054,7 +1052,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in res in - let nb_intro_to_do = nb_prod (project g) (EConstr.of_constr (pf_concl g)) in + let nb_intro_to_do = nb_prod (project g) (pf_concl g) in tclTHEN (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) ( @@ -1070,7 +1068,6 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = fun g -> let princ_type = pf_concl g in - let princ_type = EConstr.of_constr princ_type in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) @@ -1258,7 +1255,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let intros_after_fixes : tactic = fun gl -> - let ctxt,pte_app = (decompose_prod_assum (project gl) (EConstr.of_constr (pf_concl gl))) in + let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in let pte,pte_args = (decompose_app (project gl) pte_app) in try let pte = @@ -1431,12 +1428,12 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (project gls) (EConstr.of_constr (pf_unsafe_type_of gls (mkVar hrec))) in + let _,hrec_concl = decompose_prod (project gls) (pf_unsafe_type_of gls (mkVar hrec)) in let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in let f = (fst (destApp (project gls) f_app)) in let rec backtrack : tactic = fun g -> - let f_app = Array.last (snd (destApp (project g) (EConstr.of_constr (pf_concl g)))) in + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in match EConstr.kind (project g) f_app with | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g @@ -1525,7 +1522,6 @@ let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in - let princ_type = EConstr.of_constr princ_type in let princ_info = compute_elim_sig (project gl) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps gl) in @@ -1664,7 +1660,7 @@ let prove_principle_for_gen Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> let body = - let _,args = destApp (project gl') (EConstr.of_constr (pf_concl gl')) in + let _,args = destApp (project gl') (pf_concl gl') in Array.last args in let body_info rec_hyps = diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d964002f9f..ba01b3b044 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -493,7 +493,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con in let _ = evd := sigma in let l_schemes = - List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma) schemes + List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes in let i = ref (-1) in let sorts = @@ -671,7 +671,7 @@ let build_case_scheme fa = Indrec.build_case_analysis_scheme_default env sigma ind sf in let sigma = Sigma.to_evar_map sigma in - let scheme_type = (Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme) in + let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index fc5a287ae0..fd2f4bbd37 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -504,6 +504,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr rt_as_constr) in + let rt_typ = EConstr.Unsafe.to_constr rt_typ in let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in @@ -612,6 +613,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in let v_type = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr v_as_constr) in + let v_type = EConstr.Unsafe.to_constr v_type in let new_env = match n with Anonymous -> env @@ -629,7 +631,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr b_as_constr) in let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) (EConstr.of_constr b_typ) + try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ @@ -661,7 +663,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in let b_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr b_as_constr) in let (ind,_) = - try Inductiveops.find_inductive env (Evd.from_env env) (EConstr.of_constr b_typ) + try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> user_err (str "Cannot find the inductive associated to " ++ Printer.pr_glob_constr b ++ str " in " ++ @@ -706,7 +708,7 @@ and build_entry_lc_from_case env funname make_discr let types = List.map (fun (case_arg,_) -> let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr case_arg_as_constr) + EConstr.Unsafe.to_constr (Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr case_arg_as_constr)) ) el in (****** The next works only if the match is not dependent ****) @@ -755,6 +757,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let typ_of_id = Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in + let typ_of_id = EConstr.Unsafe.to_constr typ_of_id in let raw_typ_of_id = Detyping.detype false [] env_with_pat_ids (Evd.from_env env) typ_of_id @@ -808,6 +811,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve if Id.Set.mem id this_pat_ids then (Prod (Name id), let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in + let typ_of_id = EConstr.Unsafe.to_constr typ_of_id in let raw_typ_of_id = Detyping.detype false [] new_env (Evd.from_env env) typ_of_id in @@ -1122,6 +1126,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in let type_t' = Typing.unsafe_type_of env evd (EConstr.of_constr t') in + let type_t' = EConstr.Unsafe.to_constr type_t' in let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index e22fed391e..1cde4420e5 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -78,11 +78,11 @@ let functional_induction with_clean c princl pat = ++Printer.pr_leconstr (mkConst c') ) in let princ = EConstr.of_constr princ in - (princ,NoBindings,EConstr.of_constr (Tacmach.pf_unsafe_type_of g' princ),g') + (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> - princ,binding,EConstr.of_constr (Tacmach.pf_unsafe_type_of g princ),g + princ,binding,Tacmach.pf_unsafe_type_of g princ,g in let sigma = Tacmach.project g' in let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index be82010d9d..5cbec77437 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -263,7 +263,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes let princ_type = nf_zeta princ_type in let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) - let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in + let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the functional principle is defined in the @@ -315,7 +315,6 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.fold_right (fun hid acc -> let type_of_hid = pf_unsafe_type_of g (mkVar hid) in - let type_of_hid = EConstr.of_constr type_of_hid in let sigma = project g in match EConstr.kind sigma type_of_hid with | Prod(_,_,t') -> @@ -503,7 +502,7 @@ and intros_with_rewrite_aux : tactic = fun g -> let eq_ind = make_eq () in let sigma = project g in - match EConstr.kind sigma (EConstr.of_constr (pf_concl g)) with + match EConstr.kind sigma (pf_concl g) with | Prod(_,t,t') -> begin match EConstr.kind sigma t with @@ -591,7 +590,7 @@ and intros_with_rewrite_aux : tactic = let rec reflexivity_with_destruct_cases g = let destruct_case () = try - match EConstr.kind (project g) (snd (destApp (project g) (EConstr.of_constr (pf_concl g)))).(2) with + match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ Proofview.V82.of_tactic (simplest_case v); @@ -608,7 +607,7 @@ let rec reflexivity_with_destruct_cases g = match sc with None -> tclIDTAC g | Some id -> - match EConstr.kind (project g) (EConstr.of_constr (pf_unsafe_type_of g (mkVar id))) with + match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g @@ -674,12 +673,11 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let f = funcs.(i) in let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g graph_principle in - let princ_type = EConstr.of_constr princ_type in let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them *) - let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in + let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) @@ -937,7 +935,6 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let revert_graph kn post_tac hid g = let sigma = project g in let typ = pf_unsafe_type_of g (mkVar hid) in - let typ = EConstr.of_constr typ in match EConstr.kind sigma typ with | App(i,args) when isInd sigma i -> let ((kn',num) as ind'),u = destInd sigma i in @@ -990,7 +987,6 @@ let functional_inversion kn hid fconst f_correct : tactic = let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let sigma = project g in let type_of_h = pf_unsafe_type_of g (mkVar hid) in - let type_of_h = EConstr.of_constr type_of_h in match EConstr.kind sigma type_of_h with | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> let pre_tac,f_args,res = @@ -1044,7 +1040,6 @@ let invfun qhyp f g = (fun hid -> Proofview.V82.tactic begin fun g -> let sigma = project g in let hyp_typ = pf_unsafe_type_of g (mkVar hid) in - let hyp_typ = EConstr.of_constr hyp_typ in match EConstr.kind sigma hyp_typ with | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> begin diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index a80a7b5e7c..adbdb1eb7b 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -123,7 +123,7 @@ let pf_get_new_ids idl g = let compute_renamed_type gls c = EConstr.of_constr (rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] - (pf_unsafe_type_of gls c)) + (EConstr.Unsafe.to_constr (pf_unsafe_type_of gls c))) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" @@ -412,7 +412,6 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = h_intros to_intros; (fun g' -> let ty_teq = pf_unsafe_type_of g' (mkVar heq) in - let ty_teq = EConstr.of_constr ty_teq in let teq_lhs,teq_rhs = let _,args = try destApp (project g') ty_teq with DestKO -> assert false in args.(1),args.(2) @@ -522,19 +521,19 @@ let rec prove_lt hyple g = let sigma = project g in begin try - let (varx,varz) = match decompose_app sigma (EConstr.of_constr (pf_concl g)) with + let (varx,varz) = match decompose_app sigma (pf_concl g) with | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z | _ -> assert false in let h = List.find (fun id -> - match decompose_app sigma (EConstr.of_constr (pf_unsafe_type_of g (mkVar id))) with + match decompose_app sigma (pf_unsafe_type_of g (mkVar id)) with | _, t::_ -> EConstr.eq_constr sigma t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app sigma (EConstr.of_constr (pf_unsafe_type_of g (mkVar h)))))) in + List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) @@ -698,7 +697,6 @@ let mkDestructEq : then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in - let type_of_expr = EConstr.of_constr type_of_expr in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in pf_typel new_hyps (fun _ -> @@ -707,7 +705,7 @@ let mkDestructEq : (fun g2 -> let changefun patvars = { run = fun sigma -> let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in - let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) in + let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) in Sigma (c, sigma, p) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); @@ -846,7 +844,7 @@ let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = let rec prove_le g = let sigma = project g in let x,z = - let _,args = decompose_app sigma (EConstr.of_constr (pf_concl g)) in + let _,args = decompose_app sigma (pf_concl g) in (List.hd args,List.hd (List.tl args)) in tclFIRST[ @@ -857,9 +855,8 @@ let rec prove_le g = let matching_fun = pf_is_matching g (Pattern.PApp(Pattern.PRef (reference_of_constr (EConstr.Unsafe.to_constr (le ()))),[|Pattern.PVar (destVar sigma x);Pattern.PMeta None|])) in - let (h,t) = List.find (fun (_,t) -> matching_fun (EConstr.of_constr t)) (pf_hyps_types g) + let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in - let t = EConstr.of_constr t in let y = let _,args = decompose_app sigma t in List.hd (List.tl args) @@ -1350,7 +1347,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ] gls) (fun g -> let sigma = project g in - match EConstr.kind sigma (EConstr.of_constr (pf_concl g)) with + match EConstr.kind sigma (pf_concl g) with | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> @@ -1523,9 +1520,11 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num let env = Global.env() in let evd = ref (Evd.from_env env) in let function_type = interp_type_evars env evd type_of_f in + let function_type = EConstr.Unsafe.to_constr function_type in let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let ty = interp_type_evars env evd ~impls:rec_impls eq in + let ty = EConstr.Unsafe.to_constr ty in let evm, nf = Evarutil.nf_evars_and_universes !evd in let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in let function_type = nf function_type in diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index ced5724669..a2346cc904 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1606,6 +1606,7 @@ let rec parse_hyps gl parse_arith env tg hyps = match hyps with | [] -> ([],env,tg) | (i,t)::l -> + let t = EConstr.Unsafe.to_constr t in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in try let (c,env,tg) = parse_formula gl parse_arith env tg t in @@ -1713,7 +1714,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* ("__varmap", vm, Term.mkApp( coq_VarMap, [|spec.typ|])); ("__wit", cert, cert_typ) ] - (Tacmach.pf_concl gl)) + (EConstr.Unsafe.to_constr (Tacmach.pf_concl gl))) ] end } @@ -1964,6 +1965,7 @@ let micromega_gen Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in let concl = Tacmach.pf_concl gl in + let concl = EConstr.Unsafe.to_constr concl in let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in @@ -2051,7 +2053,7 @@ let micromega_order_changer cert env ff = [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); ("__wit", cert, cert_typ) ] - (Tacmach.pf_concl gl))); + (EConstr.Unsafe.to_constr (Tacmach.pf_concl gl)))); (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] end } @@ -2072,6 +2074,7 @@ let micromega_genr prover tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in let concl = Tacmach.pf_concl gl in + let concl = EConstr.Unsafe.to_constr concl in let hyps = Tacmach.pf_hyps_types gl in try diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 51790f4c90..6654862722 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -38,9 +38,9 @@ open OmegaSolver let elim_id id = Proofview.Goal.nf_enter { enter = begin fun gl -> - simplest_elim (EConstr.of_constr (Tacmach.New.pf_global id gl)) + simplest_elim (Tacmach.New.pf_global id gl) end } -let resolve_id id gl = Proofview.V82.of_tactic (apply (EConstr.of_constr (pf_global gl id))) gl +let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl let timing timer_name f arg = f arg @@ -568,7 +568,7 @@ let abstract_path typ path t = mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = - let newc = context (fun i t -> EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr t))) (List.rev path) (pf_concl gl) in + let newc = context (fun i t -> EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr t))) (List.rev path) (EConstr.Unsafe.to_constr (pf_concl gl)) in let newc = EConstr.of_constr newc in Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl @@ -632,6 +632,7 @@ let mkNewMeta () = mkMeta (Evarutil.new_meta()) let clever_rewrite_base_poly typ p result theorem gl = let full = pf_concl gl in + let full = EConstr.Unsafe.to_constr full in let (abstracted,occ) = abstract_path typ (List.rev p) full in let t = applist @@ -663,6 +664,7 @@ let clever_rewrite_gen_nat p result (t,args) = let clever_rewrite p vpath t gl = let full = pf_concl gl in + let full = EConstr.Unsafe.to_constr full in let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in let vargs = List.map (fun p -> occurrence p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in @@ -1424,6 +1426,7 @@ let coq_omega = Proofview.Goal.nf_enter { enter = begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in + let hyps_types = List.map (on_snd EConstr.Unsafe.to_constr) hyps_types in let destructure_omega = Tacmach.New.of_old destructure_omega gl in let tactic_normalisation, system = List.fold_left destructure_omega ([],[]) hyps_types in @@ -1607,6 +1610,7 @@ let nat_inject = with e when catchable_exception e -> loop lit end in let hyps_types = Tacmach.New.pf_hyps_types gl in + let hyps_types = List.map (on_snd EConstr.Unsafe.to_constr) hyps_types in loop (List.rev hyps_types) end } @@ -1722,7 +1726,7 @@ let destructure_hyps = | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if is_Prop (type_of (EConstr.of_constr t2)) + if is_Prop (EConstr.Unsafe.to_constr (type_of (EConstr.of_constr t2))) then let d1 = decidability t1 in Tacticals.New.tclTHENLIST [ diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 87276f5df4..edf34607bb 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -459,8 +459,7 @@ let quote f lid = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let f = Tacmach.New.pf_global f gl in - let f = EConstr.of_constr f in - let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in let ivs = compute_ivs f cl gl in let concl = Proofview.Goal.concl gl in let quoted_terms = quote_terms env sigma ivs [concl] in @@ -478,8 +477,7 @@ let gen_quote cont c f lid = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let f = Tacmach.New.pf_global f gl in - let f = EConstr.of_constr f in - let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in let ivs = compute_ivs f cl gl in let quoted_terms = quote_terms env sigma ivs [c] in let (p, vm) = match quoted_terms with diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index ab5033601a..cfe14b230c 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -740,6 +740,7 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = let reify_gl env gl = let concl = Tacmach.pf_concl gl in + let concl = EConstr.Unsafe.to_constr concl in let t_concl = Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in if !debug then begin @@ -748,6 +749,7 @@ let reify_gl env gl = end; let rec loop = function (i,t) :: lhyps -> + let t = EConstr.Unsafe.to_constr t in let t' = oproposition_of_constr env (false,[],i,[]) gl t in if !debug then begin Printf.printf " %s: " (Names.Id.to_string i); diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 981ce2a61f..4753805120 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -262,8 +262,9 @@ let rtauto_tac gls= let gl=pf_concl gls in let _= if Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) (EConstr.of_constr gl) != InProp + (pf_env gls) (Tacmach.project gls) gl != InProp then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in + let gl = EConstr.Unsafe.to_constr gl in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 358ea56852..f525570955 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -142,7 +142,7 @@ let ic c = let env = Global.env() in let sigma = Evd.from_env env in let sigma, c = Constrintern.interp_open_constr env sigma c in - (sigma, EConstr.of_constr c) + (sigma, c) let ic_unsafe c = (*FIXME remove *) let env = Global.env() in @@ -505,8 +505,6 @@ let ring_equality env evd (r,add,mul,opp,req) = | None -> plapp evd coq_eq_smorph [|r;add;mul|] in let setoid = Typing.e_solve_evars env evd setoid in let op_morph = Typing.e_solve_evars env evd op_morph in - let setoid = EConstr.of_constr setoid in - let op_morph = EConstr.of_constr op_morph in (setoid,op_morph) | _ -> let setoid = setoid_of_relation (Global.env ()) evd r req in @@ -594,6 +592,7 @@ let make_hyp_list env evd lH = (plapp evd coq_nil [|carrier|]) in let l' = Typing.e_solve_evars env evd l in + let l' = EConstr.Unsafe.to_constr l' in Evarutil.nf_evars_universes !evd l' let interp_power env evd pow = @@ -756,7 +755,7 @@ let ring_lookup (f : Value.t) lH rl t = let rl = make_args_list sigma rl t in let evdref = ref sigma in let e = find_ring_structure env sigma rl in - let rl = carg (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let ring = ltac_ring_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) @@ -1039,7 +1038,7 @@ let field_lookup (f : Value.t) lH rl t = let rl = make_args_list sigma rl t in let evdref = ref sigma in let e = find_field_structure env sigma rl in - let rl = carg (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let field = ltac_field_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index 9dcc6c4cc0..eb5f401e37 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1353,6 +1353,7 @@ let fill_occ_term env cl occ sigma0 (sigma, t) = let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in + let concl = EConstr.Unsafe.to_constr concl in let cl,(_,t) = fill_occ_term env concl occ sigma0 t in cl, t @@ -1388,6 +1389,7 @@ let ssrpatterntac _ist (arg_ist,arg) gl = let pat = interp_rpattern arg_ist gl arg in let sigma0 = project gl in let concl0 = pf_concl gl in + let concl0 = EConstr.Unsafe.to_constr concl0 in let (t, uc), concl_x = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in let t = EConstr.of_constr t in @@ -1416,6 +1418,7 @@ let ssrinstancesof ist arg gl = let ok rhs lhs ise = true in (* not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *) let env, sigma, concl = pf_env gl, project gl, pf_concl gl in + let concl = EConstr.Unsafe.to_constr concl in let sigma0, cpat = interp_cpattern ist gl arg None in let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in -- cgit v1.2.3 From 0c56c953670d69f40e9554e35bdb206c2fb80911 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Nov 2016 22:40:26 +0100 Subject: Micromega API using EConstr. --- plugins/micromega/coq_micromega.ml | 272 ++++++++++++++++++++----------------- 1 file changed, 144 insertions(+), 128 deletions(-) (limited to 'plugins') diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a2346cc904..82218a35c8 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -20,6 +20,8 @@ open Pp open Mutils open Goptions +module Term = EConstr + (** * Debug flag *) @@ -330,6 +332,8 @@ struct open Coqlib open Term + open Constr + open EConstr (** * Location of the Coq libraries. @@ -373,6 +377,7 @@ struct * ZMicromega.v *) + let gen_constant_in_modules s m n = EConstr.of_constr (gen_constant_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module @@ -599,12 +604,12 @@ struct (* A simple but useful getter function *) - let get_left_construct term = - match Term.kind_of_term term with - | Term.Construct((_,i),_) -> (i,[| |]) - | Term.App(l,rst) -> - (match Term.kind_of_term l with - | Term.Construct((_,i),_) -> (i,rst) + let get_left_construct sigma term = + match EConstr.kind sigma term with + | Constr.Construct((_,i),_) -> (i,[| |]) + | Constr.App(l,rst) -> + (match EConstr.kind sigma l with + | Constr.Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -613,11 +618,11 @@ struct (* parse/dump/print from numbers up to expressions and formulas *) - let rec parse_nat term = - let (i,c) = get_left_construct term in + let rec parse_nat sigma term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> Mc.O - | 2 -> Mc.S (parse_nat (c.(0))) + | 2 -> Mc.S (parse_nat sigma (c.(0))) | i -> raise ParseError let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) @@ -627,11 +632,11 @@ struct | Mc.O -> Lazy.force coq_O | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) - let rec parse_positive term = - let (i,c) = get_left_construct term in + let rec parse_positive sigma term = + let (i,c) = get_left_construct sigma term in match i with - | 1 -> Mc.XI (parse_positive c.(0)) - | 2 -> Mc.XO (parse_positive c.(0)) + | 1 -> Mc.XI (parse_positive sigma c.(0)) + | 2 -> Mc.XO (parse_positive sigma c.(0)) | 3 -> Mc.XH | i -> raise ParseError @@ -661,12 +666,12 @@ struct let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) - let parse_z term = - let (i,c) = get_left_construct term in + let parse_z sigma term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive c.(0)) - | 3 -> Mc.Zneg (parse_positive c.(0)) + | 2 -> Mc.Zpos (parse_positive sigma c.(0)) + | 3 -> Mc.Zneg (parse_positive sigma c.(0)) | i -> raise ParseError let dump_z x = @@ -686,10 +691,10 @@ struct Term.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) - let parse_q term = - match Term.kind_of_term term with - | Term.App(c, args) -> if Constr.equal c (Lazy.force coq_Qmake) then - {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } + let parse_q sigma term = + match EConstr.kind sigma term with + | Constr.App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then + {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } else raise ParseError | _ -> raise ParseError @@ -719,27 +724,27 @@ struct | Mc.CInv t -> Term.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> Term.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - let rec parse_Rcst term = - let (i,c) = get_left_construct term in + let rec parse_Rcst sigma term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> Mc.C0 | 2 -> Mc.C1 - | 3 -> Mc.CQ (parse_q c.(0)) - | 4 -> Mc.CPlus(parse_Rcst c.(0), parse_Rcst c.(1)) - | 5 -> Mc.CMinus(parse_Rcst c.(0), parse_Rcst c.(1)) - | 6 -> Mc.CMult(parse_Rcst c.(0), parse_Rcst c.(1)) - | 7 -> Mc.CInv(parse_Rcst c.(0)) - | 8 -> Mc.COpp(parse_Rcst c.(0)) + | 3 -> Mc.CQ (parse_q sigma c.(0)) + | 4 -> Mc.CPlus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) + | 5 -> Mc.CMinus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) + | 6 -> Mc.CMult(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) + | 7 -> Mc.CInv(parse_Rcst sigma c.(0)) + | 8 -> Mc.COpp(parse_Rcst sigma c.(0)) | _ -> raise ParseError - let rec parse_list parse_elt term = - let (i,c) = get_left_construct term in + let rec parse_list sigma parse_elt term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> [] - | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2) + | 2 -> parse_elt sigma c.(1) :: parse_list sigma parse_elt c.(2) | i -> raise ParseError let rec dump_list typ dump_elt l = @@ -872,9 +877,9 @@ struct dump_op o ; dump_expr typ dump_constant e2|]) - let assoc_const x l = + let assoc_const sigma x l = try - snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) + snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) with Not_found -> raise ParseError @@ -898,35 +903,37 @@ struct let has_typ gl t1 typ = let ty = Retyping.get_type_of (Tacmach.pf_env gl) (Tacmach.project gl) t1 in - EConstr.eq_constr (Tacmach.project gl) ty (EConstr.of_constr typ) + EConstr.eq_constr (Tacmach.project gl) ty typ let is_convertible gl t1 t2 = - Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) (EConstr.of_constr t1) (EConstr.of_constr t2) + Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2 let parse_zop gl (op,args) = - match kind_of_term op with - | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1)) + let sigma = Tacmach.project gl in + match EConstr.kind sigma op with + | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) | Ind((n,0),_) -> - if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_rop gl (op,args) = - match kind_of_term op with - | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1)) + let sigma = Tacmach.project gl in + match EConstr.kind sigma op with + | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) | Ind((n,0),_) -> - if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_qop gl (op,args) = - (assoc_const op qop_table, args.(0) , args.(1)) + (assoc_const (Tacmach.project gl) op qop_table, args.(0) , args.(1)) - let is_constant t = (* This is an approx *) - match kind_of_term t with + let is_constant sigma t = (* This is an approx *) + match EConstr.kind sigma t with | Construct(i,_) -> true | _ -> false @@ -936,9 +943,9 @@ struct | Power | Ukn of string - let assoc_ops x l = + let assoc_ops sigma x l = try - snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) + snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) with Not_found -> Ukn "Oups" @@ -950,12 +957,12 @@ struct struct type t = constr list - let compute_rank_add env v = + let compute_rank_add env sigma v = let rec _add env n v = match env with | [] -> ([v],n) | e::l -> - if eq_constr e v + if eq_constr sigma e v then (env,n) else let (env,n) = _add l ( n+1) v in @@ -963,13 +970,13 @@ struct let (env, n) = _add env 1 v in (env, CamlToCoq.positive n) - let get_rank env v = + let get_rank env sigma v = let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> - if eq_constr e v + if eq_constr sigma e v then n else _get_rank l (n+1) in _get_rank env 1 @@ -985,9 +992,9 @@ struct * This is the big generic function for expression parsers. *) - let parse_expr parse_constant parse_exp ops_spec env term = + let parse_expr sigma parse_constant parse_exp ops_spec env term = if debug - then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); + then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr term); (* let constant_or_variable env term = @@ -998,7 +1005,7 @@ struct (Mc.PEX n , env) in *) let parse_variable env term = - let (env,n) = Env.compute_rank_add env term in + let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n , env) in let rec parse_expr env term = @@ -1009,12 +1016,12 @@ struct try (Mc.PEc (parse_constant term) , env) with ParseError -> - match kind_of_term term with + match EConstr.kind sigma term with | App(t,args) -> ( - match kind_of_term t with + match EConstr.kind sigma t with | Const c -> - ( match assoc_ops t ops_spec with + ( match assoc_ops sigma t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in (Mc.PEopp expr, env) @@ -1026,12 +1033,12 @@ struct (power , env) with e when CErrors.noncritical e -> (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) end | Ukn s -> if debug then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) ) | _ -> parse_variable env term ) @@ -1074,60 +1081,60 @@ struct (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] - let rec rconstant term = - match Term.kind_of_term term with + let rec rconstant sigma term = + match EConstr.kind sigma term with | Const x -> - if Constr.equal term (Lazy.force coq_R0) + if EConstr.eq_constr sigma term (Lazy.force coq_R0) then Mc.C0 - else if Constr.equal term (Lazy.force coq_R1) + else if EConstr.eq_constr sigma term (Lazy.force coq_R1) then Mc.C1 else raise ParseError | App(op,args) -> begin try (* the evaluation order is important in the following *) - let f = assoc_const op rconst_assoc in - let a = rconstant args.(0) in - let b = rconstant args.(1) in + let f = assoc_const sigma op rconst_assoc in + let a = rconstant sigma args.(0) in + let b = rconstant sigma args.(1) in f a b with ParseError -> match op with - | op when Constr.equal op (Lazy.force coq_Rinv) -> - let arg = rconstant args.(0) in + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> + let arg = rconstant sigma args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) - | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0)) - | op when Constr.equal op (Lazy.force coq_IZR) -> Mc.CZ (parse_z args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) | _ -> raise ParseError end | _ -> raise ParseError - let rconstant term = + let rconstant sigma term = if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); - let res = rconstant term in + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr term ++ fnl ()); + let res = rconstant sigma term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res - let parse_zexpr = parse_expr - zconstant + let parse_zexpr sigma = parse_expr sigma + (zconstant sigma) (fun expr x -> - let exp = (parse_z x) in + let exp = (parse_z sigma x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec - let parse_qexpr = parse_expr - qconstant + let parse_qexpr sigma = parse_expr sigma + (qconstant sigma) (fun expr x -> - let exp = parse_z x in + let exp = parse_z sigma x in match exp with | Mc.Zneg _ -> begin @@ -1139,21 +1146,22 @@ struct Mc.PEpow(expr,exp)) qop_spec - let parse_rexpr = parse_expr - rconstant + let parse_rexpr sigma = parse_expr sigma + (rconstant sigma) (fun expr x -> - let exp = Mc.N.of_nat (parse_nat x) in + let exp = Mc.N.of_nat (parse_nat sigma x) in Mc.PEpow(expr,exp)) rop_spec let parse_arith parse_op parse_expr env cstr gl = + let sigma = Tacmach.project gl in if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); - match kind_of_term cstr with + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr cstr ++ fnl ()); + match EConstr.kind sigma cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr env lhs in - let (e2,env) = parse_expr env rhs in + let (e1,env) = parse_expr sigma env lhs in + let (e2,env) = parse_expr sigma env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" @@ -1191,6 +1199,7 @@ struct *) let parse_formula gl parse_atom env tg term = + let sigma = Tacmach.project gl in let parse_atom env tg t = try @@ -1199,34 +1208,34 @@ struct with e when CErrors.noncritical e -> (X(t),env,tg) in let is_prop term = - let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) (EConstr.of_constr term) in - Term.is_prop_sort sort in + let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) term in + Sorts.is_prop sort in let rec xparse_formula env tg term = - match kind_of_term term with + match EConstr.kind sigma term with | App(l,rst) -> (match rst with - | [|a;b|] when eq_constr l (Lazy.force coq_and) -> + | [|a;b|] when eq_constr sigma l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in let g,env, tg = xparse_formula env tg b in mkformula_binary mkC term f g,env,tg - | [|a;b|] when eq_constr l (Lazy.force coq_or) -> + | [|a;b|] when eq_constr sigma l (Lazy.force coq_or) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg - | [|a|] when eq_constr l (Lazy.force coq_not) -> + | [|a|] when eq_constr sigma l (Lazy.force coq_not) -> let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> + | [|a;b|] when eq_constr sigma l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Prod(typ,a,b) when EConstr.Vars.noccurn Evd.empty 1 (EConstr.of_constr b) (** FIXME *) -> + | Prod(typ,a,b) when Vars.noccurn sigma 1 b -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg) - | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg) + | _ when eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) + | _ when eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) | _ when is_prop term -> X(term),env,tg | _ -> raise ParseError in @@ -1246,10 +1255,10 @@ struct xdump f - let prop_env_of_formula form = + let prop_env_of_formula sigma form = let rec doit env = function | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env t) + | X t -> fst (Env.compute_rank_add env sigma t) | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> doit (doit env f1) f2 | N f -> doit env f in @@ -1380,14 +1389,22 @@ let dump_rexpr = lazy *) -let rec make_goal_of_formula dexpr form = +let prodn n env b = + let rec prodrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | _ -> assert false + in + prodrec (n,env,b) + +let make_goal_of_formula sigma dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - let props = prop_env_of_formula form in + let props = prop_env_of_formula sigma form in let vars_n = List.map (fun (_,i) -> (Names.id_of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in let props_n = List.mapi (fun i _ -> (Names.id_of_string (Printf.sprintf "__p%i" (i+1))) , Term.mkProp) props in @@ -1428,7 +1445,7 @@ let rec make_goal_of_formula dexpr form = | I(x,_,y) -> mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) | N(x) -> mkArrow (xdump pi xi x) (Lazy.force coq_False) | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props t in + | X(t) -> let idx = Env.get_rank props sigma t in mkRel (pi+idx) in let nb_vars = List.length vars_n in @@ -1437,13 +1454,13 @@ let rec make_goal_of_formula dexpr form = (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) let subst_prop p = - let idx = Env.get_rank props p in + let idx = Env.get_rank props sigma p in mkVar (Names.id_of_string (Printf.sprintf "__p%i" idx)) in let form' = map_prop subst_prop form in - (Term.prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n) - (Term.prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n) + (prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n) + (prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n) (xdump (List.length vars_n) 0 form)), List.rev props_n, List.rev var_name_pos,form') @@ -1461,7 +1478,7 @@ let rec make_goal_of_formula dexpr form = xset (Term.mkNamedLetIn (Names.Id.of_string name) expr typ acc) l in - EConstr.of_constr (xset concl l) + xset concl l end (** * MODULE END: M @@ -1518,17 +1535,17 @@ let rec apply_ids t ids = | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids let coq_Node = - (Coqlib.gen_constant_in_modules "VarMap" + EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") let coq_Leaf = - (Coqlib.gen_constant_in_modules "VarMap" + EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") let coq_Empty = - (Coqlib.gen_constant_in_modules "VarMap" + EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") let coq_VarMap = - (Coqlib.gen_constant_in_modules "VarMap" + EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") @@ -1606,7 +1623,6 @@ let rec parse_hyps gl parse_arith env tg hyps = match hyps with | [] -> ([],env,tg) | (i,t)::l -> - let t = EConstr.Unsafe.to_constr t in let (lhyps,env,tg) = parse_hyps gl parse_arith env tg l in try let (c,env,tg) = parse_formula gl parse_arith env tg t in @@ -1714,7 +1730,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* ("__varmap", vm, Term.mkApp( coq_VarMap, [|spec.typ|])); ("__wit", cert, cert_typ) ] - (EConstr.Unsafe.to_constr (Tacmach.pf_concl gl))) + (Tacmach.pf_concl gl)) ] end } @@ -1905,7 +1921,7 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.prterm ff); + Feedback.msg_notice (Printer.pr_leconstr ff); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; @@ -1930,7 +1946,7 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff' = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.prterm ff'); + Feedback.msg_notice (Printer.pr_leconstr ff'); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; @@ -1964,8 +1980,8 @@ let micromega_gen spec dumpexpr prover tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in + let sigma = Tacmach.project gl in let concl = Tacmach.pf_concl gl in - let concl = EConstr.Unsafe.to_constr concl in let hyps = Tacmach.pf_hyps_types gl in try let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in @@ -1976,7 +1992,7 @@ let micromega_gen match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula dumpexpr ff' in + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -1989,7 +2005,7 @@ let micromega_gen micromega_order_change spec res' (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula ff') in + let goal_props = List.rev (prop_env_of_formula sigma ff') in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -2002,12 +2018,12 @@ let micromega_gen (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) (EConstr.of_constr arith_goal)) + (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.of_constr (Term.applist (Term.mkVar goal_name, arith_args))) + [(Tactics.generalize (List.map Term.mkVar ids)); + Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) ] ) ] with @@ -2049,11 +2065,11 @@ let micromega_order_changer cert env ff = [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, Term.mkApp - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); + (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t"), [|typ|])); ("__wit", cert, cert_typ) ] - (EConstr.Unsafe.to_constr (Tacmach.pf_concl gl)))); + (Tacmach.pf_concl gl))); (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] end } @@ -2073,8 +2089,8 @@ let micromega_genr prover tac = } in Proofview.Goal.nf_enter { enter = begin fun gl -> let gl = Tacmach.New.of_old (fun x -> x) gl in + let sigma = Tacmach.project gl in let concl = Tacmach.pf_concl gl in - let concl = EConstr.Unsafe.to_constr concl in let hyps = Tacmach.pf_hyps_types gl in try @@ -2092,7 +2108,7 @@ let micromega_genr prover tac = (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in let ff' = abstract_wrt_formula ff' ff in - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula (Lazy.force dump_rexpr) ff' in + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in @@ -2104,7 +2120,7 @@ let micromega_genr prover tac = let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula ff') in + let goal_props = List.rev (prop_env_of_formula sigma ff') in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -2117,12 +2133,12 @@ let micromega_genr prover tac = (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) (EConstr.of_constr arith_goal)) + (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map EConstr.mkVar ids)); - Tactics.exact_check (EConstr.of_constr (Term.applist (Term.mkVar goal_name, arith_args))) + [(Tactics.generalize (List.map Term.mkVar ids)); + Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) ] ) ] -- cgit v1.2.3 From e1010899051546467b790bca0409174bde824270 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 00:36:34 +0100 Subject: Omega API using EConstr. --- plugins/omega/coq_omega.ml | 252 ++++++++++++++++++++++++--------------------- 1 file changed, 136 insertions(+), 116 deletions(-) (limited to 'plugins') diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 6654862722..9e0d591b69 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -18,6 +18,7 @@ open Util open Names open Nameops open Term +open EConstr open Tacticals open Tacmach open Tactics @@ -149,7 +150,7 @@ let mk_then = tclTHENLIST let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c]) -let generalize_tac t = generalize (List.map EConstr.of_constr t) +let generalize_tac t = generalize t let elim t = simplest_elim t let exact t = Tacmach.refine t let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] @@ -172,8 +173,8 @@ let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags = let hide_constr,find_constr,clear_constr_tables,dump_tables = let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), - (fun h -> - try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"), + (fun sigma h -> + try List.assoc_f (eq_constr_nounivs sigma) h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) @@ -197,6 +198,7 @@ let coq_modules = init_modules @arith_modules @ [logic_dir] @ zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] +let gen_constant_in_modules n m s = EConstr.of_constr (gen_constant_in_modules n m s) let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules @@ -348,11 +350,18 @@ let coq_not_iff = lazy (constant "not_iff") let coq_not_not = lazy (constant "not_not") let coq_imp_simp = lazy (constant "imp_simp") let coq_iff = lazy (constant "iff") +let coq_not = lazy (init_constant "not") +let coq_and = lazy (init_constant "and") +let coq_or = lazy (init_constant "or") +let coq_eq = lazy (init_constant "eq") +let coq_ex = lazy (init_constant "ex") +let coq_False = lazy (init_constant "False") +let coq_True = lazy (init_constant "True") (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) (* For unfold *) -let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with +let evaluable_ref_of_constr s c = match EConstr.kind Evd.empty (Lazy.force c) with | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant")) @@ -364,21 +373,21 @@ let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt) -let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) +let sp_not = lazy (evaluable_ref_of_constr "not" coq_not) let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) -let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), +let mk_eq t1 t2 = mkApp (Lazy.force coq_eq, [| Lazy.force coq_Z; t1; t2 |]) let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) -let mk_gt t1 t2 = EConstr.of_constr (mkApp (Lazy.force coq_Zgt, [| t1; t2 |])) +let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) -let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) -let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) -let mk_not t = mkApp (build_coq_not (), [| t |]) -let mk_eq_rel t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), +let mk_and t1 t2 = mkApp (Lazy.force coq_and, [| t1; t2 |]) +let mk_or t1 t2 = mkApp (Lazy.force coq_or, [| t1; t2 |]) +let mk_not t = mkApp (Lazy.force coq_not, [| t |]) +let mk_eq_rel t1 t2 = mkApp (Lazy.force coq_eq, [| Lazy.force coq_comparison; t1; t2 |]) let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) @@ -420,22 +429,23 @@ type result = the term parts that we manipulate, but rather Var's. Said otherwise: all constr manipulated here are closed *) -let destructurate_prop t = - let c, args = decompose_app t in - match kind_of_term c, args with - | _, [_;_;_] when is_global (build_coq_eq ()) c -> Kapp (Eq,args) +let destructurate_prop sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in + let c, args = decompose_app sigma t in + match EConstr.kind sigma c, args with + | _, [_;_;_] when eq_constr (Lazy.force coq_eq) c -> Kapp (Eq,args) | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args) - | _, [_;_] when eq_constr c (build_coq_and ()) -> Kapp (And,args) - | _, [_;_] when eq_constr c (build_coq_or ()) -> Kapp (Or,args) + | _, [_;_] when eq_constr c (Lazy.force coq_and) -> Kapp (And,args) + | _, [_;_] when eq_constr c (Lazy.force coq_or) -> Kapp (Or,args) | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args) - | _, [_] when eq_constr c (build_coq_not ()) -> Kapp (Not,args) - | _, [] when eq_constr c (build_coq_False ()) -> Kapp (False,args) - | _, [] when eq_constr c (build_coq_True ()) -> Kapp (True,args) + | _, [_] when eq_constr c (Lazy.force coq_not) -> Kapp (Not,args) + | _, [] when eq_constr c (Lazy.force coq_False) -> Kapp (False,args) + | _, [] when eq_constr c (Lazy.force coq_True) -> Kapp (True,args) | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args) | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) @@ -451,16 +461,18 @@ let destructurate_prop t = | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" | _ -> Kufo -let destructurate_type t = - let c, args = decompose_app t in - match kind_of_term c, args with +let destructurate_type sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in + let c, args = decompose_app sigma t in + match EConstr.kind sigma c, args with | _, [] when eq_constr c (Lazy.force coq_Z) -> Kapp (Z,args) | _, [] when eq_constr c (Lazy.force coq_nat) -> Kapp (Nat,args) | _ -> Kufo -let destructurate_term t = - let c, args = decompose_app t in - match kind_of_term c, args with +let destructurate_term sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in + let c, args = decompose_app sigma t in + match EConstr.kind sigma c, args with | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args) @@ -480,15 +492,16 @@ let destructurate_term t = | Var id,[] -> Kvar id | _ -> Kufo -let recognize_number t = +let recognize_number sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in let rec loop t = - match decompose_app t with + match decompose_app sigma t with | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t | f, [] when eq_constr f (Lazy.force coq_xH) -> one | _ -> failwith "not a number" in - match decompose_app t with + match decompose_app sigma t with | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t) | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero @@ -504,9 +517,9 @@ type constr_path = | P_ARITY | P_ARG -let context operation path (t : constr) = +let context sigma operation path (t : constr) = let rec loop i p0 t = - match (p0,kind_of_term t) with + match (p0,EConstr.kind sigma t) with | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> @@ -517,7 +530,7 @@ let context operation path (t : constr) = let v' = Array.copy v in v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) | ((P_ARITY :: p), App (f,l)) -> - appvect (loop i p f,l) + mkApp (loop i p f,l) | ((P_ARG :: p), App (f,v)) -> let v' = Array.copy v in v'.(0) <- loop i p v'.(0); mkApp (f,v') @@ -542,8 +555,8 @@ let context operation path (t : constr) = in loop 1 path t -let occurrence path (t : constr) = - let rec loop p0 t = match (p0,kind_of_term t) with +let occurrence sigma path (t : constr) = + let rec loop p0 t = match (p0,EConstr.kind sigma t) with | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) @@ -562,14 +575,13 @@ let occurrence path (t : constr) = in loop path t -let abstract_path typ path t = +let abstract_path sigma typ path t = let term_occur = ref (mkRel 0) in - let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in + let abstract = context sigma (fun i t -> term_occur:= t; mkRel i) path t in mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur let focused_simpl path gl = - let newc = context (fun i t -> EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr t))) (List.rev path) (EConstr.Unsafe.to_constr (pf_concl gl)) in - let newc = EConstr.of_constr newc in + let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl let focused_simpl path = focused_simpl path @@ -632,8 +644,7 @@ let mkNewMeta () = mkMeta (Evarutil.new_meta()) let clever_rewrite_base_poly typ p result theorem gl = let full = pf_concl gl in - let full = EConstr.Unsafe.to_constr full in - let (abstracted,occ) = abstract_path typ (List.rev p) full in + let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in let t = applist (mkLambda @@ -646,7 +657,7 @@ let clever_rewrite_base_poly typ p result theorem gl = [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), [abstracted]) in - exact (EConstr.of_constr (applist(t,[mkNewMeta()]))) gl + exact (applist(t,[mkNewMeta()])) gl let clever_rewrite_base p result theorem gl = clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl @@ -664,11 +675,10 @@ let clever_rewrite_gen_nat p result (t,args) = let clever_rewrite p vpath t gl = let full = pf_concl gl in - let full = EConstr.Unsafe.to_constr full in - let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in - let vargs = List.map (fun p -> occurrence p occ) vpath in + let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in + let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in - exact (EConstr.of_constr (applist(t',[mkNewMeta()]))) gl + exact (applist(t',[mkNewMeta()])) gl let rec shuffle p (t1,t2) = match t1,t2 with @@ -910,10 +920,10 @@ let rec negate p = function | Oz i -> [focused_simpl p],Oz(neg i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) -let rec transform p t = +let rec transform sigma p t = let default isnat t' = try - let v,th,_ = find_constr t' in + let v,th,_ = find_constr sigma t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v with e when CErrors.noncritical e -> let v = new_identifier_var () @@ -921,29 +931,29 @@ let rec transform p t = hide_constr t' v th isnat; [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v in - try match destructurate_term t with + try match destructurate_term sigma t with | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 - and tac2,t2' = transform (P_APP 2 :: p) t2 in + let tac1,t1' = transform sigma (P_APP 1 :: p) t1 + and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in let tac,t' = shuffle p (t1',t2') in tac1 @ tac2 @ tac, t' | Kapp(Zminus,[t1;t2]) -> let tac,t = - transform p + transform sigma p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in Proofview.V82.of_tactic (unfold sp_Zminus) :: tac,t | Kapp(Zsucc,[t1]) -> - let tac,t = transform p (mkApp (Lazy.force coq_Zplus, + let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer one |])) in Proofview.V82.of_tactic (unfold sp_Zsucc) :: tac,t | Kapp(Zpred,[t1]) -> - let tac,t = transform p (mkApp (Lazy.force coq_Zplus, + let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer negone |])) in Proofview.V82.of_tactic (unfold sp_Zpred) :: tac,t | Kapp(Zmult,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 - and tac2,t2' = transform (P_APP 2 :: p) t2 in + let tac1,t1' = transform sigma (P_APP 1 :: p) t1 + and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in begin match t1',t2' with | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' | (Oz n,_) -> @@ -954,11 +964,11 @@ let rec transform p t = | _ -> default false t end | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number t)) + (try ([],Oz(recognize_number sigma t)) with e when CErrors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> - let tac,t' = transform (P_APP 1 :: p) t in + let tac,t' = transform sigma (P_APP 1 :: p) t in let tac',t'' = negate p t' in tac @ tac', t'' | Kapp(Z_of_nat,[t']) -> default true t' @@ -1088,13 +1098,12 @@ let replay_history tactic_normalisation = let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = - let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()), + let not_sup_sup = mkApp (Lazy.force coq_eq, [| Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) in - let not_sup_sup = EConstr.of_constr not_sup_sup in Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ unfold sp_Zle; @@ -1120,7 +1129,7 @@ let replay_history tactic_normalisation = let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in Tacticals.New.tclTHENS - (cut (EConstr.of_constr state_eg)) + (cut state_eg) [ Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ (intros_using [aux]); @@ -1189,7 +1198,7 @@ let replay_history tactic_normalisation = if e1.kind == DISE then let tac = scalar_norm [P_APP 3] e2.body in Tacticals.New.tclTHENS - (cut (EConstr.of_constr state_eq)) + (cut state_eq) [Tacticals.New.tclTHENLIST [ (intros_using [aux1]); (generalize_tac @@ -1201,7 +1210,7 @@ let replay_history tactic_normalisation = Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in - Tacticals.New.tclTHENS (cut (EConstr.of_constr state_eq)) + Tacticals.New.tclTHENS (cut state_eq) [ Tacticals.New.tclTHENS (cut (mk_gt kk izero)) @@ -1231,7 +1240,7 @@ let replay_history tactic_normalisation = scalar_norm [P_APP 3] e1.body in Tacticals.New.tclTHENS - (cut (EConstr.of_constr (mk_eq eq1 (mk_inv eq2)))) + (cut (mk_eq eq1 (mk_inv eq2))) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA8, @@ -1249,7 +1258,7 @@ let replay_history tactic_normalisation = and eq2 = val_of(decompile orig) in let vid = unintern_id v in let theorem = - mkApp (build_coq_ex (), [| + mkApp (Lazy.force coq_ex, [| Lazy.force coq_Z; mkLambda (Name vid, @@ -1264,7 +1273,7 @@ let replay_history tactic_normalisation = shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in Tacticals.New.tclTHENS - (cut (EConstr.of_constr theorem)) + (cut theorem) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (elim_id aux); @@ -1277,7 +1286,7 @@ let replay_history tactic_normalisation = (clear [aux]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHEN (exists_tac (EConstr.of_constr eq1)) reflexivity ] + Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in @@ -1287,7 +1296,7 @@ let replay_history tactic_normalisation = let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in Tacticals.New.tclTHENS - (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))) + (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) [Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac1); (intros_using [id1]); (loop act1) ]; Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> @@ -1360,15 +1369,15 @@ let replay_history tactic_normalisation = in loop -let normalize p_initial t = - let (tac,t') = transform p_initial t in +let normalize sigma p_initial t = + let (tac,t') = transform sigma p_initial t in let (tac',t'') = condense p_initial t' in let (tac'',t''') = clear_zero p_initial t'' in tac @ tac' @ tac'' , t''' -let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = +let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = let p_initial = [P_APP pos ;P_TYPE] in - let (tac,t') = normalize p_initial t in + let (tac,t') = normalize sigma p_initial t in let shift_left = tclTHEN (Proofview.V82.of_tactic (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])) @@ -1383,34 +1392,35 @@ let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = (tactic,defs) let destructure_omega gl tac_def (id,c) = + let sigma = project gl in if String.equal (atompart_of_id id) "State" then tac_def else - try match destructurate_prop c with + try match destructurate_prop sigma c with | Kapp(Eq,[typ;t1;t2]) - when begin match destructurate_type (EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr typ))) with Kapp(Z,[]) -> true | _ -> false end -> + when begin match destructurate_type sigma (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation sigma id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def | Kapp(Zne,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation sigma id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def | Kapp(Zle,[t1;t2]) -> let t = mk_plus t2 (mk_inv t1) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def | Kapp(Zlt,[t1;t2]) -> let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def | Kapp(Zge,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def | Kapp(Zgt,[t1;t2]) -> let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def | _ -> tac_def with e when catchable_exception e -> tac_def @@ -1426,7 +1436,6 @@ let coq_omega = Proofview.Goal.nf_enter { enter = begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in - let hyps_types = List.map (on_snd EConstr.Unsafe.to_constr) hyps_types in let destructure_omega = Tacmach.New.of_old destructure_omega gl in let tactic_normalisation, system = List.fold_left destructure_omega ([],[]) hyps_types in @@ -1438,7 +1447,7 @@ let coq_omega = let i = new_id () in tag_hypothesis id i; (Tacticals.New.tclTHENLIST [ - (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_intro_Z, [t])))); + (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); (intros_using [v; id]); (elim_id id); (clear [id]); @@ -1449,7 +1458,7 @@ let coq_omega = constant = zero; id = i} :: sys else (Tacticals.New.tclTHENLIST [ - (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_new_var, [t])))); + (simplest_elim (applist (Lazy.force coq_new_var, [t]))); (intros_using [v;th]); tac ]), sys) @@ -1480,7 +1489,8 @@ let nat_inject = Proofview.Goal.nf_enter { enter = begin fun gl -> let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in let rec explore p t : unit Proofview.tactic = - try match destructurate_term t with + Proofview.tclEVARMAP >>= fun sigma -> + try match destructurate_term sigma t with | Kapp(Plus,[t1;t2]) -> Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) @@ -1499,7 +1509,7 @@ let nat_inject = let id = new_identifier () in Tacticals.New.tclTHENS (Tacticals.New.tclTHEN - (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_le_gt_dec, [t2;t1])))) + (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) (intros_using [id])) [ Tacticals.New.tclTHENLIST [ @@ -1516,14 +1526,14 @@ let nat_inject = ] | Kapp(S,[t']) -> let rec is_number t = - try match destructurate_term t with + try match destructurate_term sigma t with Kapp(S,[t]) -> is_number t | Kapp(O,[]) -> true | _ -> false with e when catchable_exception e -> false in let rec loop p t : unit Proofview.tactic = - try match destructurate_term t with + try match destructurate_term sigma t with Kapp(S,[t]) -> (Tacticals.New.tclTHEN (Proofview.V82.tactic (clever_rewrite_gen p @@ -1549,7 +1559,8 @@ let nat_inject = and loop = function | [] -> Proofview.tclUNIT () | (i,t)::lit -> - begin try match destructurate_prop t with + Proofview.tclEVARMAP >>= fun sigma -> + begin try match destructurate_prop sigma t with Kapp(Le,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac @@ -1596,7 +1607,7 @@ let nat_inject = (loop lit) ] | Kapp(Eq,[typ;t1;t2]) -> - if is_conv (EConstr.of_constr typ) (EConstr.of_constr (Lazy.force coq_nat)) then + if is_conv typ (Lazy.force coq_nat) then Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); @@ -1610,7 +1621,6 @@ let nat_inject = with e when catchable_exception e -> loop lit end in let hyps_types = Tacmach.New.pf_hyps_types gl in - let hyps_types = List.map (on_snd EConstr.Unsafe.to_constr) hyps_types in loop (List.rev hyps_types) end } @@ -1647,7 +1657,7 @@ let not_binop = function exception Undecidable let rec decidability gl t = - match destructurate_prop t with + match destructurate_prop (project gl) t with | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; decidability gl t1; decidability gl t2 |]) @@ -1665,7 +1675,7 @@ let rec decidability gl t = | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type (EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr typ))) with + begin match destructurate_type (project gl) (pf_nf gl typ) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable @@ -1696,6 +1706,15 @@ let onClearedName2 id tac = Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end }) +let local_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let rec is_Prop sigma c = match EConstr.kind sigma c with + | Sort (Prop Null) -> true + | Cast (c,_,_) -> is_Prop sigma c + | _ -> false + let destructure_hyps = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in @@ -1705,46 +1724,47 @@ let destructure_hyps = | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) | decl::lit -> let i = NamedDecl.get_id decl in - begin try match destructurate_prop (NamedDecl.get_type decl) with + Proofview.tclEVARMAP >>= fun sigma -> + begin try match destructurate_prop sigma (EConstr.of_constr (NamedDecl.get_type decl)) with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> (Tacticals.New.tclTHENS (elim_id i) - [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); - onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) + [ onClearedName i (fun i -> (loop (local_assum (i,t1)::lit))); + onClearedName i (fun i -> (loop (local_assum (i,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) + loop (local_assum (i1,t1) :: local_assum (i2,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) + loop (local_assum (i1,mkArrow t1 t2) :: local_assum (i2,mkArrow t2 t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if is_Prop (EConstr.Unsafe.to_constr (type_of (EConstr.of_constr t2))) + if is_Prop sigma (type_of t2) then let d1 = decidability t1 in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit)))) + (loop (local_assum (i,mk_or (mk_not t1) t2) :: lit)))) ] else loop lit | Kapp(Not,[t]) -> - begin match destructurate_prop t with + begin match destructurate_prop sigma t with Kapp(Or,[t1;t2]) -> Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) + (loop (local_assum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in @@ -1753,7 +1773,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) + (loop (local_assum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in @@ -1763,7 +1783,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2)) + (loop (local_assum (i, mk_or (mk_and t1 (mk_not t2)) (mk_and (mk_not t1) t2)) :: lit)))) ] | Kimp(t1,t2) -> @@ -1775,14 +1795,14 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit)))) + (loop (local_assum (i,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability t in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) + (onClearedName i (fun i -> (loop (local_assum (i,t) :: lit)))) ] | Kapp(op,[t1;t2]) -> (try @@ -1795,32 +1815,32 @@ let destructure_hyps = with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin - match destructurate_type (EConstr.Unsafe.to_constr (pf_nf (EConstr.of_constr typ))) with + match destructurate_type sigma (pf_nf typ) with | Kapp(Nat,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim - (EConstr.of_constr (mkApp - (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])))); + (mkApp + (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim - (EConstr.of_constr (mkApp - (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])))); + (mkApp + (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | _ -> loop lit end else begin - match destructurate_type (EConstr.Unsafe.to_constr (pf_nf (EConstr.of_constr typ))) with + match destructurate_type sigma (pf_nf typ) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) + (convert_hyp_no_check (NamedDecl.set_type (EConstr.Unsafe.to_constr (mkApp (Lazy.force coq_neq, [| t1;t2|]))) decl)) (loop lit)) | Kapp(Z,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) + (convert_hyp_no_check (NamedDecl.set_type (EConstr.Unsafe.to_constr (mkApp (Lazy.force coq_Zne, [| t1;t2|]))) decl)) (loop lit)) | _ -> loop lit @@ -1842,7 +1862,8 @@ let destructure_goal = let concl = Proofview.Goal.concl gl in let decidability = Tacmach.New.of_old decidability gl in let rec loop t = - match destructurate_prop t with + Proofview.tclEVARMAP >>= fun sigma -> + match destructurate_prop sigma t with | Kapp(Not,[t]) -> (Tacticals.New.tclTHEN (Tacticals.New.tclTHEN (unfold sp_not) intro) @@ -1855,13 +1876,12 @@ let destructure_goal = let dec = decidability t in Tacticals.New.tclTHEN (Proofview.V82.tactic (Tacmach.refine - (EConstr.of_constr (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))) + (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))) intro - with Undecidable -> Tactics.elim_type (EConstr.of_constr (build_coq_False ())) + with Undecidable -> Tactics.elim_type (Lazy.force coq_False) in Tacticals.New.tclTHEN goal_tac destructure_hyps in - let concl = EConstr.Unsafe.to_constr concl in (loop concl) end } -- cgit v1.2.3 From 01849481fbabc3a3fa6c483e703996b01e37fca5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 01:25:11 +0100 Subject: Removing compatibility layers from Tacticals --- plugins/cc/cctac.ml | 5 ++--- plugins/firstorder/instances.ml | 12 +++++++----- plugins/firstorder/rules.ml | 32 +++++++++++++++++++------------- plugins/fourier/fourierR.ml | 2 +- 4 files changed, 29 insertions(+), 22 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 2ab4dced4d..53c4501169 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -241,10 +241,10 @@ let build_projection intype (cstr:pconstructor) special default gls= let _M =mkMeta let app_global f args k = - Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (EConstr.of_constr fc, args))) + Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) let new_app_global f args k = - Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (EConstr.of_constr fc, args))) + Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) let new_refine c = Proofview.V82.tactic (refine c) let refine c = refine c @@ -491,7 +491,6 @@ let congruence_tac depth l = let mk_eq f c1 c2 k = Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> - let fc = EConstr.of_constr fc in Proofview.Goal.enter { enter = begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 2881b53339..ef8172de41 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -104,7 +104,7 @@ let mk_open_instance id idc gl m t= let evmap=Refiner.project gl in let var_id= if id==dummy_id then dummy_bvid else - let typ=pf_unsafe_type_of gl (EConstr.of_constr idc) in + let typ=pf_unsafe_type_of gl idc in (* since we know we will get a product, reduction is not too expensive *) let (nam,_,_)=destProd (EConstr.Unsafe.to_constr (whd_all env evmap typ)) in @@ -127,6 +127,7 @@ let mk_open_instance id idc gl m t= (* tactics *) let left_instance_tac (inst,id) continue seq= + let open EConstr in match inst with Phantom dom-> if lookup (id,None) seq then @@ -137,8 +138,8 @@ let left_instance_tac (inst,id) continue seq= [Proofview.V82.of_tactic introf; pf_constr_of_global id (fun idc -> (fun gls-> Proofview.V82.of_tactic (generalize - [EConstr.of_constr (mkApp(idc, - [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|]))]) gls)); + [mkApp(idc, + [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])]) gls)); Proofview.V82.of_tactic introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; @@ -152,18 +153,19 @@ let left_instance_tac (inst,id) continue seq= pf_constr_of_global id (fun idc -> fun gl-> let evmap,rc,ot = mk_open_instance id idc gl m t in + let ot = EConstr.of_constr ot in let gt= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in - let gt = EConstr.of_constr gt in let evmap, _ = try Typing.type_of (pf_env gl) evmap gt with e when CErrors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl) else + let t = EConstr.of_constr t in pf_constr_of_global id (fun idc -> - Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(idc,[|t|]))])) + Proofview.V82.of_tactic (generalize [mkApp(idc,[|t|])])) in tclTHENLIST [special_generalize; diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 38dae0b204..36bd91ab6a 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -59,16 +59,17 @@ let clear_global=function (* connection rules *) let axiom_tac t seq= - try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check (EConstr.of_constr c))) + try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check c)) with Not_found->tclFAIL 0 (Pp.str "No axiom link") let ll_atom_tac a backtrack id continue seq= + let open EConstr in tclIFTHENELSE (try tclTHENLIST [pf_constr_of_global (find_left a seq) (fun left -> pf_constr_of_global id (fun id -> - Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(id, [|left|]))]))); + Proofview.V82.of_tactic (generalize [(mkApp(id, [|left|]))]))); clear_global id; Proofview.V82.of_tactic intro] with Not_found->tclFAIL 0 (Pp.str "No link")) @@ -95,7 +96,7 @@ let left_and_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (tclTHENLIST - [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim)); + [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim); clear_global id; tclDO n (Proofview.V82.of_tactic intro)]) (wrap n false continue seq) @@ -109,12 +110,12 @@ let left_or_tac ind backtrack id continue seq gls= tclDO n (Proofview.V82.of_tactic intro); wrap n false continue seq] in tclIFTHENSVELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim))) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) (Array.map f v) backtrack gls let left_false_tac id= - Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim)) + Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim) (* left arrow connective rules *) @@ -133,7 +134,7 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= let head=mkApp ((lift p idc),[|capply|]) in EConstr.of_constr (it_mkLambda_or_LetIn head rc) in let lp=Array.length rcs in - let newhyps idc =List.init lp (myterm idc) in + let newhyps idc =List.init lp (myterm (EConstr.Unsafe.to_constr idc)) in tclIFTHENELSE (tclTHENLIST [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize (newhyps idc))); @@ -142,17 +143,22 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= (wrap lp false continue seq) backtrack gl let ll_arrow_tac a b c backtrack id continue seq= + let open EConstr in + let open Vars in + let a = EConstr.of_constr a in + let b = EConstr.of_constr b in + let c = EConstr.of_constr c in let cc=mkProd(Anonymous,a,(lift 1 b)) in - let d idc =EConstr.of_constr (mkLambda (Anonymous,b, - mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|]))) in + let d idc = mkLambda (Anonymous,b, + mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in tclORELSE - (tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr c))) + (tclTHENS (Proofview.V82.of_tactic (cut c)) [tclTHENLIST [Proofview.V82.of_tactic introf; clear_global id; wrap 1 false continue seq]; - tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr cc))) - [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check (EConstr.of_constr c))); + tclTHENS (Proofview.V82.of_tactic (cut cc)) + [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check c)); tclTHENLIST [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [d idc])); clear_global id; @@ -177,7 +183,7 @@ let forall_tac backtrack continue seq= let left_exists_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim))) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) (tclTHENLIST [clear_global id; tclDO n (Proofview.V82.of_tactic intro); (wrap (n-1) false continue seq)]) @@ -191,9 +197,9 @@ let ll_forall_tac prod backtrack id continue seq= [Proofview.V82.of_tactic intro; pf_constr_of_global id (fun idc -> (fun gls-> + let open EConstr in let id0=pf_nth_hyp_id gls 1 in let term=mkApp(idc,[|mkVar(id0)|]) in - let term = EConstr.of_constr term in tclTHEN (Proofview.V82.of_tactic (generalize [term])) (Proofview.V82.of_tactic (clear [id0])) gls)); clear_global id; Proofview.V82.of_tactic intro; diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index bffca62231..ec73fccb5b 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -616,7 +616,7 @@ let rec fourier () = (* TODO : Ring.polynom []*) (Proofview.tclUNIT ()) (Proofview.tclUNIT ()); Tacticals.New.pf_constr_of_global (cget coq_sym_eqT) (fun symeq -> - (Tacticals.New.tclTHEN (apply (EConstr.of_constr symeq)) + (Tacticals.New.tclTHEN (apply symeq) (apply (get coq_Rinv_1))))] ) -- 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. --- plugins/decl_mode/decl_proof_instr.ml | 1 + plugins/derive/derive.ml | 5 +++-- plugins/funind/functional_principles_proofs.ml | 2 +- plugins/funind/functional_principles_types.ml | 2 +- plugins/funind/invfun.ml | 4 ++-- plugins/funind/recdef.ml | 6 +++--- plugins/ssrmatching/ssrmatching.ml4 | 25 ++++++++++++++----------- 7 files changed, 25 insertions(+), 20 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 6a0ec3968f..da971fffb8 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -1506,6 +1506,7 @@ let rec postprocess pts instr = | Pend (B_elim ET_Induction) -> begin let pfterm = List.hd (Proof.partial_proof pts) in + let pfterm = EConstr.Unsafe.to_constr pfterm in let { it = gls ; sigma = sigma } = Proof.V82.subgoals pts in let env = try Goal.V82.env sigma (List.hd gls) diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index f23f4ce7df..12d7f06603 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -28,16 +28,17 @@ let start_deriving f suchthat lemma = (* spiwack: I don't know what the rigidity flag does, picked the one that looked the most general. *) let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in - let f_type_type = Term.mkSort f_type_sort in + let f_type_type = EConstr.mkSort f_type_sort in (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) let goals = let open Proofview in TCons ( env , sigma , f_type_type , (fun sigma f_type -> TCons ( env , sigma , f_type , (fun sigma ef -> + let f_type = EConstr.Unsafe.to_constr f_type in + let ef = EConstr.Unsafe.to_constr ef in let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in let evdref = ref sigma in let suchthat = Constrintern.interp_type_evars env' evdref suchthat in - let suchthat = EConstr.Unsafe.to_constr suchthat in TCons ( env' , !evdref , suchthat , (fun sigma _ -> TNil sigma)))))) in diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index f4fa61a22f..91b17b9a4d 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -1007,7 +1007,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (mk_equation_id f_id) (Decl_kinds.Global, Flags.is_universe_polymorphism (), (Decl_kinds.Proof Decl_kinds.Theorem)) evd - (EConstr.Unsafe.to_constr lemma_type) + lemma_type (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic prove_replacement)); Lemmas.save_proof (Vernacexpr.(Proved(Transparent,None))); diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index ba01b3b044..d0d44b34ba 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -294,7 +294,7 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin new_princ_name (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) !evd - new_principle_type + (EConstr.of_constr new_principle_type) hook ; (* let _tim1 = System.get_time () in *) diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 5cbec77437..dcec2cb74d 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -846,7 +846,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( lem_id (Decl_kinds.Global,Flags.is_universe_polymorphism (),((Decl_kinds.Proof Decl_kinds.Theorem))) !evd - (EConstr.Unsafe.to_constr typ) + typ (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove correctness ("^(Id.to_string f_id)^")") @@ -908,7 +908,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let lem_id = mk_complete_id f_id in Lemmas.start_proof lem_id (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) sigma - (EConstr.Unsafe.to_constr (fst lemmas_types_infos.(i))) + (fst lemmas_types_infos.(i)) (Lemmas.mk_hook (fun _ _ -> ())); ignore (Pfedit.by (Proofview.V82.tactic (observe_tac ("prove completeness ("^(Id.to_string f_id)^")") diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index adbdb1eb7b..56c6ab054d 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -1374,7 +1374,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp Lemmas.start_proof na (Decl_kinds.Global, false (* FIXME *), Decl_kinds.Proof Decl_kinds.Lemma) - sigma (EConstr.Unsafe.to_constr gls_type) + sigma gls_type (Lemmas.mk_hook hook); if Indfun_common.is_strict_tcc () then @@ -1421,7 +1421,7 @@ let com_terminate let (evmap, env) = Lemmas.get_current_context() in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) - ctx (compute_terminate_type nb_args fonctional_ref) hook; + ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook; ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref @@ -1476,7 +1476,7 @@ let (com_eqn : int -> Id.t -> (Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign:(Environ.named_context_val env) evmap - equation_lemma_type + (EConstr.of_constr equation_lemma_type) (Lemmas.mk_hook (fun _ _ -> ())); ignore (by (Proofview.V82.tactic (start_equation f_ref terminate_ref diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index eb5f401e37..bf3e2ac1c0 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -178,6 +178,9 @@ let mk_lterm = mk_term ' ' let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty +let nf_evar sigma c = + EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) + (* }}} *) (** Profiling {{{ *************************************************************) @@ -780,13 +783,13 @@ let on_instance, instances = let rec uniquize = function | [] -> [] | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs -> - let t = Reductionops.nf_evar sigma t in - let f = Reductionops.nf_evar sigma f in - let a = Array.map (Reductionops.nf_evar sigma) a in + let t = nf_evar sigma t in + let f = nf_evar sigma f in + let a = Array.map (nf_evar sigma) a in let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) = - let t1 = Reductionops.nf_evar sigma1 t1 in - let f1 = Reductionops.nf_evar sigma1 f1 in - let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in + let t1 = nf_evar sigma1 t1 in + let f1 = nf_evar sigma1 f1 in + let a1 = Array.map (nf_evar sigma1) a1 in not (Term.eq_constr t t1 && Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in x :: uniquize (List.filter neq xs) in @@ -1138,7 +1141,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else (update k; k::acc) | _ -> fold_constr aux acc t in - aux [] (Evarutil.nf_evar sigma rp) in + aux [] (nf_evar sigma rp) in let sigma = List.fold_left (fun sigma e -> if Evd.is_defined sigma e then sigma else (* clear may be recursive *) @@ -1195,7 +1198,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in - let rp = subst1 h (Evarutil.nf_evar sigma rp) in + let rp = subst1 h (nf_evar sigma rp) in sigma, mk h rp | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> let mk e x p = @@ -1204,7 +1207,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in - let rp = subst1 h (Evarutil.nf_evar sigma rp) in + let rp = subst1 h (nf_evar sigma rp) in let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in sigma, mk e h rp ;; @@ -1220,7 +1223,7 @@ let noindex = Some(false,[]) (* calls do_subst on every sub-term identified by (pattern,occ) *) let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = - let fs sigma x = Reductionops.nf_evar sigma x in + let fs sigma x = nf_evar sigma x in let pop_evar sigma e p = let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in let e_body = match e_body with Evar_defined c -> c @@ -1307,7 +1310,7 @@ let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = let sigma = if not resolve_typeclasses then sigma else Typeclasses.resolve_typeclasses ~fail:false env sigma in - Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma + nf_evar sigma e, Evd.evar_universe_context sigma let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = let do_make_rel, occ = -- 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. --- plugins/cc/cctac.ml | 8 ++----- plugins/decl_mode/decl_proof_instr.ml | 15 +++++++------ plugins/extraction/extraction.ml | 2 +- plugins/firstorder/instances.ml | 3 +-- plugins/firstorder/rules.ml | 2 +- plugins/fourier/fourierR.ml | 4 +++- plugins/funind/functional_principles_proofs.ml | 7 +++--- plugins/funind/functional_principles_types.ml | 16 ++++++++------ plugins/funind/indfun.ml | 2 +- plugins/funind/invfun.ml | 20 ++++++----------- plugins/funind/merge.ml | 2 +- plugins/funind/recdef.ml | 2 +- plugins/omega/coq_omega.ml | 30 +++++++++++--------------- plugins/rtauto/refl_tauto.ml | 28 +++++++++++++----------- plugins/rtauto/refl_tauto.mli | 6 +++--- plugins/ssrmatching/ssrmatching.ml4 | 4 ++-- 16 files changed, 72 insertions(+), 79 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 53c4501169..5d894c6774 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -28,10 +28,6 @@ open Proofview.Notations 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 reference dir s = lazy (Coqlib.gen_reference "CC" dir s) let _f_equal = reference ["Init";"Logic"] "f_equal" @@ -160,7 +156,7 @@ let rec quantified_atom_of_constr env sigma nrels term = let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (Environ.push_rel (local_assum (id,atom)) env) sigma (succ nrels) ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts @@ -175,7 +171,7 @@ let litteral_of_constr env sigma term= else begin try - quantified_atom_of_constr (Environ.push_rel (local_assum (id,atom)) env) sigma 1 ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index da971fffb8..adc4ad8a33 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -49,7 +49,7 @@ let clear ids { it = goal; sigma } = user_err (str "Cannot clear " ++ pr_id id) in let sigma = !evdref in - let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps (EConstr.of_constr concl) (Goal.V82.extra sigma goal) in + let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in let sigma = Goal.V82.partial_solution_to sigma goal gl ev in { it = [gl]; sigma } @@ -638,7 +638,7 @@ let assume_tac hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,EConstr.of_constr st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_hyps_or_theses hyps gls = @@ -648,7 +648,7 @@ let assume_hyps_or_theses hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,c)))) nam) + Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,EConstr.of_constr c)))) nam) | Hprop {st_label=nam;st_it=Thesis (tk)} -> tclTHEN (push_intro_tac @@ -660,7 +660,7 @@ let assume_st hyps gls = (fun st -> tclTHEN (push_intro_tac - (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) + (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,EConstr.of_constr st.st_it)))) st.st_label)) hyps tclIDTAC gls let assume_st_letin hyps gls = @@ -669,7 +669,7 @@ let assume_st_letin hyps gls = tclTHEN (push_intro_tac (fun id -> - Proofview.V82.of_tactic (convert_hyp (LocalDef (id, fst st.st_it, snd st.st_it)))) st.st_label)) + Proofview.V82.of_tactic (convert_hyp (LocalDef (id, EConstr.of_constr (fst st.st_it), EConstr.of_constr (snd st.st_it))))) st.st_label)) hyps tclIDTAC gls (* suffices *) @@ -763,7 +763,7 @@ let rec consider_match may_intro introduced available expected gls = error "Not enough sub-hypotheses to match statements." (* should tell which ones *) | id::rest_ids,(Hvar st | Hprop st)::rest -> - tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) + tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,EConstr.of_constr st.st_it)))) begin match st.st_label with Anonymous -> @@ -834,13 +834,13 @@ let define_tac id args body gls = (* tactics for reconsider *) let cast_tac id_or_thesis typ gls = + let typ = EConstr.of_constr typ in match id_or_thesis with | This id -> Proofview.V82.of_tactic (id |> pf_get_hyp gls |> NamedDecl.set_id id |> NamedDecl.set_type typ |> convert_hyp) gls | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> - let typ = EConstr.of_constr typ in Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls (* per cases *) @@ -1290,6 +1290,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let f_ids typ = let sign = (prod_assum (Term.prod_applist typ params)) in + let sign = List.map (fun d -> Termops.map_rel_decl EConstr.of_constr d) sign in find_intro_names sign gls in let constr_args_ids = Array.map f_ids gen_arities in let case_term = diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index 7b7e746f20..8744eacd3f 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -858,7 +858,7 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt = let decomp_lams_eta_n n m env c t = let rels = fst (splay_prod_n env none n (EConstr.of_constr t)) in - let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in + let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,EConstr.Unsafe.to_constr c)) rels in let rels',c = decompose_lam c in let d = n - m in (* we'd better keep rels' as long as possible. *) diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index ef8172de41..9dc2a51a61 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -117,10 +117,9 @@ let mk_open_instance id idc gl m t= let nid=(fresh_id avoid var_id gl) in let evmap = Sigma.Unsafe.of_evar_map evmap in let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in - let c = EConstr.Unsafe.to_constr c in let evmap = Sigma.to_evar_map evmap in let decl = LocalAssum (Name nid, c) in - aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in + aux (n-1) (nid::avoid) (EConstr.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in evmap, decls, revt diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 36bd91ab6a..a60fd4d8f1 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -42,7 +42,7 @@ let wrap n b continue seq gls= List.exists (occur_var_in_decl env (project gls) id) ctx then (aux (i-1) q (nd::ctx)) else - add_formula Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) gls in + add_formula Hyp (VarRef id) (EConstr.Unsafe.to_constr (NamedDecl.get_type nd)) (aux (i-1) q (nd::ctx)) gls in let seq1=aux n nc [] in let seq2=if b then add_formula Concl dummy_id (EConstr.Unsafe.to_constr (pf_concl gls)) seq1 gls else seq1 in diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index ec73fccb5b..e11cbc279a 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -190,6 +190,8 @@ type hineq={hname:constr; (* le nom de l'hypothèse *) exception NoIneq let ineq1_of_constr (h,t) = + let h = EConstr.Unsafe.to_constr h in + let t = EConstr.Unsafe.to_constr t in match (kind_of_term t) with | App (f,args) -> (match kind_of_term f with @@ -504,7 +506,7 @@ let rec fourier () = |_-> raise GoalDone with GoalDone -> (* les hypothèses *) - let hyps = List.map (fun (h,t)-> (mkVar h,t)) + let hyps = List.map (fun (h,t)-> (EConstr.mkVar h,t)) (list_of_sign (Proofview.Goal.hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 91b17b9a4d..bc64b079c5 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -236,7 +236,7 @@ let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta -let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = +let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let nochange ?t' msg = begin observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_leconstr t ); @@ -315,7 +315,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, EConstr.of_constr (RelDecl.get_type decl), witness_fun)) + (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -544,7 +544,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = (scan_type new_context new_t') with Failure "NoChange" -> (* Last thing todo : push the rel in the context and continue *) - scan_type (local_assum (x,t_x) :: context) t' + scan_type (LocalAssum (x,t_x) :: context) t' end end else @@ -933,6 +933,7 @@ let generalize_non_dep hyp g = let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in let hyp = get_id decl in if Id.List.mem hyp hyps || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index d0d44b34ba..e845db3bc3 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -33,9 +33,9 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let princ_type = EConstr.of_constr princ_type in let princ_type_info = compute_elim_sig Evd.empty princ_type (** FIXME *) in let env = Global.env () in - let env_with_params = Environ.push_rel_context princ_type_info.params env in + let env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t = + let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context) : EConstr.rel_context = match predicates with | [] -> [] | decl :: predicates -> @@ -56,7 +56,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod (RelDecl.get_type decl) in + let args,_ = decompose_prod (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in let real_args = if princ_type_info.indarg_in_concl then List.tl args @@ -87,17 +87,19 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | _ -> false in let pre_princ = + let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn (Option.fold_right mkProd_or_LetIn princ_type_info.indarg - (EConstr.Unsafe.to_constr princ_type_info.concl) + princ_type_info.concl ) princ_type_info.args ) princ_type_info.branches in + let pre_princ = EConstr.Unsafe.to_constr pre_princ in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with @@ -240,7 +242,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) new_predicates) ) - princ_type_info.params + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) @@ -251,7 +253,7 @@ let change_property_sort evd toSort princ princName = let change_sort_in_predicate decl = LocalAssum (get_name decl, - let args,ty = decompose_prod (get_type decl) in + let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); Term.compose_prod args (mkSort toSort) @@ -270,7 +272,7 @@ let change_property_sort evd toSort princ princName = (it_mkLambda_or_LetIn init (List.map change_sort_in_predicate princ_info.predicates) ) - princ_info.params + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.params) let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 1cde4420e5..a7489fb7b4 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -19,7 +19,7 @@ let is_rec_info sigma scheme_info = let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (EConstr.of_constr (RelDecl.get_type decl)))) in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in let free_rels_in_br = Termops.free_rels sigma new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index dcec2cb74d..8f1420940b 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -26,12 +26,6 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration -let local_assum (na, t) = - RelDecl.LocalAssum (na, EConstr.Unsafe.to_constr t) - -let local_def (na, b, t) = - RelDecl.LocalDef (na, EConstr.Unsafe.to_constr b, EConstr.Unsafe.to_constr t) - (* Some pretty printing function for debugging purpose *) let pr_binding prc = @@ -147,7 +141,7 @@ let generate_type evd g_to_f f graph i = let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") - | decl :: fun_ctxt -> fun_ctxt, EConstr.of_constr (RelDecl.get_type decl) + | decl :: fun_ctxt -> fun_ctxt, RelDecl.get_type decl in let rec args_from_decl i accu = function | [] -> accu @@ -187,12 +181,12 @@ let generate_type evd g_to_f f graph i = \[\forall (x_1:t_1)\ldots(x_n:t_n), let fv := f x_1\ldots x_n in, forall res, \] i*) let pre_ctxt = - local_assum (Name res_id, lift 1 res_type) :: local_def (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt + LocalAssum (Name res_id, lift 1 res_type) :: LocalDef (Name fv_id, mkApp (f,args_as_rels), res_type) :: fun_ctxt in (*i and we can return the solution depending on which lemma type we are defining i*) if g_to_f - then local_assum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph - else local_assum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph + then LocalAssum (Anonymous,graph_applied)::pre_ctxt,(lift 1 res_eq_f_of_args),graph + else LocalAssum (Anonymous,res_eq_f_of_args)::pre_ctxt,(lift 1 graph_applied),graph (* @@ -280,7 +274,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (EConstr.of_constr (RelDecl.get_type decl)))))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches in @@ -477,7 +471,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | LocalAssum (id,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -695,7 +689,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (EConstr.of_constr (RelDecl.get_type decl)))) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl))) ) branches in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 2840193a94..691385fad0 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -976,7 +976,7 @@ let funify_branches relinfo nfuns branch = | Rel i -> let reali = i-shift in (reali>=0 && reali false in (* FIXME: *) - LocalDef (Anonymous,mkProp,mkProp) + LocalDef (Anonymous,EConstr.mkProp,EConstr.mkProp) let relprinctype_to_funprinctype relprinctype nfuns = diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 56c6ab054d..f5ea32878c 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -693,7 +693,7 @@ let mkDestructEq : (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.occur_term (project g) expr (EConstr.of_constr (get_type decl))) + if Id.List.mem id not_on_hyp || not (Termops.occur_term (project g) expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 9e0d591b69..8c2f0f53f4 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1706,10 +1706,6 @@ let onClearedName2 id tac = Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end }) -let local_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - let rec is_Prop sigma c = match EConstr.kind sigma c with | Sort (Prop Null) -> true | Cast (c,_,_) -> is_Prop sigma c @@ -1725,24 +1721,24 @@ let destructure_hyps = | decl::lit -> let i = NamedDecl.get_id decl in Proofview.tclEVARMAP >>= fun sigma -> - begin try match destructurate_prop sigma (EConstr.of_constr (NamedDecl.get_type decl)) with + begin try match destructurate_prop sigma (NamedDecl.get_type decl) with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> (Tacticals.New.tclTHENS (elim_id i) - [ onClearedName i (fun i -> (loop (local_assum (i,t1)::lit))); - onClearedName i (fun i -> (loop (local_assum (i,t2)::lit))) ]) + [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); + onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (local_assum (i1,t1) :: local_assum (i2,t2) :: lit))) + loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> Tacticals.New.tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> - loop (local_assum (i1,mkArrow t1 t2) :: local_assum (i2,mkArrow t2 t1) :: lit))) + loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) @@ -1753,7 +1749,7 @@ let destructure_hyps = (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> - (loop (local_assum (i,mk_or (mk_not t1) t2) :: lit)))) + (loop (LocalAssum (i,mk_or (mk_not t1) t2) :: lit)))) ] else loop lit @@ -1764,7 +1760,7 @@ let destructure_hyps = (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> - (loop (local_assum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) + (loop (LocalAssum (i,mk_and (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in @@ -1773,7 +1769,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (local_assum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) + (loop (LocalAssum (i,mk_or (mk_not t1) (mk_not t2)) :: lit)))) ] | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in @@ -1783,7 +1779,7 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); (onClearedName i (fun i -> - (loop (local_assum (i, mk_or (mk_and t1 (mk_not t2)) + (loop (LocalAssum (i, mk_or (mk_and t1 (mk_not t2)) (mk_and (mk_not t1) t2)) :: lit)))) ] | Kimp(t1,t2) -> @@ -1795,14 +1791,14 @@ let destructure_hyps = [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); (onClearedName i (fun i -> - (loop (local_assum (i,mk_and t1 (mk_not t2)) :: lit)))) + (loop (LocalAssum (i,mk_and t1 (mk_not t2)) :: lit)))) ] | Kapp(Not,[t]) -> let d = decidability t in Tacticals.New.tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); - (onClearedName i (fun i -> (loop (local_assum (i,t) :: lit)))) + (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) ] | Kapp(op,[t1;t2]) -> (try @@ -1835,12 +1831,12 @@ let destructure_hyps = match destructurate_type sigma (pf_nf typ) with | Kapp(Nat,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (EConstr.Unsafe.to_constr (mkApp (Lazy.force coq_neq, [| t1;t2|]))) + (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> (Tacticals.New.tclTHEN - (convert_hyp_no_check (NamedDecl.set_type (EConstr.Unsafe.to_constr (mkApp (Lazy.force coq_Zne, [| t1;t2|]))) + (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) | _ -> loop lit diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 4753805120..adb11f4f88 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -66,19 +66,18 @@ let l_E_Or = lazy (constant "E_Or") let l_D_Or = lazy (constant "D_Or") -let special_whd gl= - let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) +let special_whd gl c = + Reductionops.clos_whd_flags CClosure.all (pf_env gl) (Tacmach.project gl) c -let special_nf gl= - let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in - (fun t -> CClosure.norm_val infos (CClosure.inject t)) +let special_nf gl c = + Reductionops.clos_norm_flags CClosure.betaiotazeta (pf_env gl) (Tacmach.project gl) c type atom_env= {mutable next:int; mutable env:(constr*int) list} let make_atom atom_env term= + let term = EConstr.Unsafe.to_constr term in try let (_,i)= List.find (fun (t,_)-> eq_constr term t) atom_env.env @@ -90,13 +89,17 @@ let make_atom atom_env term= Atom i let rec make_form atom_env gls term = + let open EConstr in + let open Vars in let normalize=special_nf gls in let cciterm=special_whd gls term in - match kind_of_term cciterm with + let sigma = Tacmach.project gls in + let inj = EConstr.Unsafe.to_constr in + match EConstr.kind sigma cciterm with Prod(_,a,b) -> - if EConstr.Vars.noccurn (Tacmach.project gls) 1 (EConstr.of_constr b) && + if noccurn sigma 1 b && Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) (EConstr.of_constr a) == InProp + (pf_env gls) sigma a == InProp then let fa=make_form atom_env gls a in let fb=make_form atom_env gls b in @@ -113,7 +116,7 @@ let rec make_form atom_env gls term = | App(hd,argv) when Int.equal (Array.length argv) 2 -> begin try - let ind, _ = destInd hd in + let ind, _ = destInd sigma hd in if Names.eq_ind ind (fst (Lazy.force li_and)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in @@ -134,9 +137,9 @@ let rec make_hyps atom_env gls lenv = function | LocalAssum (id,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in - if List.exists (fun c -> Termops.local_occur_var Evd.empty (** FIXME *) id (EConstr.of_constr c)) lenv || + if List.exists (fun c -> Termops.local_occur_var Evd.empty (** FIXME *) id c) lenv || (Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) (EConstr.of_constr typ) != InProp) + (pf_env gls) (Tacmach.project gls) typ != InProp) then hrec else @@ -264,7 +267,6 @@ let rtauto_tac gls= if Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) gl != InProp then user_err ~hdr:"rtauto" (Pp.str "goal should be in Prop") in - let gl = EConstr.Unsafe.to_constr gl in let glf=make_form gamma gls gl in let hyps=make_hyps gamma gls [gl] (pf_hyps gls) in let formula= diff --git a/plugins/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index 9a14ac6c79..0925523641 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -12,13 +12,13 @@ type atom_env= mutable env:(Term.constr*int) list} val make_form : atom_env -> - Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form + Proof_type.goal Tacmach.sigma -> EConstr.types -> Proof_search.form val make_hyps : atom_env -> Proof_type.goal Tacmach.sigma -> - Term.types list -> - Context.Named.t -> + EConstr.types list -> + EConstr.named_context -> (Names.Id.t * Proof_search.form) list val rtauto_tac : Proof_type.tactic diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index bf3e2ac1c0..d4579c3a19 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -838,7 +838,7 @@ let rec uniquize = function | Context.Rel.Declaration.LocalAssum _ as x -> x | Context.Rel.Declaration.LocalDef (x,_,y) -> Context.Rel.Declaration.LocalAssum(x,y) in - Environ.push_rel ctx_item env, h' + 1 in + EConstr.push_rel ctx_item env, h' + 1 in let self acc c = EConstr.of_constr (subst_loop acc (EConstr.Unsafe.to_constr c)) in let f = EConstr.of_constr f in let f' = map_constr_with_binders_left_to_right sigma inc_h self acc f in @@ -1091,7 +1091,7 @@ let thin id sigma goal = | None -> sigma | Some (hyps, concl) -> let sigma = !evdref in - let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps (EConstr.of_constr concl) (Goal.V82.extra sigma goal) in + let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in let sigma = Goal.V82.partial_solution_to sigma goal gl ev in sigma -- 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. --- plugins/decl_mode/decl_interp.ml | 2 +- plugins/decl_mode/decl_proof_instr.ml | 18 +++++++++--------- plugins/funind/glob_term_to_relation.ml | 9 ++++----- plugins/funind/merge.ml | 2 ++ plugins/funind/recdef.ml | 4 ++-- 5 files changed, 18 insertions(+), 17 deletions(-) (limited to 'plugins') diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml index ae057b4581..828d634d0c 100644 --- a/plugins/decl_mode/decl_interp.ml +++ b/plugins/decl_mode/decl_interp.ml @@ -316,7 +316,7 @@ let rec match_aliases names constr = function let args,bnames,body = match_aliases qnames body q in st::args,bnames,body -let detype_ground env c = Detyping.detype false [] env Evd.empty c +let detype_ground env c = Detyping.detype false [] env Evd.empty (EConstr.of_constr c) let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = let et,pinfo = diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index adc4ad8a33..4fe59d755e 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -440,7 +440,7 @@ let concl_refiner metas body gls = [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") | (n,typ)::rest -> let _A = subst_meta subst typ in - let x = id_of_name_using_hdchar env _A Anonymous in + let x = id_of_name_using_hdchar env evd (EConstr.of_constr _A) Anonymous in let _x = fresh_id avoid x gls in let nenv = Environ.push_named (LocalAssum (_x,_A)) env in let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) (EConstr.of_constr _A)) in @@ -895,7 +895,6 @@ let build_per_info etype casee gls = let ctyp=pf_unsafe_type_of gls (EConstr.of_constr casee) in let is_dep = dependent (project gls) (EConstr.of_constr casee) concl in let hd,args = decompose_app (special_whd gls ctyp) in - let ctyp = EConstr.Unsafe.to_constr ctyp in let (ind,u) = try destInd hd @@ -909,10 +908,11 @@ let build_per_info etype casee gls = let params,real_args = List.chop nparams args in let abstract_obj c body = let typ=pf_unsafe_type_of gls (EConstr.of_constr c) in - let typ = EConstr.Unsafe.to_constr typ in - lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in + lambda_create env (project gls) (typ,Termops.subst_term (project gls) (EConstr.of_constr c) body) in let pred= List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) concl)) in + real_args (lambda_create env (project gls) (ctyp,Termops.subst_term (project gls) (EConstr.of_constr casee) concl)) in + let ctyp = EConstr.Unsafe.to_constr ctyp in + let pred = EConstr.Unsafe.to_constr pred in is_dep, {per_casee=casee; per_ctype=ctyp; @@ -1275,16 +1275,15 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let env=pf_env gls in let ctyp=pf_unsafe_type_of gls (EConstr.of_constr casee) in let hd,all_args = decompose_app (special_whd gls ctyp) in - let ctyp = EConstr.Unsafe.to_constr ctyp in let ind', u = destInd hd in let _ = assert (eq_ind ind' ind) in (* just in case *) let params,real_args = List.chop nparams all_args in let abstract_obj c body = let typ=pf_unsafe_type_of gls (EConstr.of_constr c) in - let typ = EConstr.Unsafe.to_constr typ in - lambda_create env (typ,subst_term (project gls) (EConstr.of_constr c) (EConstr.of_constr body)) in + lambda_create env (project gls) (typ,Termops.subst_term (project gls) (EConstr.of_constr c) body) in let elim_pred = List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term (project gls) (EConstr.of_constr casee) concl)) in + real_args (lambda_create env (project gls) (ctyp,Termops.subst_term (project gls) (EConstr.of_constr casee) concl)) in + let elim_pred = EConstr.Unsafe.to_constr elim_pred in let case_info = Inductiveops.make_case_info env ind RegularStyle in let gen_arities = Inductive.arities_of_constructors (ind,u) spec in let f_ids typ = @@ -1345,6 +1344,7 @@ let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = let understand_my_constr env sigma c concl = let env = env in + let c = EConstr.of_constr c in let rawc = Detyping.detype false [] env Evd.empty c in let rec frob = function | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index fd2f4bbd37..63bd3848f6 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -421,7 +421,7 @@ let rec pattern_to_term_and_type env typ = function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] env (Evd.from_env env) csta.(i)) + (fun i -> Detyping.detype false [] env (Evd.from_env env) (EConstr.of_constr csta.(i))) ) in let patl_as_term = @@ -504,7 +504,6 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr rt_as_constr) in - let rt_typ = EConstr.Unsafe.to_constr rt_typ in let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in @@ -757,7 +756,6 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve let typ_of_id = Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in - let typ_of_id = EConstr.Unsafe.to_constr typ_of_id in let raw_typ_of_id = Detyping.detype false [] env_with_pat_ids (Evd.from_env env) typ_of_id @@ -804,6 +802,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in + let typ_as_constr = EConstr.of_constr typ_as_constr in let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right @@ -811,7 +810,6 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve if Id.Set.mem id this_pat_ids then (Prod (Name id), let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in - let typ_of_id = EConstr.Unsafe.to_constr typ_of_id in let raw_typ_of_id = Detyping.detype false [] new_env (Evd.from_env env) typ_of_id in @@ -970,7 +968,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (List.map (fun p -> Detyping.detype false [] env (Evd.from_env env) - p) params)@(Array.to_list + (EConstr.of_constr p)) params)@(Array.to_list (Array.make (List.length args' - nparam) (mkGHole ())))) @@ -988,6 +986,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let ty' = snd (Util.List.chop nparam ty) in List.fold_left2 (fun acc var_as_constr arg -> + let arg = EConstr.of_constr arg in if isRel var_as_constr then let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 691385fad0..44aacaf45e 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -777,6 +777,7 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let mkrawcor nme avoid typ = (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in + let substindtyp = EConstr.of_constr substindtyp in Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in @@ -860,6 +861,7 @@ let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with | LocalAssum (nme,t) -> + let t = EConstr.of_constr t in let traw = Detyping.detype false [] (Global.env()) Evd.empty t in GProd (Loc.ghost,nme,Explicit,traw,t2) | LocalDef _ -> assert false diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index f5ea32878c..2a66ba8523 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -122,8 +122,8 @@ let pf_get_new_ids idl g = [] let compute_renamed_type gls c = - EConstr.of_constr (rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] - (EConstr.Unsafe.to_constr (pf_unsafe_type_of gls c))) + rename_bound_vars_as_displayed (project gls) (*no avoid*) [] (*no rels*) [] + (pf_unsafe_type_of gls c) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" let ano_id = Id.of_string "anonymous" -- cgit v1.2.3 From 63ae87d51456add79652b42b972d6be93b6119bc Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Dec 2016 15:50:10 +0100 Subject: Fix a mishandled exception in Omega. Due to the introduction of the monadic layer, an exception was raised at a later time and not caught properly. --- plugins/omega/coq_omega.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'plugins') diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 8c2f0f53f4..72aeb9066d 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1859,7 +1859,9 @@ let destructure_goal = let decidability = Tacmach.New.of_old decidability gl in let rec loop t = Proofview.tclEVARMAP >>= fun sigma -> - match destructurate_prop sigma t with + let prop () = Proofview.tclUNIT (destructurate_prop sigma t) in + Proofview.V82.wrap_exceptions prop >>= fun prop -> + match prop with | Kapp(Not,[t]) -> (Tacticals.New.tclTHEN (Tacticals.New.tclTHEN (unfold sp_not) intro) -- cgit v1.2.3 From 3c1cd2338fcddc4a6c0e97b0af53eb2b2f238c4a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 15 Dec 2016 10:45:19 +0100 Subject: Removing most nf_enter in tactics. Now they are useless because all of the primitives are (should?) be evar-insensitive. --- plugins/cc/cctac.ml | 44 +++++++++++++++++++++++--------------------- plugins/omega/coq_omega.ml | 35 +++++++++++++++++++++-------------- 2 files changed, 44 insertions(+), 35 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 5d894c6774..c9c904e350 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -182,9 +182,10 @@ let litteral_of_constr env sigma term= (* store all equalities from the context *) let make_prb gls depth additionnal_terms = + let open Tacmach.New in let env=pf_env gls in - let sigma=sig_sig gls in - let state = empty depth gls in + let sigma=project gls in + let state = empty depth {it = Proofview.Goal.goal (Proofview.Goal.assume gls); sigma } in let pos_hyps = ref [] in let neg_hyps =ref [] in List.iter @@ -196,7 +197,7 @@ let make_prb gls depth additionnal_terms = let id = NamedDecl.get_id decl in begin let cid=Constr.mkVar id in - match litteral_of_constr env sigma (EConstr.of_constr (NamedDecl.get_type decl)) with + match litteral_of_constr env sigma (NamedDecl.get_type decl) with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b | `Other ph -> @@ -213,7 +214,7 @@ let make_prb gls depth additionnal_terms = neg_hyps:=(cid,nh):: !neg_hyps | `Rule patts -> add_quant state id true patts | `Nrule patts -> add_quant state id false patts - end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it)); + end) (Proofview.Goal.hyps gls); begin match atom_of_constr env sigma (pf_concl gls) with `Eq (t,a,b) -> add_disequality state Goal a b @@ -227,6 +228,7 @@ let make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) let build_projection intype (cstr:pconstructor) special default gls= + let open Tacmach.New in let ci= (snd(fst cstr)) in let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in @@ -266,7 +268,7 @@ let refresh_universes ty k = let constr_of_term c = EConstr.of_constr (constr_of_term c) let rec proof_tac p : unit Proofview.tactic = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let type_of t = Tacmach.New.pf_unsafe_type_of gl t in try (* type_of can raise exceptions *) match p.p_rule with @@ -296,7 +298,7 @@ let rec proof_tac p : unit Proofview.tactic = refresh_universes (type_of tf1) (fun typf -> refresh_universes (type_of tx1) (fun typx -> refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> - let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in + let id = Tacmach.New.pf_get_new_id (Id.of_string "f") gl in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in let lemma1 = app_global _f_equal [|typf;typfx;appx1;tf1;tf2;_M 1|] in let lemma2 = app_global _f_equal [|typx;typfx;tf2;tx1;tx2;_M 1|] in @@ -322,7 +324,7 @@ let rec proof_tac p : unit Proofview.tactic = refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> let proj = - Tacmach.New.of_old (build_projection intype cstr special default) gl + build_projection intype cstr special default gl in let injt= app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in @@ -331,9 +333,9 @@ let rec proof_tac p : unit Proofview.tactic = end } let refute_tac c t1 t2 p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in - let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in + let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in let false_t=mkApp (c,[|mkVar hid|]) in let k intype = let neweq= new_app_global _eq [|intype;tt1;tt2|] in @@ -347,12 +349,12 @@ let refine_exact_check c gl = Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl let convert_to_goal_tac c t1 t2 p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let k sort = let neweq= new_app_global _eq [|sort;tt1;tt2|] in - let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in - let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in + let e = Tacmach.New.pf_get_new_id (Id.of_string "e") gl in + let x = Tacmach.New.pf_get_new_id (Id.of_string "X") gl in let identity=mkLambda (Name x,sort,mkRel 1) in let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) @@ -361,9 +363,9 @@ let convert_to_goal_tac c t1 t2 p = end } let convert_to_hyp_tac c1 t1 c2 t2 p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let tt2=constr_of_term t2 in - let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in + let h = Tacmach.New.pf_get_new_id (Id.of_string "H") gl in let false_t=mkApp (c2,[|mkVar h|]) in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; @@ -371,11 +373,11 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = end } let discriminate_tac (cstr,u as cstru) p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in + let xid = Tacmach.New.pf_get_new_id (Id.of_string "X") gl in let identity = Universes.constr_of_global (Lazy.force _I) in let identity = EConstr.of_constr identity in let trivial = Universes.constr_of_global (Lazy.force _True) in @@ -385,8 +387,8 @@ let discriminate_tac (cstr,u as cstru) p = let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in - let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in - let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in + let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in + let proj = build_projection intype cstru trivial concl gl in let injt=app_global _f_equal [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = @@ -409,11 +411,11 @@ let build_term_to_complete uf meta pac = applist (mkConstructU cinfo.ci_constr, all_args) let cc_tactic depth additionnal_terms = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in Coqlib.check_required_library Coqlib.logic_module_name; let _ = debug (fun () -> Pp.str "Reading subgoal ...") in - let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in + let state = make_prb gl depth additionnal_terms in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in let _ = debug (fun () -> Pp.str "Computation completed.") in @@ -498,7 +500,7 @@ let mk_eq f c1 c2 k = end }) let f_equal = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let cut_eq c1 c2 = diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 72aeb9066d..adf9269587 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -38,7 +38,7 @@ open OmegaSolver (* Added by JCF, 09/03/98 *) let elim_id id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> simplest_elim (Tacmach.New.pf_global id gl) end } let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl @@ -1391,7 +1391,10 @@ let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = else (tactic,defs) +let pf_nf gl c = Tacmach.New.pf_apply Tacred.simpl gl c + let destructure_omega gl tac_def (id,c) = + let open Tacmach.New in let sigma = project gl in if String.equal (atompart_of_id id) "State" then tac_def @@ -1433,10 +1436,10 @@ let reintroduce id = open Proofview.Notations let coq_omega = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in - let destructure_omega = Tacmach.New.of_old destructure_omega gl in + let destructure_omega = destructure_omega gl in let tactic_normalisation, system = List.fold_left destructure_omega ([],[]) hyps_types in let prelude,sys = @@ -1486,7 +1489,7 @@ let coq_omega = let coq_omega = coq_omega let nat_inject = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in let rec explore p t : unit Proofview.tactic = Proofview.tclEVARMAP >>= fun sigma -> @@ -1657,6 +1660,7 @@ let not_binop = function exception Undecidable let rec decidability gl t = + let open Tacmach.New in match destructurate_prop (project gl) t with | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; @@ -1687,22 +1691,25 @@ let rec decidability gl t = | Kapp(True,[]) -> Lazy.force coq_dec_True | _ -> raise Undecidable +let fresh_id avoid id gl = + fresh_id_in_env avoid id (Proofview.Goal.env gl) + let onClearedName id tac = (* We cannot ensure that hyps can be cleared (because of dependencies), *) (* so renaming may be necessary *) Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) - (Proofview.Goal.nf_enter { enter = begin fun gl -> - let id = Tacmach.New.of_old (fresh_id [] id) gl in + (Proofview.Goal.enter { enter = begin fun gl -> + let id = fresh_id [] id gl in Tacticals.New.tclTHEN (introduction id) (tac id) end }) let onClearedName2 id tac = Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) - (Proofview.Goal.nf_enter { enter = begin fun gl -> - let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in - let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in + (Proofview.Goal.enter { enter = begin fun gl -> + let id1 = fresh_id [] (add_suffix id "_left") gl in + let id2 = fresh_id [] (add_suffix id "_right") gl in Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end }) @@ -1712,10 +1719,10 @@ let rec is_Prop sigma c = match EConstr.kind sigma c with | _ -> false let destructure_hyps = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - let decidability = Tacmach.New.of_old decidability gl in - let pf_nf = Tacmach.New.of_old pf_nf gl in + let decidability = decidability gl in + let pf_nf = pf_nf gl in let rec loop = function | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) | decl::lit -> @@ -1854,9 +1861,9 @@ let destructure_hyps = end } let destructure_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in - let decidability = Tacmach.New.of_old decidability gl in + let decidability = decidability gl in let rec loop t = Proofview.tclEVARMAP >>= fun sigma -> let prop () = Proofview.tclUNIT (destructurate_prop sigma t) 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. --- plugins/quote/quote.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'plugins') diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index edf34607bb..23069a9abc 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -214,9 +214,9 @@ let compute_rhs env sigma bodyi index_of_f = let i = destRel sigma (Array.last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> - PApp (pattern_of_constr env sigma f, Array.map aux args) + PApp (pattern_of_constr env sigma (EConstr.to_constr sigma f), Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> pattern_of_constr env sigma c + | _ -> pattern_of_constr env sigma (EConstr.to_constr sigma c) in aux bodyi -- cgit v1.2.3 From cca57bcd89770e76e1bcc21eb41756dca2c51425 Mon Sep 17 00:00:00 2001 From: Enrico Tassi Date: Thu, 9 Feb 2017 18:53:53 +0100 Subject: Porting the ssrmatching plugin to the new EConstr API. --- plugins/ssrmatching/ssrmatching.ml4 | 62 ++++++++++++++++++++----------------- plugins/ssrmatching/ssrmatching.mli | 6 ++-- 2 files changed, 36 insertions(+), 32 deletions(-) (limited to 'plugins') diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index d4579c3a19..c40a1a9d9b 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -301,14 +301,14 @@ let unif_EQ_args env sigma pa a = prof_unif_eq_args.profile (unif_EQ_args env sigma pa) a ;; -let unif_HO env ise p c = Evarconv.the_conv_x env (EConstr.of_constr p) (EConstr.of_constr c) ise +let unif_HO env ise p c = Evarconv.the_conv_x env p c ise -let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env (EConstr.of_constr p) (EConstr.of_constr c) ise +let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise let unif_HO_args env ise0 pa i ca = let n = Array.length pa in let rec loop ise j = - if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in + if j = n then ise else loop (unif_HO env ise (EConstr.of_constr pa.(j)) (EConstr.of_constr ca.(i + j))) (j + 1) in loop ise0 0 (* FO unification should boil down to calling w_unify with no_delta, but *) @@ -339,6 +339,7 @@ let unif_FO env ise p c = (* Perform evar substitution in main term and prune substitution. *) let nf_open_term sigma0 ise c = + let c = EConstr.Unsafe.to_constr c in let s = ise and s' = ref sigma0 in let rec nf c' = match kind_of_term c' with | Evar ex -> @@ -355,7 +356,7 @@ let nf_open_term sigma0 ise c = | Evar_defined c' -> s' := Evd.define k (nf c') !s' | _ -> () in let c' = nf c in let _ = Evd.fold copy_def sigma0 () in - !s', Evd.evar_universe_context s, c' + !s', Evd.evar_universe_context s, EConstr.of_constr c' let unif_end env sigma0 ise0 pt ok = let ise = Evarconv.consider_remaining_unif_problems env ise0 in @@ -429,7 +430,7 @@ type tpattern = { up_a : constr array; up_t : constr; (* equation proof term or matched term *) up_dir : ssrdir; (* direction of the rule *) - up_ok : constr -> evar_map -> bool; (* progess test for rewrite *) + up_ok : constr -> evar_map -> bool; (* progress test for rewrite *) } let all_ok _ _ = true @@ -632,13 +633,14 @@ let match_upats_FO upats env sigma0 ise orig_c = | _ -> unif_FO env ise u.up_FO c' in let ise' = (* Unify again using HO to assign evars *) let p = mkApp (u.up_f, u.up_a) in - try unif_HO env ise p c' with _ -> raise NoMatch in + try unif_HO env ise (EConstr.of_constr p) (EConstr.of_constr c') with e when CErrors.noncritical e -> raise NoMatch in let lhs = mkSubApp f i a in - let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in + let pt' = unif_end env sigma0 ise' (EConstr.of_constr u.up_t) (u.up_ok lhs) in + let pt' = pi1 pt', pi2 pt', EConstr.Unsafe.to_constr (pi3 pt') in raise (FoundUnif (ungen_upat lhs pt' u)) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO") - | _ -> () in + | e when CErrors.noncritical e -> () in List.iter one_match fpats done; iter_constr_LR loop f; Array.iter loop a in @@ -651,7 +653,7 @@ let match_upats_FO upats env sigma0 ise c = let match_upats_HO ~on_instance upats env sigma0 ise c = - let dont_impact_evars = dont_impact_evars_in c in + let dont_impact_evars = dont_impact_evars_in c in let it_did_match = ref false in let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = @@ -673,16 +675,17 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = | KpatLet -> let x, v, t, b = destLetIn f in let _, pv, _, pb = destLetIn u.up_f in - let ise' = unif_HO env ise pv v in + let ise' = unif_HO env ise (EConstr.of_constr pv) (EConstr.of_constr v) in unif_HO (Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env) - ise' pb b + ise' (EConstr.of_constr pb) (EConstr.of_constr b) | KpatFlex | KpatProj _ -> - unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a) - | _ -> unif_HO env ise u.up_f f in + unif_HO env ise (EConstr.of_constr u.up_f) (EConstr.of_constr(mkSubApp f (i - Array.length u.up_a) a)) + | _ -> unif_HO env ise (EConstr.of_constr u.up_f) (EConstr.of_constr f) in let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in let lhs = mkSubApp f i a in - let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in + let pt' = unif_end env sigma0 ise'' (EConstr.of_constr u.up_t) (u.up_ok lhs) in + let pt' = pi1 pt', pi2 pt', EConstr.Unsafe.to_constr (pi3 pt') in on_instance (ungen_upat lhs pt' u) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u | NoProgress -> it_did_match := true @@ -721,13 +724,13 @@ let assert_done_multires r = r := Some (n+1,xs); try List.nth xs n with Failure _ -> raise NoMatch -type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr +type subst = Environ.env -> constr -> constr -> int -> constr type find_P = - Environ.env -> Term.constr -> int -> + Environ.env -> constr -> int -> k:subst -> - Term.constr + constr type conclude = unit -> - Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr) + constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * constr) (* upats_origin makes a better error message only *) let mk_tpattern_matcher ?(all_instances=false) @@ -897,7 +900,7 @@ let pr_pattern_aux pr_constr = function | E_As_X_In_T (e,x,t) -> pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern (sigma, p) = - pr_pattern_aux (fun t -> pr_constr_pat (pi3 (nf_open_term sigma sigma t))) p + pr_pattern_aux (fun t -> pr_constr_pat (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p let pr_cpattern = pr_term let pr_rpattern _ _ _ = pr_pattern @@ -1001,7 +1004,7 @@ type occ = (bool * int list) option type rpattern = (cpattern, cpattern) ssrpattern let pr_rpattern = pr_pattern -type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern +type pattern = Evd.evar_map * (constr, constr) ssrpattern let id_of_cpattern = function @@ -1260,7 +1263,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in let concl = find_T env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let p_sigma = unify_HO env (create_evar_defs sigma) (EConstr.of_constr c) (EConstr.of_constr p) in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env _ -> do_subst env e_body))) in @@ -1276,7 +1279,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in let concl = find_T env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let p_sigma = unify_HO env (create_evar_defs sigma) (EConstr.of_constr c) (EConstr.of_constr p) in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> find_E env e_body h do_subst))) in @@ -1286,17 +1289,17 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let p, e = fs sigma p, fs sigma e in let ex = ex_value hole in let rp = - let e_sigma = unify_HO env0 sigma hole e in + let e_sigma = unify_HO env0 sigma (EConstr.of_constr hole) (EConstr.of_constr e) in e_sigma, fs e_sigma p in let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in let find_X, end_X = mk_tpattern_matcher sigma occ holep in let concl = find_TE env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let p_sigma = unify_HO env (create_evar_defs sigma) (EConstr.of_constr c) (EConstr.of_constr p) in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> - let e_sigma = unify_HO env sigma e_body e in + let e_sigma = unify_HO env sigma (EConstr.of_constr e_body) (EConstr.of_constr e) in let e_body = fs e_sigma e in do_subst env e_body e_body h))) in let _ = end_X () in let _ = end_TE () in @@ -1332,13 +1335,15 @@ let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = ;; let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = + let p = EConstr.Unsafe.to_constr p in + let concl = EConstr.Unsafe.to_constr concl in let ise = create_evar_defs sigma in - let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in + let ise, u = mk_tpattern env sigma0 (ise,EConstr.Unsafe.to_constr t) ok L2R p in let find_U, end_U = mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in let concl = find_U env concl h (fun _ _ _ -> mkRel) in let rdx, _, (sigma, uc, p) = end_U () in - sigma, uc, p, concl, rdx + sigma, uc, EConstr.of_constr p, EConstr.of_constr concl, EConstr.of_constr rdx let fill_occ_term env cl occ sigma0 (sigma, t) = try @@ -1351,12 +1356,11 @@ let fill_occ_term env cl occ sigma0 (sigma, t) = if sigma' != sigma0 then raise NoMatch else cl, (Evd.merge_universe_context sigma' uc, t') with _ -> - errorstrm (str "partial term " ++ pr_constr_pat t + errorstrm (str "partial term " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = let sigma0 = project gl and env = pf_env gl and concl = pf_concl gl in - let concl = EConstr.Unsafe.to_constr concl in let cl,(_,t) = fill_occ_term env concl occ sigma0 t in cl, t diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 74a603e51c..fa0c2f5b10 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -194,7 +194,7 @@ val mk_tpattern_matcher : (* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns * the conclusion of [gl] where [occ] occurrences of [t] have been replaced * by [Rel 1] and the instance of [t] *) -val pf_fill_occ_term : goal sigma -> occ -> evar_map * constr -> constr * constr +val pf_fill_occ_term : goal sigma -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t (* It may be handy to inject a simple term into the first form of cpattern *) val cpattern_of_term : char * glob_constr_and_expr -> cpattern @@ -216,8 +216,8 @@ val assert_done : 'a option ref -> 'a [consider_remaining_unif_problems] and [resolve_typeclasses]. In case of failure they raise [NoMatch] *) -val unify_HO : env -> evar_map -> constr -> constr -> evar_map -val pf_unify_HO : goal sigma -> constr -> constr -> goal sigma +val unify_HO : env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map +val pf_unify_HO : goal sigma -> EConstr.constr -> EConstr.constr -> goal sigma (** Some more low level functions needed to implement the full SSR language on top of the former APIs *) -- 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. --- plugins/ltac/rewrite.ml | 2 +- plugins/ltac/taccoerce.ml | 2 +- plugins/omega/coq_omega.ml | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) (limited to 'plugins') diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml index 55172cba6a..b84be4600c 100644 --- a/plugins/ltac/rewrite.ml +++ b/plugins/ltac/rewrite.ml @@ -434,7 +434,7 @@ module TypeGlobal = struct end let sort_of_rel env evm rel = - Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel) + ESorts.kind evm (Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel)) let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 114b8dda04..95620b3747 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -164,7 +164,7 @@ let id_of_name = function basename | Sort s -> begin - match s with + match ESorts.kind sigma s with | Prop _ -> Label.to_id (Label.make "Prop") | Type _ -> Label.to_id (Label.make "Type") end diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index adf9269587..a2016cb038 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1714,7 +1714,7 @@ let onClearedName2 id tac = end }) let rec is_Prop sigma c = match EConstr.kind sigma c with - | Sort (Prop Null) -> true + | Sort s -> Sorts.is_prop (ESorts.kind sigma s) | Cast (c,_,_) -> is_Prop sigma c | _ -> false -- 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. --- plugins/cc/cctac.ml | 6 +++++- plugins/firstorder/formula.ml | 6 +++++- plugins/funind/functional_principles_types.ml | 3 ++- plugins/funind/glob_term_to_relation.ml | 5 +++-- plugins/funind/indfun.ml | 11 ++++++++--- plugins/funind/invfun.ml | 5 +++-- plugins/funind/merge.ml | 7 ++++--- plugins/funind/recdef.ml | 5 +++-- plugins/ltac/extratactics.ml4 | 2 +- plugins/ltac/taccoerce.ml | 2 +- plugins/quote/quote.ml | 5 +++-- 11 files changed, 38 insertions(+), 19 deletions(-) (limited to 'plugins') diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index c9c904e350..2d9dec095a 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -66,6 +66,7 @@ let rec decompose_term env sigma t= decompose_term env sigma b) | Construct c -> let (((mind,i_ind),i_con),u)= c in + let u = EInstance.kind sigma u in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in @@ -75,9 +76,11 @@ let rec decompose_term env sigma t= ci_nhyps=nargs-oib.mind_nparams} | Ind c -> let (mind,i_ind),u = c in + let u = EInstance.kind sigma u in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in (Symb (Constr.mkIndU (canon_ind,u))) | Const (c,u) -> + let u = EInstance.kind sigma u in let canon_const = constant_of_kn (canonical_con c) in (Symb (Constr.mkConstU (canon_const,u))) | Proj (p, c) -> @@ -408,7 +411,8 @@ let build_term_to_complete uf meta pac = let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in let dummy_args = List.rev (List.init pac.arity meta) in let all_args = List.rev_append real_args dummy_args in - applist (mkConstructU cinfo.ci_constr, all_args) + let (kn, u) = cinfo.ci_constr in + applist (mkConstructU (kn, EInstance.make u), all_args) let cc_tactic depth additionnal_terms = Proofview.Goal.enter { enter = begin fun gl -> diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index 87bac2fe39..7773f6a2fd 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -91,6 +91,7 @@ let kind_of_formula gl term = Some (i,l,n)-> let l = List.map EConstr.Unsafe.to_constr l in let ind,u=EConstr.destInd (project gl) i in + let u = EConstr.EInstance.kind (project gl) u in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in if Int.equal nconstr 0 then @@ -112,7 +113,10 @@ let kind_of_formula gl term = Or((ind,u),l,is_trivial) | _ -> match match_with_sigma_type (project gl) (EConstr.of_constr cciterm) with - Some (i,l)-> Exists((EConstr.destInd (project gl) i),List.map EConstr.Unsafe.to_constr l) + Some (i,l)-> + let (ind, u) = EConstr.destInd (project gl) i in + let u = EConstr.EInstance.kind (project gl) u in + Exists((ind, u), List.map EConstr.Unsafe.to_constr l) |_-> Atom (normalize cciterm) type atoms = {positive:constr list;negative:constr list} diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index e845db3bc3..529b91c4ca 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -300,7 +300,8 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin hook ; (* let _tim1 = System.get_time () in *) - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map EConstr.mkConstU funs) mutr_nparams))); + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams))); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index 63bd3848f6..8aab3b7429 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -1275,8 +1275,9 @@ let do_build_inductive let open Context.Named.Declaration in let evd,env = Array.fold_right2 - (fun id c (evd,env) -> - let evd,t = Typing.type_of env evd (EConstr.mkConstU c) in + (fun id (c, u) (evd,env) -> + let u = EConstr.EInstance.make u in + let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in let t = EConstr.Unsafe.to_constr t in evd, Environ.push_named (LocalAssum (id,t)) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index a7489fb7b4..2852152e13 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -249,7 +249,8 @@ let derive_inversion fix_names = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in let c = EConstr.of_constr c in - evd, destConst evd c::l + let (cst, u) = destConst evd c in + evd, (cst, EInstance.kind evd u) :: l ) fix_names (evd',[]) @@ -412,7 +413,9 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in let c = EConstr.of_constr c in - evd,((destConst evd c)::l) + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl @@ -427,7 +430,9 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in let c = EConstr.of_constr c in - evd,((destConst evd c)::l) + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index 2c2cd919b1..94ec0a898a 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -783,7 +783,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in - let funs_constr = Array.map mkConstU funs in + let map (c, u) = mkConstU (c, EInstance.make u) in + let funs_constr = Array.map map funs in States.with_state_protection_on_exception (fun () -> let env = Global.env () in @@ -882,7 +883,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( (Indrec.build_mutual_induction_scheme (Global.env ()) !evd (Array.to_list (Array.mapi - (fun i _ -> ((kn,i),u(* Univ.Instance.empty *)),true,InType) + (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType) mib.Declarations.mind_packets ) ) diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 44aacaf45e..c0298d06cd 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -136,13 +136,14 @@ let prNamedRLDecl s lc = let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in - let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty (EConstr.of_constr cstrid) in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in + let (ind1, u),cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty (EConstr.of_constr cstrid) in + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in + let u = EConstr.Unsafe.to_instance u in List.iter (fun decl -> print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); prconstr (RelDecl.get_type decl); print_string "\n") ib1.mind_arity_ctxt; - Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); + Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) (ind1, u)); Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index 0a288c76e1..5460d6fb73 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -86,9 +86,10 @@ let def_of_const t = let type_of_const sigma t = match (EConstr.kind sigma t) with - | Const sp -> + | Const (sp, u) -> + let u = EInstance.kind sigma u in (* FIXME discarding universe constraints *) - Typeops.type_of_constant_in (Global.env()) sp + Typeops.type_of_constant_in (Global.env()) (sp, u) |_ -> assert false let constr_of_global x = diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index 55108631bd..b34afd51bd 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -1073,7 +1073,7 @@ let decompose l c = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let to_ind c = - if isInd sigma c then Univ.out_punivs (destInd sigma c) + if isInd sigma c then fst (destInd sigma c) else error "not an inductive type" in let l = List.map to_ind l in diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml index 95620b3747..b76009c997 100644 --- a/plugins/ltac/taccoerce.ml +++ b/plugins/ltac/taccoerce.ml @@ -255,7 +255,7 @@ let coerce_to_evaluable_ref env sigma v = | IndRef _ | ConstructRef _ -> fail () else match Value.to_constr v with - | Some c when isConst sigma c -> EvalConstRef (Univ.out_punivs (destConst sigma c)) + | Some c when isConst sigma c -> EvalConstRef (fst (destConst sigma c)) | Some c when isVar sigma c -> EvalVarRef (destVar sigma c) | _ -> fail () in if Tacred.is_evaluable env ev then ev else fail () diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 23069a9abc..fc9d70ae7d 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -225,8 +225,9 @@ let compute_rhs env sigma bodyi index_of_f = let compute_ivs f cs gl = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let cst = try destConst sigma f with DestKO -> i_can't_do_that () in - let body = Environ.constant_value_in (Global.env()) cst in + let (cst, u) = try destConst sigma f with DestKO -> i_can't_do_that () in + let u = EInstance.kind sigma u in + let body = Environ.constant_value_in (Global.env()) (cst, u) in let body = EConstr.of_constr body in match decomp_term sigma body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> -- 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. --- plugins/ltac/extratactics.ml4 | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) (limited to 'plugins') diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 index b34afd51bd..1ec52718a5 100644 --- a/plugins/ltac/extratactics.ml4 +++ b/plugins/ltac/extratactics.ml4 @@ -1087,10 +1087,14 @@ END (** library/keys *) VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF -| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ - let it c = EConstr.Unsafe.to_constr (snd (Constrintern.interp_open_constr (Global.env ()) Evd.empty c)) in - let k1 = Keys.constr_key (it c) in - let k2 = Keys.constr_key (it c') in +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ + let get_key c = + let (evd, c) = Constrintern.interp_open_constr (Global.env ()) Evd.empty c in + let kind c = EConstr.kind evd c in + Keys.constr_key kind c + in + let k1 = get_key c in + let k2 = get_key c' in match k1, k2 with | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 | _ -> () ] -- cgit v1.2.3 From 2ba1351849550c50e0fe2c7fc7f63758c10fb14a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 7 Apr 2017 16:31:25 +0200 Subject: Fix an unhandled exception in Omega. --- plugins/omega/coq_omega.ml | 1 + 1 file changed, 1 insertion(+) (limited to 'plugins') diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index a2016cb038..7780de7127 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -1884,6 +1884,7 @@ let destructure_goal = (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))) intro with Undecidable -> Tactics.elim_type (Lazy.force coq_False) + | e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Tacticals.New.tclTHEN goal_tac destructure_hyps in -- cgit v1.2.3