summaryrefslogtreecommitdiff
path: root/plugins/firstorder/formula.ml
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/firstorder/formula.ml')
-rw-r--r--plugins/firstorder/formula.ml123
1 files changed, 66 insertions, 57 deletions
diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml
index 58744b57..047fc9fb 100644
--- a/plugins/firstorder/formula.ml
+++ b/plugins/firstorder/formula.ml
@@ -1,21 +1,24 @@
(************************************************************************)
-(* v * The Coq Proof Assistant / The Coq Development Team *)
-(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *)
+(* * The Coq Proof Assistant / The Coq Development Team *)
+(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *)
+(* <O___,, * (see CREDITS file for the list of authors) *)
(* \VV/ **************************************************************)
-(* // * This file is distributed under the terms of the *)
-(* * GNU Lesser General Public License Version 2.1 *)
+(* // * This file is distributed under the terms of the *)
+(* * GNU Lesser General Public License Version 2.1 *)
+(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
open Hipattern
open Names
-open Term
+open Constr
+open EConstr
open Vars
open Termops
-open Tacmach
open Util
open Declarations
open Globnames
-open Context.Rel.Declaration
+
+module RelDecl = Context.Rel.Declaration
let qflag=ref true
@@ -38,33 +41,33 @@ exception Is_atom of constr
let meta_succ m = m+1
let rec nb_prod_after n c=
- match kind_of_term c with
+ match Constr.kind c with
| Prod (_,_,b) ->if n>0 then nb_prod_after (n-1) b else
1+(nb_prod_after 0 b)
| _ -> 0
-let construct_nhyps ind gls =
+let construct_nhyps env ind =
let nparams = (fst (Global.lookup_inductive (fst ind))).mind_nparams in
- let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in
+ let constr_types = Inductiveops.arities_of_constructors env ind in
let hyp = nb_prod_after nparams in
Array.map hyp constr_types
(* indhyps builds the array of arrays of constructor hyps for (ind largs)*)
-let ind_hyps nevar ind largs gls=
- let types= Inductiveops.arities_of_constructors (pf_env gls) ind in
+let ind_hyps env sigma nevar ind largs =
+ let types= Inductiveops.arities_of_constructors env ind in
let myhyps t =
- let t1=prod_applist t largs in
- let t2=snd (decompose_prod_n_assum nevar t1) in
- fst (decompose_prod_assum t2) in
+ let t = EConstr.of_constr t in
+ let nparam_decls = Context.Rel.length (fst (Global.lookup_inductive (fst ind))).mind_params_ctxt in
+ let t1=Termops.prod_applist_assum sigma nparam_decls t largs in
+ let t2=snd (decompose_prod_n_assum sigma nevar t1) in
+ fst (decompose_prod_assum sigma t2) in
Array.map myhyps types
-let special_nf gl=
- let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in
- (fun t -> CClosure.norm_val infos (CClosure.inject t))
+let special_nf env sigma t =
+ Reductionops.clos_norm_flags !red_flags env sigma t
-let special_whd gl=
- let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in
- (fun t -> CClosure.whd_val infos (CClosure.inject t))
+let special_whd env sigma t =
+ Reductionops.clos_whd_flags !red_flags env sigma t
type kind_of_formula=
Arrow of constr*constr
@@ -75,18 +78,21 @@ type kind_of_formula=
| Forall of constr*constr
| Atom of constr
-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))
+let pop t = Vars.lift (-1) t
+
+let kind_of_formula env sigma term =
+ let normalize = special_nf env sigma in
+ let cciterm = special_whd env sigma term in
+ match match_with_imp_term sigma cciterm with
+ Some (a,b)-> Arrow (a, pop b)
|_->
- match match_with_forall_term cciterm with
- Some (_,a,b)-> Forall(a,b)
+ match match_with_forall_term sigma cciterm with
+ Some (_,a,b)-> Forall (a, b)
|_->
- match match_with_nodep_ind cciterm with
+ match match_with_nodep_ind sigma cciterm with
Some (i,l,n)->
- let ind,u=destInd i in
+ let ind,u=EConstr.destInd sigma i in
+ let u = EConstr.EInstance.kind sigma u in
let (mib,mip) = Global.lookup_inductive ind in
let nconstr=Array.length mip.mind_consnames in
if Int.equal nconstr 0 then
@@ -95,7 +101,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 sigma (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)
@@ -107,8 +113,11 @@ let kind_of_formula gl term =
else
Or((ind,u),l,is_trivial)
| _ ->
- match match_with_sigma_type cciterm with
- Some (i,l)-> Exists((destInd i),l)
+ match match_with_sigma_type sigma cciterm with
+ Some (i,l)->
+ let (ind, u) = EConstr.destInd sigma i in
+ let u = EConstr.EInstance.kind sigma u in
+ Exists((ind, u), l)
|_-> Atom (normalize cciterm)
type atoms = {positive:constr list;negative:constr list}
@@ -119,29 +128,29 @@ let no_atoms = (false,{positive=[];negative=[]})
let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *)
-let build_atoms gl metagen side cciterm =
+let build_atoms env sigma metagen side cciterm =
let trivial =ref false
and positive=ref []
and negative=ref [] in
- let normalize=special_nf gl in
- let rec build_rec env polarity cciterm=
- match kind_of_formula gl cciterm with
+ let normalize=special_nf env sigma in
+ let rec build_rec subst polarity cciterm=
+ match kind_of_formula env sigma cciterm with
False(_,_)->if not polarity then trivial:=true
| Arrow (a,b)->
- build_rec env (not polarity) a;
- build_rec env polarity b
+ build_rec subst (not polarity) a;
+ build_rec subst polarity b
| And(i,l,b) | Or(i,l,b)->
if b then
begin
- let unsigned=normalize (substnl env 0 cciterm) in
+ let unsigned=normalize (substnl subst 0 cciterm) in
if polarity then
positive:= unsigned :: !positive
else
negative:= unsigned :: !negative
end;
- let v = ind_hyps 0 i l gl in
+ let v = ind_hyps env sigma 0 i l in
let g i _ decl =
- build_rec env polarity (lift i (get_type decl)) in
+ build_rec subst polarity (lift i (RelDecl.get_type decl)) in
let f l =
List.fold_left_i g (1-(List.length l)) () l in
if polarity && (* we have a constant constructor *)
@@ -150,16 +159,16 @@ let build_atoms gl metagen side cciterm =
Array.iter f v
| Exists(i,l)->
let var=mkMeta (metagen true) in
- let v =(ind_hyps 1 i l gl).(0) in
+ let v =(ind_hyps env sigma 1 i l).(0) in
let g i _ decl =
- build_rec (var::env) polarity (lift i (get_type decl)) in
+ build_rec (var::subst) polarity (lift i (RelDecl.get_type decl)) in
List.fold_left_i g (2-(List.length l)) () v
| Forall(_,b)->
let var=mkMeta (metagen true) in
- build_rec (var::env) polarity b
+ build_rec (var::subst) polarity b
| Atom t->
- let unsigned=substnl env 0 t in
- if not (isMeta unsigned) then (* discarding wildcard atoms *)
+ let unsigned=substnl subst 0 t in
+ if not (isMeta sigma unsigned) then (* discarding wildcard atoms *)
if polarity then
positive:= unsigned :: !positive
else
@@ -169,9 +178,9 @@ let build_atoms gl metagen side cciterm =
Concl -> build_rec [] true cciterm
| Hyp -> build_rec [] false cciterm
| Hint ->
- let rels,head=decompose_prod cciterm in
- let env=List.rev_map (fun _->mkMeta (metagen true)) rels in
- build_rec env false head;trivial:=false (* special for hints *)
+ let rels,head=decompose_prod sigma cciterm in
+ let subst=List.rev_map (fun _->mkMeta (metagen true)) rels in
+ build_rec subst false head;trivial:=false (* special for hints *)
end;
(!trivial,
{positive= !positive;
@@ -207,32 +216,32 @@ type t={id:global_reference;
pat:(left_pattern,right_pattern) sum;
atoms:atoms}
-let build_formula side nam typ gl metagen=
- let normalize = special_nf gl in
+let build_formula env sigma side nam typ metagen=
+ let normalize = special_nf env sigma in
try
let m=meta_succ(metagen false) in
let trivial,atoms=
if !qflag then
- build_atoms gl metagen side typ
+ build_atoms env sigma metagen side typ
else no_atoms in
let pattern=
match side with
Concl ->
let pat=
- match kind_of_formula gl typ with
+ match kind_of_formula env sigma typ with
False(_,_) -> Rfalse
| Atom a -> raise (Is_atom a)
| And(_,_,_) -> Rand
| Or(_,_,_) -> Ror
| Exists (i,l) ->
- let d = get_type (List.last (ind_hyps 0 i l gl).(0)) in
+ let d = RelDecl.get_type (List.last (ind_hyps env sigma 0 i l).(0)) in
Rexists(m,d,trivial)
| Forall (_,a) -> Rforall
| Arrow (a,b) -> Rarrow in
Right pat
| _ ->
let pat=
- match kind_of_formula gl typ with
+ match kind_of_formula env sigma typ with
False(i,_) -> Lfalse
| Atom a -> raise (Is_atom a)
| And(i,_,b) ->
@@ -249,7 +258,7 @@ let build_formula side nam typ gl metagen=
| Arrow (a,b) ->
let nfa=normalize a in
LA (nfa,
- match kind_of_formula gl a with
+ match kind_of_formula env sigma a with
False(i,l)-> LLfalse(i,l)
| Atom t-> LLatom
| And(i,l,_)-> LLand(i,l)
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-07 10:48:39 +0000