aboutsummaryrefslogtreecommitdiffhomepage
path: root/plugins/funind/indfun.ml
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/funind/indfun.ml')
-rw-r--r--plugins/funind/indfun.ml55
1 files changed, 35 insertions, 20 deletions
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index d394fe313..ebeddf5f6 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
@@ -14,37 +15,39 @@ 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
+ 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
)
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 =
- 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
@@ -72,15 +75,17 @@ 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' princ,g')
+ let princ = EConstr.of_constr princ in
+ (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,Tacmach.pf_unsafe_type_of g princ,g
in
- let princ_infos = Tactics.compute_elim_sig 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 =
if princ_infos.Tactics.farg_in_concl
@@ -94,7 +99,7 @@ let functional_induction with_clean c princl pat =
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
@@ -245,7 +250,9 @@ 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
+ let (cst, u) = destConst evd c in
+ evd, (cst, EInstance.kind evd u) :: l
)
fix_names
(evd',[])
@@ -265,7 +272,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',[])
@@ -332,7 +340,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
@@ -370,7 +378,8 @@ 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
+ let princ_type = EConstr.Unsafe.to_constr princ_type in
Functional_principles_types.generate_functional_principle
evd
interactive_proof
@@ -405,7 +414,10 @@ 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
+ 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
@@ -419,7 +431,10 @@ 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
+ 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
@@ -429,7 +444,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
@@ -837,7 +852,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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-21 04:44:54 +0000