aboutsummaryrefslogtreecommitdiffhomepage
path: root/plugins
diff options
context:
space:
mode:
Diffstat (limited to 'plugins')
-rw-r--r--plugins/cc/ccalgo.ml48
-rw-r--r--plugins/funind/functional_principles_types.ml7
-rw-r--r--plugins/funind/glob_term_to_relation.ml4
-rw-r--r--plugins/funind/indfun.ml15
-rw-r--r--plugins/funind/invfun.ml2
-rw-r--r--plugins/ltac/pltac.mli2
-rw-r--r--plugins/ltac/pptactic.mli2
-rw-r--r--plugins/ltac/tacarg.mli6
-rw-r--r--plugins/ltac/tacexpr.ml18
-rw-r--r--plugins/ltac/tacexpr.mli18
-rw-r--r--plugins/ltac/tactic_debug.ml13
-rw-r--r--plugins/ssr/ssripats.ml10
-rw-r--r--plugins/ssr/ssrparser.ml413
13 files changed, 76 insertions, 82 deletions
diff --git a/plugins/cc/ccalgo.ml b/plugins/cc/ccalgo.ml
index 5a4818926..8e53a044d 100644
--- a/plugins/cc/ccalgo.ml
+++ b/plugins/cc/ccalgo.ml
@@ -9,7 +9,7 @@
(************************************************************************)
(* This file implements the basic congruence-closure algorithm by *)
-(* Downey,Sethi and Tarjan. *)
+(* Downey, Sethi and Tarjan. *)
(* Plus some e-matching and constructor handling by P. Corbineau *)
open CErrors
@@ -18,7 +18,6 @@ open Names
open Sorts
open Constr
open Vars
-open Evd
open Goptions
open Tacmach
open Util
@@ -272,7 +271,8 @@ type state =
mutable rew_depth:int;
mutable changed:bool;
by_type: Int.Set.t Typehash.t;
- mutable gls:Goal.goal Evd.sigma}
+ mutable env:Environ.env;
+ sigma:Evd.evar_map}
let dummy_node =
{
@@ -307,7 +307,8 @@ let empty depth gls:state =
rew_depth=depth;
by_type=Constrhash.create init_size;
changed=false;
- gls=gls
+ env=pf_env gls;
+ sigma=project gls
}
let forest state = state.uf
@@ -426,7 +427,7 @@ let cc_product s1 s2 =
mkLambda(_B_,mkSort(s2),_body_))
let rec constr_of_term = function
- Symb s-> applist_projection s []
+ Symb s-> s
| Product(s1,s2) -> cc_product s1 s2
| Eps id -> mkVar id
| Constructor cinfo -> mkConstructU cinfo.ci_constr
@@ -434,25 +435,7 @@ let rec constr_of_term = function
make_app [(constr_of_term s2)] s1
and make_app l=function
Appli (s1,s2)->make_app ((constr_of_term s2)::l) s1
- | other ->
- applist_proj other l
-and applist_proj c l =
- match c with
- | Symb s -> applist_projection s l
- | _ -> Term.applistc (constr_of_term c) l
-and applist_projection c l =
- match Constr.kind c with
- | Const c when Environ.is_projection (fst c) (Global.env()) ->
- let p = Projection.make (fst c) false in
- (match l with
- | [] -> (* Expand the projection *)
- let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *)
- let pb = Environ.lookup_projection p (Global.env()) in
- let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in
- Term.it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx
- | hd :: tl ->
- Term.applistc (mkProj (p, hd)) tl)
- | _ -> Term.applistc c l
+ | other -> Term.applist (constr_of_term other,l)
let rec canonize_name sigma c =
let c = EConstr.Unsafe.to_constr c in
@@ -511,8 +494,8 @@ 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 (EConstr.of_constr trm) in
- let typ = canonize_name (project state.gls) typ in
+ let typ = Typing.unsafe_type_of state.env state.sigma (EConstr.of_constr trm) in
+ let typ = canonize_name state.sigma typ in
let new_node=
match t with
Symb _ | Product (_,_) ->
@@ -820,11 +803,10 @@ let one_step state =
let __eps__ = Id.of_string "_eps_"
let new_state_var typ state =
- let id = pf_get_new_id __eps__ state.gls in
- let {it=gl ; sigma=sigma} = state.gls in
- let gls = Goal.V82.new_goal_with sigma gl [Context.Named.Declaration.LocalAssum (id,typ)] in
- state.gls<- gls;
- id
+ let ids = Environ.ids_of_named_context_val (Environ.named_context_val state.env) in
+ let id = Namegen.next_ident_away __eps__ ids in
+ state.env<- EConstr.push_named (Context.Named.Declaration.LocalAssum (id,typ)) state.env;
+ id
let complete_one_class state i=
match (get_representative state.uf i).inductive_status with
@@ -832,9 +814,9 @@ let complete_one_class state i=
let rec app t typ n =
if n<=0 then t else
let _,etyp,rest= destProd typ in
- let id = new_state_var etyp state in
+ let id = new_state_var (EConstr.of_constr etyp) state in
app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in
- let _c = pf_unsafe_type_of state.gls
+ let _c = Typing.unsafe_type_of state.env state.sigma
(EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in
let _c = EConstr.Unsafe.to_constr _c in
let _args =
diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml
index 7a9bbd92c..804548ce5 100644
--- a/plugins/funind/functional_principles_types.ml
+++ b/plugins/funind/functional_principles_types.ml
@@ -628,16 +628,19 @@ let build_scheme fas =
user_err ~hdr:"FunInd.build_scheme"
(str "Cannot find " ++ Libnames.pr_reference f)
in
- let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant 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 (EConstr.of_constr f) in
- (destConst f,sort)
+ if isConst f
+ then (destConst f,sort)
+ else user_err Pp.(pr_constr_env (Global.env ()) !evd f ++spc () ++ str "should be the named of a globally defined function")
)
fas
) in
let bodies_types =
make_scheme evd pconstants
in
+
List.iter2
(fun (princ_id,_,_) def_entry ->
ignore
diff --git a/plugins/funind/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml
index 49f7aae43..319b410df 100644
--- a/plugins/funind/glob_term_to_relation.ml
+++ b/plugins/funind/glob_term_to_relation.ml
@@ -1512,7 +1512,7 @@ let do_build_inductive
in
let msg =
str "while trying to define"++ spc () ++
- Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds)))
+ Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)))
++ fnl () ++
msg
in
@@ -1527,7 +1527,7 @@ let do_build_inductive
in
let msg =
str "while trying to define"++ spc () ++
- Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(GlobalNonCumulativity,false,Declarations.Finite,repacked_rel_inds)))
+ Ppvernac.pr_vernac Vernacexpr.(VernacExpr([], VernacInductive(None,false,Declarations.Finite,repacked_rel_inds)))
++ fnl () ++
CErrors.print reraise
in
diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml
index 9c350483b..d395e3601 100644
--- a/plugins/funind/indfun.ml
+++ b/plugins/funind/indfun.ml
@@ -91,10 +91,19 @@ let functional_induction with_clean c princl pat =
if princ_infos.Tactics.farg_in_concl
then [c] else []
in
+ if List.length args + List.length c_list = 0
+ then user_err Pp.(str "Cannot recognize a valid functional scheme" );
let encoded_pat_as_patlist =
- List.make (List.length args + List.length c_list - 1) None @ [pat] in
- List.map2 (fun c pat -> ((None,Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)) )),(None,pat),None))
- (args@c_list) encoded_pat_as_patlist
+ List.make (List.length args + List.length c_list - 1) None @ [pat]
+ in
+ List.map2
+ (fun c pat ->
+ ((None,
+ Ltac_plugin.Tacexpr.ElimOnConstr (fun env sigma -> (sigma,(c,NoBindings)))),
+ (None,pat),
+ None))
+ (args@c_list)
+ encoded_pat_as_patlist
in
let princ' = Some (princ,bindings) in
let princ_vars =
diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml
index 2743a8a2f..ae84eaa93 100644
--- a/plugins/funind/invfun.ml
+++ b/plugins/funind/invfun.ml
@@ -969,7 +969,7 @@ let functional_inversion kn hid fconst f_correct : Tacmach.tactic =
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));
+ Proofview.V82.of_tactic (Inv.inv Inv.FullInversion None (NamedHyp hid));
(fun g ->
let new_ids = List.filter (fun id -> not (Id.Set.mem id old_ids)) (pf_ids_of_hyps g) in
tclMAP (revert_graph kn pre_tac) (hid::new_ids) g
diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli
index 6637de745..434feba95 100644
--- a/plugins/ltac/pltac.mli
+++ b/plugins/ltac/pltac.mli
@@ -25,7 +25,7 @@ val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eva
val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry
val uconstr : constr_expr Gram.entry
val quantified_hypothesis : quantified_hypothesis Gram.entry
-val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry
+val destruction_arg : constr_expr with_bindings Tactics.destruction_arg Gram.entry
val int_or_var : int or_var Gram.entry
val simple_tactic : raw_tactic_expr Gram.entry
val simple_intropattern : constr_expr intro_pattern_expr CAst.t Gram.entry
diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli
index 5951f2b11..aea00c240 100644
--- a/plugins/ltac/pptactic.mli
+++ b/plugins/ltac/pptactic.mli
@@ -84,7 +84,7 @@ type pp_tactic = {
pptac_prods : grammar_terminals;
}
-val pr_goal_selector : toplevel:bool -> goal_selector -> Pp.t
+val pr_goal_selector : toplevel:bool -> Vernacexpr.goal_selector -> Pp.t
val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli
index 5347eda7d..59473a5e5 100644
--- a/plugins/ltac/tacarg.mli
+++ b/plugins/ltac/tacarg.mli
@@ -23,7 +23,7 @@ val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_typ
val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type
val wit_destruction_arg :
- (constr_expr with_bindings Tacexpr.destruction_arg,
- glob_constr_and_expr with_bindings Tacexpr.destruction_arg,
- delayed_open_constr_with_bindings Tacexpr.destruction_arg) genarg_type
+ (constr_expr with_bindings Tactics.destruction_arg,
+ glob_constr_and_expr with_bindings Tactics.destruction_arg,
+ delayed_open_constr_with_bindings Tactics.destruction_arg) genarg_type
diff --git a/plugins/ltac/tacexpr.ml b/plugins/ltac/tacexpr.ml
index 8b0c44041..3baa475ab 100644
--- a/plugins/ltac/tacexpr.ml
+++ b/plugins/ltac/tacexpr.ml
@@ -40,25 +40,29 @@ type goal_selector = Vernacexpr.goal_selector =
| SelectList of (int * int) list
| SelectId of Id.t
| SelectAll
+[@@ocaml.deprecated "Use Vernacexpr.goal_selector"]
-type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg =
+type 'a core_destruction_arg = 'a Tactics.core_destruction_arg =
| ElimOnConstr of 'a
| ElimOnIdent of lident
| ElimOnAnonHyp of int
+[@@ocaml.deprecated "Use Tactics.core_destruction_arg"]
type 'a destruction_arg =
- clear_flag * 'a core_destruction_arg
+ clear_flag * 'a Tactics.core_destruction_arg
+[@@ocaml.deprecated "Use Tactics.destruction_arg"]
-type inversion_kind = Misctypes.inversion_kind =
+type inversion_kind = Inv.inversion_kind =
| SimpleInversion
| FullInversion
| FullInversionClear
+[@@ocaml.deprecated "Use Tactics.inversion_kind"]
type ('c,'d,'id) inversion_strength =
| NonDepInversion of
- inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option
+ Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option
| DepInversion of
- inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option
+ Inv.inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option
| InversionUsing of 'c * 'id list
type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b
@@ -69,7 +73,7 @@ type 'id message_token =
| MsgIdent of 'id
type ('dconstr,'id) induction_clause =
- 'dconstr with_bindings destruction_arg *
+ 'dconstr with_bindings Tactics.destruction_arg *
(intro_pattern_naming_expr CAst.t option (* eqn:... *)
* 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *)
* 'id clause_expr option (* in ... *)
@@ -265,7 +269,7 @@ and 'a gen_tactic_expr =
('p,'a gen_tactic_expr) match_rule list
| TacFun of 'a gen_tactic_fun_ast
| TacArg of 'a gen_tactic_arg located
- | TacSelect of goal_selector * 'a gen_tactic_expr
+ | TacSelect of Vernacexpr.goal_selector * 'a gen_tactic_expr
(* For ML extensions *)
| TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located
(* For syntax extensions *)
diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli
index 8b0c44041..3baa475ab 100644
--- a/plugins/ltac/tacexpr.mli
+++ b/plugins/ltac/tacexpr.mli
@@ -40,25 +40,29 @@ type goal_selector = Vernacexpr.goal_selector =
| SelectList of (int * int) list
| SelectId of Id.t
| SelectAll
+[@@ocaml.deprecated "Use Vernacexpr.goal_selector"]
-type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg =
+type 'a core_destruction_arg = 'a Tactics.core_destruction_arg =
| ElimOnConstr of 'a
| ElimOnIdent of lident
| ElimOnAnonHyp of int
+[@@ocaml.deprecated "Use Tactics.core_destruction_arg"]
type 'a destruction_arg =
- clear_flag * 'a core_destruction_arg
+ clear_flag * 'a Tactics.core_destruction_arg
+[@@ocaml.deprecated "Use Tactics.destruction_arg"]
-type inversion_kind = Misctypes.inversion_kind =
+type inversion_kind = Inv.inversion_kind =
| SimpleInversion
| FullInversion
| FullInversionClear
+[@@ocaml.deprecated "Use Tactics.inversion_kind"]
type ('c,'d,'id) inversion_strength =
| NonDepInversion of
- inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option
+ Inv.inversion_kind * 'id list * 'd or_and_intro_pattern_expr CAst.t or_var option
| DepInversion of
- inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option
+ Inv.inversion_kind * 'c option * 'd or_and_intro_pattern_expr CAst.t or_var option
| InversionUsing of 'c * 'id list
type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b
@@ -69,7 +73,7 @@ type 'id message_token =
| MsgIdent of 'id
type ('dconstr,'id) induction_clause =
- 'dconstr with_bindings destruction_arg *
+ 'dconstr with_bindings Tactics.destruction_arg *
(intro_pattern_naming_expr CAst.t option (* eqn:... *)
* 'dconstr or_and_intro_pattern_expr CAst.t or_var option) (* as ... *)
* 'id clause_expr option (* in ... *)
@@ -265,7 +269,7 @@ and 'a gen_tactic_expr =
('p,'a gen_tactic_expr) match_rule list
| TacFun of 'a gen_tactic_fun_ast
| TacArg of 'a gen_tactic_arg located
- | TacSelect of goal_selector * 'a gen_tactic_expr
+ | TacSelect of Vernacexpr.goal_selector * 'a gen_tactic_expr
(* For ML extensions *)
| TacML of (ml_tactic_entry * 'a gen_tactic_arg list) Loc.located
(* For syntax extensions *)
diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml
index e55b49fb4..105b5c59a 100644
--- a/plugins/ltac/tactic_debug.ml
+++ b/plugins/ltac/tactic_debug.ml
@@ -391,19 +391,14 @@ let explain_ltac_call_trace last trace loc =
let skip_extensions trace =
let rec aux = function
- | (_,Tacexpr.LtacNameCall f as tac) :: _
- when Tacenv.is_ltac_for_ml_tactic f -> [tac]
- | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ ->
+ | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: tail ->
(* Case of an ML defined tactic with entry of the form <<"foo" args>> *)
(* see tacextend.mlp *)
- [tac]
- | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac]
+ tac :: aux tail
| t :: tail -> t :: aux tail
| [] -> [] in
List.rev (aux (List.rev trace))
-let finer_loc loc1 loc2 = Loc.merge_opt loc1 loc2 = loc2
-
let extract_ltac_trace ?loc trace =
let trace = skip_extensions trace in
let (tloc,c),tail = List.sep_last trace in
@@ -411,7 +406,7 @@ let extract_ltac_trace ?loc trace =
(* We entered a user-defined tactic,
we display the trace with location of the call *)
let msg = hov 0 (explain_ltac_call_trace c tail loc ++ fnl()) in
- (if finer_loc loc tloc then loc else tloc), Some msg
+ (if Loc.finer loc tloc then loc else tloc), Some msg
else
(* We entered a primitive tactic, we don't display trace but
report on the finest location *)
@@ -420,7 +415,7 @@ let extract_ltac_trace ?loc trace =
let rec aux best_loc = function
| (loc,_)::tail ->
if Option.is_empty best_loc ||
- not (Option.is_empty loc) && finer_loc loc best_loc
+ not (Option.is_empty loc) && Loc.finer loc best_loc
then
aux loc tail
else
diff --git a/plugins/ssr/ssripats.ml b/plugins/ssr/ssripats.ml
index 8bba35440..af78bf36a 100644
--- a/plugins/ssr/ssripats.ml
+++ b/plugins/ssr/ssripats.ml
@@ -133,6 +133,12 @@ let intro_clear ids future_ipats =
isCLR_PUSHL clear_ids
end
+let tacCHECK_HYPS_EXIST hyps = Goal.enter begin fun gl ->
+ let ctx = Goal.hyps gl in
+ List.iter (Ssrcommon.check_hyp_exists ctx) hyps;
+ tclUNIT ()
+end
+
(** [=> []] *****************************************************************)
let tac_case t =
Goal.enter begin fun _ ->
@@ -229,7 +235,9 @@ let rec ipat_tac1 future_ipats ipat : unit tactic =
| IPatNoop -> tclUNIT ()
| IPatSimpl Nop -> tclUNIT ()
- | IPatClear ids -> intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats
+ | IPatClear ids ->
+ tacCHECK_HYPS_EXIST ids <*>
+ intro_clear (List.map Ssrcommon.hyp_id ids) future_ipats
| IPatSimpl (Simpl n) ->
V82.tactic ~nf_evars:false (Ssrequality.simpltac (Simpl n))
diff --git a/plugins/ssr/ssrparser.ml4 b/plugins/ssr/ssrparser.ml4
index 0d82a9f09..5f3967440 100644
--- a/plugins/ssr/ssrparser.ml4
+++ b/plugins/ssr/ssrparser.ml4
@@ -585,21 +585,10 @@ let pr_ssripat _ _ _ = pr_ipat
let pr_ssripats _ _ _ = pr_ipats
let pr_ssriorpat _ _ _ = pr_iorpat
-(*
-let intern_ipat ist ipat =
- let rec check_pat = function
- | IPatClear clr -> ignore (List.map (intern_hyp ist) clr)
- | IPatCase iorpat -> List.iter (List.iter check_pat) iorpat
- | IPatDispatch iorpat -> List.iter (List.iter check_pat) iorpat
- | IPatInj iorpat -> List.iter (List.iter check_pat) iorpat
- | _ -> () in
- check_pat ipat; ipat
-*)
-
let intern_ipat ist =
map_ipat
(fun id -> id)
- (intern_hyp ist) (* TODO: check with ltac, old code was ignoring the result *)
+ (intern_hyp ist)
(glob_ast_closure_term ist)
let intern_ipats ist = List.map (intern_ipat ist)
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-20 21:41:06 +0000