aboutsummaryrefslogtreecommitdiffhomepage
path: root/plugins/ltac
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/ltac')
-rw-r--r--plugins/ltac/extratactics.ml46
-rw-r--r--plugins/ltac/g_tactic.ml448
-rw-r--r--plugins/ltac/pptactic.ml16
-rw-r--r--plugins/ltac/tacexpr.mli4
-rw-r--r--plugins/ltac/tacintern.ml8
-rw-r--r--plugins/ltac/tacinterp.ml35
-rw-r--r--plugins/ltac/tacsubst.ml8
7 files changed, 76 insertions, 49 deletions
diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4
index d68139a4b..cba9c1364 100644
--- a/plugins/ltac/extratactics.ml4
+++ b/plugins/ltac/extratactics.ml4
@@ -636,7 +636,7 @@ let subst_var_with_hole occ tid t =
else
(incr locref;
CAst.make ~loc:(Loc.make_loc (!locref,0)) @@
- GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true),
+ GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),
Misctypes.IntroAnonymous, None)))
else x
| c -> map_glob_constr_left_to_right substrec c in
@@ -648,13 +648,13 @@ let subst_hole_with_term occ tc t =
let locref = ref 0 in
let occref = ref occ in
let rec substrec = function
- | { CAst.v = GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) } ->
+ | { CAst.v = GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s) } ->
decr occref;
if Int.equal !occref 0 then tc
else
(incr locref;
CAst.make ~loc:(Loc.make_loc (!locref,0)) @@
- GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s))
+ GHole (Evar_kinds.QuestionMark(Evar_kinds.Define true,Anonymous),Misctypes.IntroAnonymous,s))
| c -> map_glob_constr_left_to_right substrec c
in
substrec t
diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4
index 1404b1c1f..83bfd0233 100644
--- a/plugins/ltac/g_tactic.ml4
+++ b/plugins/ltac/g_tactic.ml4
@@ -538,38 +538,64 @@ GEXTEND Gram
TacAtom (Loc.tag ~loc:!@loc @@ TacMutualCofix (id,List.map mk_cofix_tac fd))
| IDENT "pose"; (id,b) = bindings_with_parameters ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (Names.Name id,b,Locusops.nowhere,true,None))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name id,b,Locusops.nowhere,true,None))
| IDENT "pose"; b = constr; na = as_name ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (na,b,Locusops.nowhere,true,None))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,b,Locusops.nowhere,true,None))
+ | IDENT "epose"; (id,b) = bindings_with_parameters ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,b,Locusops.nowhere,true,None))
+ | IDENT "epose"; b = constr; na = as_name ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,b,Locusops.nowhere,true,None))
| IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (Names.Name id,c,p,true,None))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,Names.Name id,c,p,true,None))
| IDENT "set"; c = constr; na = as_name; p = clause_dft_concl ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (na,c,p,true,None))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,true,None))
+ | IDENT "eset"; (id,c) = bindings_with_parameters; p = clause_dft_concl ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,Names.Name id,c,p,true,None))
+ | IDENT "eset"; c = constr; na = as_name; p = clause_dft_concl ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,true,None))
| IDENT "remember"; c = constr; na = as_name; e = eqn_ipat;
p = clause_dft_all ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (na,c,p,false,e))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (false,na,c,p,false,e))
+ | IDENT "eremember"; c = constr; na = as_name; e = eqn_ipat;
+ p = clause_dft_all ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacLetTac (true,na,c,p,false,e))
(* Alternative syntax for "pose proof c as id" *)
| IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":=";
c = lconstr; ")" ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,None,Some (Loc.tag ~loc:!@loc @@IntroNaming (IntroIdentifier id)),c))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c))
+ | IDENT "eassert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":=";
+ c = lconstr; ")" ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c))
(* Alternative syntax for "assert c as id by tac" *)
| IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
c = lconstr; ")"; tac=by_tactic ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,Some tac,Some (Loc.tag ~loc:!@loc @@IntroNaming (IntroIdentifier id)),c))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c))
+ | IDENT "eassert"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
+ c = lconstr; ")"; tac=by_tactic ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c))
(* Alternative syntax for "enough c as id by tac" *)
| IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
c = lconstr; ")"; tac=by_tactic ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,Some tac,Some (Loc.tag ~loc:!@loc @@IntroNaming (IntroIdentifier id)),c))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c))
+ | IDENT "eenough"; test_lpar_id_colon; "("; (loc,id) = identref; ":";
+ c = lconstr; ")"; tac=by_tactic ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,Some (Loc.tag ~loc:!@loc @@ IntroNaming (IntroIdentifier id)),c))
| IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,Some tac,ipat,c))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,Some tac,ipat,c))
+ | IDENT "eassert"; c = constr; ipat = as_ipat; tac = by_tactic ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,Some tac,ipat,c))
| IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,None,ipat,c))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,true,None,ipat,c))
+ | IDENT "epose"; IDENT "proof"; c = lconstr; ipat = as_ipat ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,true,None,ipat,c))
| IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic ->
- TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,Some tac,ipat,c))
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (false,false,Some tac,ipat,c))
+ | IDENT "eenough"; c = constr; ipat = as_ipat; tac = by_tactic ->
+ TacAtom (Loc.tag ~loc:!@loc @@ TacAssert (true,false,Some tac,ipat,c))
| IDENT "generalize"; c = constr ->
TacAtom (Loc.tag ~loc:!@loc @@ TacGeneralize [((AllOccurrences,c),Names.Anonymous)])
diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml
index a001c6a2b..4e254ea76 100644
--- a/plugins/ltac/pptactic.ml
+++ b/plugins/ltac/pptactic.ml
@@ -768,15 +768,15 @@ type 'a extra_genarg_printer =
primitive "cofix" ++ spc () ++ pr_id id ++ spc()
++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l
)
- | TacAssert (b,Some tac,ipat,c) ->
+ | TacAssert (ev,b,Some tac,ipat,c) ->
hov 1 (
- primitive (if b then "assert" else "enough") ++
+ primitive (if b then if ev then "eassert" else "assert" else if ev then "eenough" else "enough") ++
pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++
pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac
)
- | TacAssert (_,None,ipat,c) ->
+ | TacAssert (ev,_,None,ipat,c) ->
hov 1 (
- primitive "pose proof"
+ primitive (if ev then "epose proof" else "pose proof")
++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c
)
| TacGeneralize l ->
@@ -786,11 +786,11 @@ type 'a extra_genarg_printer =
pr_with_occurrences pr.pr_constr cl ++ pr_as_name na)
l
)
- | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl ->
- hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c)
- | TacLetTac (na,c,cl,b,e) ->
+ | TacLetTac (ev,na,c,cl,true,_) when Locusops.is_nowhere cl ->
+ hov 1 (primitive (if ev then "epose" else "pose") ++ pr_pose pr.pr_constr pr.pr_lconstr na c)
+ | TacLetTac (ev,na,c,cl,b,e) ->
hov 1 (
- (if b then primitive "set" else primitive "remember") ++
+ primitive (if b then if ev then "eset" else "set" else if ev then "eremember" else "remember") ++
(if b then pr_pose pr.pr_constr pr.pr_lconstr na c
else pr_pose_as_style pr.pr_constr na c) ++
pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++
diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli
index bf760e7bb..b78dc3742 100644
--- a/plugins/ltac/tacexpr.mli
+++ b/plugins/ltac/tacexpr.mli
@@ -141,10 +141,10 @@ type 'a gen_atomic_tactic_expr =
| TacMutualFix of Id.t * int * (Id.t * int * 'trm) list
| TacMutualCofix of Id.t * (Id.t * 'trm) list
| TacAssert of
- bool * 'tacexpr option option *
+ evars_flag * bool * 'tacexpr option option *
'dtrm intro_pattern_expr located option * 'trm
| TacGeneralize of ('trm with_occurrences * Name.t) list
- | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag *
+ | TacLetTac of evars_flag * Name.t * 'trm * 'nam clause_expr * letin_flag *
intro_pattern_naming_expr located option
(* Derived basic tactics *)
diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml
index e431a13bc..2dc3bb378 100644
--- a/plugins/ltac/tacintern.ml
+++ b/plugins/ltac/tacintern.ml
@@ -489,17 +489,17 @@ let rec intern_atomic lf ist x =
| TacMutualCofix (id,l) ->
let f (id,c) = (intern_ident lf ist id,intern_type ist c) in
TacMutualCofix (intern_ident lf ist id, List.map f l)
- | TacAssert (b,otac,ipat,c) ->
- TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac,
+ | TacAssert (ev,b,otac,ipat,c) ->
+ TacAssert (ev,b,Option.map (Option.map (intern_pure_tactic ist)) otac,
Option.map (intern_intro_pattern lf ist) ipat,
intern_constr_gen false (not (Option.is_empty otac)) ist c)
| TacGeneralize cl ->
TacGeneralize (List.map (fun (c,na) ->
intern_constr_with_occurrences ist c,
intern_name lf ist na) cl)
- | TacLetTac (na,c,cls,b,eqpat) ->
+ | TacLetTac (ev,na,c,cls,b,eqpat) ->
let na = intern_name lf ist na in
- TacLetTac (na,intern_constr ist c,
+ TacLetTac (ev,na,intern_constr ist c,
(clause_app (intern_hyp_location ist) cls),b,
(Option.map (intern_intro_pattern_naming_loc lf ist) eqpat))
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index a9ec779d1..6b0914ff9 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -672,10 +672,7 @@ let pure_open_constr_flags = {
expand_evars = false }
(* Interprets an open constr *)
-let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist env sigma c =
- let flags =
- if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags ()
- else open_constr_use_classes_flags () in
+let interp_open_constr ?(expected_type=WithoutTypeConstraint) ?(flags=open_constr_no_classes_flags ()) ist env sigma c =
interp_gen expected_type ist false flags env sigma c
let interp_pure_open_constr ist =
@@ -1727,18 +1724,21 @@ and interp_atomic ist tac : unit Proofview.tactic =
Sigma.Unsafe.of_pair (tac, sigma)
end }
end
- | TacAssert (b,t,ipat,c) ->
+ | TacAssert (ev,b,t,ipat,c) ->
Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = project gl in
- let (sigma,c) =
- (if Option.is_empty t then interp_constr else interp_type) ist env sigma c
+ let (sigma,c) =
+ let expected_type =
+ if Option.is_empty t then WithoutTypeConstraint else IsType in
+ let flags = open_constr_use_classes_flags () in
+ interp_open_constr ~expected_type ~flags ist env sigma c
in
let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in
let tac = Option.map (Option.map (interp_tactic ist)) t in
- Tacticals.New.tclWITHHOLES false
+ Tacticals.New.tclWITHHOLES ev
(name_atomic ~env
- (TacAssert(b,Option.map (Option.map ignore) t,ipat,c))
+ (TacAssert(ev,b,Option.map (Option.map ignore) t,ipat,c))
(Tactics.forward b tac ipat' c)) sigma
end }
| TacGeneralize cl ->
@@ -1751,36 +1751,37 @@ and interp_atomic ist tac : unit Proofview.tactic =
(TacGeneralize cl)
(Tactics.generalize_gen cl)) sigma
end }
- | TacLetTac (na,c,clp,b,eqpat) ->
+ | TacLetTac (ev,na,c,clp,b,eqpat) ->
Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = project gl in
let clp = interp_clause ist env sigma clp in
let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in
- if Locusops.is_nowhere clp then
+ if Locusops.is_nowhere clp (* typically "pose" *) then
(* We try to fully-typecheck the term *)
- let (sigma,c_interp) = interp_constr ist env sigma c in
+ let flags = open_constr_use_classes_flags () in
+ let (sigma,c_interp) = interp_open_constr ~flags ist env sigma c in
let let_tac b na c cl eqpat =
let id = Option.default (Loc.tag IntroAnonymous) eqpat in
let with_eq = if b then None else Some (true,id) in
Tactics.letin_tac with_eq na c None cl
in
let na = interp_name ist env sigma na in
- Tacticals.New.tclWITHHOLES false
+ Tacticals.New.tclWITHHOLES ev
(name_atomic ~env
- (TacLetTac(na,c_interp,clp,b,eqpat))
+ (TacLetTac(ev,na,c_interp,clp,b,eqpat))
(let_tac b na c_interp clp eqpat)) sigma
else
(* We try to keep the pattern structure as much as possible *)
let let_pat_tac b na c cl eqpat =
let id = Option.default (Loc.tag IntroAnonymous) eqpat in
let with_eq = if b then None else Some (true,id) in
- Tactics.letin_pat_tac with_eq na c cl
+ Tactics.letin_pat_tac ev with_eq na c cl
in
let (sigma',c) = interp_pure_open_constr ist env sigma c in
name_atomic ~env
- (TacLetTac(na,c,clp,b,eqpat))
- (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*)
+ (TacLetTac(ev,na,c,clp,b,eqpat))
+ (Tacticals.New.tclWITHHOLES ev
(let_pat_tac b (interp_name ist env sigma na)
(sigma,c) clp eqpat) sigma')
end }
diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml
index 4390ff08b..f5e6f05ce 100644
--- a/plugins/ltac/tacsubst.ml
+++ b/plugins/ltac/tacsubst.ml
@@ -146,13 +146,13 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l)
| TacMutualCofix (id,l) ->
TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l)
- | TacAssert (b,otac,na,c) ->
- TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na,
+ | TacAssert (ev,b,otac,na,c) ->
+ TacAssert (ev,b,Option.map (Option.map (subst_tactic subst)) otac,na,
subst_glob_constr subst c)
| TacGeneralize cl ->
TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl)
- | TacLetTac (id,c,clp,b,eqpat) ->
- TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat)
+ | TacLetTac (ev,id,c,clp,b,eqpat) ->
+ TacLetTac (ev,id,subst_glob_constr subst c,clp,b,eqpat)
(* Derived basic tactics *)
| TacInductionDestruct (isrec,ev,(l,el)) ->
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 23:03:44 +0000