aboutsummaryrefslogtreecommitdiffhomepage
path: root/tactics
diff options
context:
space:
mode:
Diffstat (limited to 'tactics')
-rw-r--r--tactics/auto.ml2
-rw-r--r--tactics/class_tactics.ml42
-rw-r--r--tactics/decl_proof_instr.ml19
-rw-r--r--tactics/elim.ml4
-rw-r--r--tactics/elim.mli2
-rw-r--r--tactics/equality.ml2
-rw-r--r--tactics/equality.mli5
-rw-r--r--tactics/extratactics.ml410
-rw-r--r--tactics/hiddentac.ml35
-rw-r--r--tactics/hiddentac.mli31
-rw-r--r--tactics/inv.ml30
-rw-r--r--tactics/inv.mli13
-rw-r--r--tactics/tacinterp.ml365
-rw-r--r--tactics/tacinterp.mli10
-rw-r--r--tactics/tacticals.ml19
-rw-r--r--tactics/tacticals.mli22
-rw-r--r--tactics/tactics.ml607
-rw-r--r--tactics/tactics.mli39
-rw-r--r--tactics/tauto.ml414
19 files changed, 668 insertions, 563 deletions
diff --git a/tactics/auto.ml b/tactics/auto.ml
index c7e2230fd..53e493d14 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -641,7 +641,7 @@ let unify_resolve_nodelta (c,clenv) gls =
let unify_resolve flags (c,clenv) gls =
let clenv' = connect_clenv gls clenv in
let _ = clenv_unique_resolver false ~flags clenv' gls in
- h_apply true false (c,NoBindings) gls
+ h_apply true false [c,NoBindings] gls
(* builds a hint database from a constr signature *)
diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4
index 16e8bce3a..68f9aa922 100644
--- a/tactics/class_tactics.ml4
+++ b/tactics/class_tactics.ml4
@@ -1075,7 +1075,7 @@ let cl_rewrite_clause_aux ?(flags=default_flags) hypinfo goal_meta occs clause g
| None ->
let name = next_name_away_with_default "H" Anonymous (pf_ids_of_hyps gl) in
tclTHENLAST
- (Tacmach.internal_cut_no_check name newt)
+ (Tacmach.internal_cut_no_check false name newt)
(tclTHEN (Tactics.revert [name]) (Tactics.refine p))
| Some (t, ty) ->
Tactics.refine
diff --git a/tactics/decl_proof_instr.ml b/tactics/decl_proof_instr.ml
index cbb8996f6..3b45573f8 100644
--- a/tactics/decl_proof_instr.ml
+++ b/tactics/decl_proof_instr.ml
@@ -106,6 +106,9 @@ let clean_tmp gls =
in
clean_all (tmp_ids gls) gls
+let assert_postpone id t =
+ assert_as true (dummy_loc, Genarg.IntroIdentifier id) t
+
(* start a proof *)
let start_proof_tac gls=
@@ -524,7 +527,7 @@ let instr_cut mkstat _thus _then cut gls0 =
if _thus then
thus_tac (mkVar c_id) c_stat [] gls
else tclIDTAC gls in
- tclTHENS (internal_cut c_id c_stat)
+ tclTHENS (assert_postpone c_id c_stat)
[tclTHEN tcl_erase_info (just_tac _then cut info);
thus_tac] gls0
@@ -572,14 +575,14 @@ let instr_rew _thus rew_side cut gls0 =
match rew_side with
Lhs ->
let new_eq = mkApp(_eq,[|typ;cut.cut_stat.st_it;rhs|]) in
- tclTHENS (internal_cut c_id new_eq)
+ tclTHENS (assert_postpone c_id new_eq)
[tclTHEN tcl_erase_info
(tclTHENS (transitivity lhs)
[just_tac;exact_check (mkVar last_id)]);
thus_tac new_eq] gls0
| Rhs ->
let new_eq = mkApp(_eq,[|typ;lhs;cut.cut_stat.st_it|]) in
- tclTHENS (internal_cut c_id new_eq)
+ tclTHENS (assert_postpone c_id new_eq)
[tclTHEN tcl_erase_info
(tclTHENS (transitivity rhs)
[exact_check (mkVar last_id);just_tac]);
@@ -600,7 +603,7 @@ let instr_claim _thus st gls0 =
else tclIDTAC gls in
let ninfo1 = {pm_stack=
(if _thus then Focus_claim else Claim)::info.pm_stack} in
- tclTHENS (internal_cut id st.st_it)
+ tclTHENS (assert_postpone id st.st_it)
[tcl_change_info ninfo1;
thus_tac] gls0
@@ -691,7 +694,7 @@ let instr_suffices _then cut gls0 =
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
- tclTHENS (internal_cut c_id c_stat)
+ tclTHENS (assert_postpone c_id c_stat)
[tclTHENLIST
[ assume_tac ctx;
tcl_erase_info;
@@ -777,7 +780,7 @@ let consider_tac c hyps gls =
| _ ->
let id = pf_get_new_id (id_of_string "_tmp") gls in
tclTHEN
- (forward None (Genarg.IntroIdentifier id) c)
+ (forward None (dummy_loc, Genarg.IntroIdentifier id) c)
(consider_match false [] [id] hyps) gls
@@ -955,7 +958,7 @@ let suppose_tac hyps gls0 =
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
- tclTHENS (internal_cut id clause)
+ tclTHENS (assert_postpone id clause)
[tclTHENLIST [tcl_change_info ninfo1;
assume_tac hyps;
clear old_clauses];
@@ -1161,7 +1164,7 @@ let case_tac params pat_info hyps gls0 =
register_dep_subcase (id,List.length hyps) (pf_env gls0) per_info
pat_info.pat_pat ek in
let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in
- tclTHENS (internal_cut id clause)
+ tclTHENS (assert_postpone id clause)
[tclTHENLIST
[tcl_change_info ninfo1;
assume_st (params@pat_info.pat_vars);
diff --git a/tactics/elim.ml b/tactics/elim.ml
index f0cc50d49..2601cd4c5 100644
--- a/tactics/elim.ml
+++ b/tactics/elim.ml
@@ -49,8 +49,8 @@ let introCaseAssumsThen tac ba =
else
(ba.branchnames, []),
if n1 > n2 then snd (list_chop n2 case_thin_sign) else [] in
- let introCaseAssums = tclTHEN (intros_pattern None l1) (intros_clearing l3)
- in
+ let introCaseAssums =
+ tclTHEN (intros_pattern no_move l1) (intros_clearing l3) in
(tclTHEN introCaseAssums (case_on_ba (tac l2) ba))
(* The following tactic Decompose repeatedly applies the
diff --git a/tactics/elim.mli b/tactics/elim.mli
index 16066a732..1fd8a9c2b 100644
--- a/tactics/elim.mli
+++ b/tactics/elim.mli
@@ -23,7 +23,7 @@ val introElimAssumsThen :
(branch_assumptions -> tactic) -> branch_args -> tactic
val introCaseAssumsThen :
- (intro_pattern_expr list -> branch_assumptions -> tactic) ->
+ (intro_pattern_expr Util.located list -> branch_assumptions -> tactic) ->
branch_args -> tactic
val general_decompose : (identifier * constr -> bool) -> constr -> tactic
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 5212711ae..cceda72f9 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -930,7 +930,7 @@ let injEq ipats (eq,(t,t1,t2)) eq_clause =
) with _ ->
tclTHEN
(inject_at_positions env sigma (eq,(t,t1,t2)) eq_clause posns)
- (intros_pattern None ipats)
+ (intros_pattern no_move ipats)
let inj ipats with_evars = onEquality with_evars (injEq ipats)
diff --git a/tactics/equality.mli b/tactics/equality.mli
index 0f93784af..7aeb7af37 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -9,6 +9,7 @@
(*i $Id$ i*)
(*i*)
+open Util
open Names
open Term
open Sign
@@ -75,9 +76,9 @@ val discrHyp : identifier -> tactic
val discrEverywhere : evars_flag -> tactic
val discr_tac : evars_flag ->
constr with_ebindings induction_arg option -> tactic
-val inj : intro_pattern_expr list -> evars_flag ->
+val inj : intro_pattern_expr located list -> evars_flag ->
constr with_ebindings -> tactic
-val injClause : intro_pattern_expr list -> evars_flag ->
+val injClause : intro_pattern_expr located list -> evars_flag ->
constr with_ebindings induction_arg option -> tactic
val injHyp : identifier -> tactic
val injConcl : tactic
diff --git a/tactics/extratactics.ml4 b/tactics/extratactics.ml4
index a2dc8a505..37498b13f 100644
--- a/tactics/extratactics.ml4
+++ b/tactics/extratactics.ml4
@@ -486,16 +486,14 @@ END
TACTIC EXTEND apply_in
-| ["apply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in false id [c] ]
-| ["apply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",")
- "in" hyp(id) ] -> [ apply_in false id (c::cl) ]
+| ["apply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] ->
+ [ apply_in false id cl ]
END
TACTIC EXTEND eapply_in
-| ["eapply" constr_with_bindings(c) "in" hyp(id) ] -> [ apply_in true id [c] ]
-| ["epply" constr_with_bindings(c) "," constr_with_bindings_list_sep(cl,",")
- "in" hyp(id) ] -> [ apply_in true id (c::cl) ]
+| ["eapply" ne_constr_with_bindings_list_sep(cl,",") "in" hyp(id) ] ->
+ [ apply_in true id cl ]
END
(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as
diff --git a/tactics/hiddentac.ml b/tactics/hiddentac.ml
index 11ace2abb..428372003 100644
--- a/tactics/hiddentac.ml
+++ b/tactics/hiddentac.ml
@@ -30,8 +30,8 @@ let inj_occ (occ,c) = (occ,inj_open c)
(* Basic tactics *)
let h_intro_move x y =
- abstract_tactic (TacIntroMove (x, Option.map inj_id y)) (intro_move x y)
-let h_intro x = h_intro_move (Some x) None
+ abstract_tactic (TacIntroMove (x, y)) (intro_move x y)
+let h_intro x = h_intro_move (Some x) no_move
let h_intros_until x = abstract_tactic (TacIntrosUntil x) (intros_until x)
let h_assumption = abstract_tactic TacAssumption assumption
let h_exact c = abstract_tactic (TacExact (inj_open c)) (exact_check c)
@@ -40,7 +40,7 @@ let h_exact_no_check c =
let h_vm_cast_no_check c =
abstract_tactic (TacVmCastNoCheck (inj_open c)) (vm_cast_no_check c)
let h_apply simple ev cb =
- abstract_tactic (TacApply (simple,ev,inj_open_wb cb))
+ abstract_tactic (TacApply (simple,ev,List.map inj_open_wb cb))
(apply_with_ebindings_gen simple ev cb)
let h_elim ev cb cbo =
abstract_tactic (TacElim (ev,inj_open_wb cb,Option.map inj_open_wb cbo))
@@ -70,7 +70,7 @@ let h_generalize cl =
let h_generalize_dep c =
abstract_tactic (TacGeneralizeDep (inj_open c))(generalize_dep c)
let h_let_tac b na c cl =
- let with_eq = if b then None else Some true in
+ let with_eq = if b then None else Some (true,(dummy_loc,IntroAnonymous)) in
abstract_tactic (TacLetTac (na,inj_open c,cl,b)) (letin_tac with_eq na c cl)
let h_instantiate n c ido =
(Evar_tactics.instantiate n c ido)
@@ -78,16 +78,19 @@ let h_instantiate n c ido =
(Evar_refiner.instantiate n c (simple_clause_of cls)) *)
(* Derived basic tactics *)
-let h_simple_induction h =
- abstract_tactic (TacSimpleInduction h) (simple_induct h)
-let h_simple_destruct h =
- abstract_tactic (TacSimpleDestruct h) (simple_destruct h)
-let h_new_induction ev c e idl cl =
- abstract_tactic (TacNewInduction (ev,List.map inj_ia c,Option.map inj_open_wb e,idl,cl))
- (new_induct ev c e idl cl)
-let h_new_destruct ev c e idl cl =
- abstract_tactic (TacNewDestruct (ev,List.map inj_ia c,Option.map inj_open_wb e,idl,cl))
- (new_destruct ev c e idl cl)
+let h_simple_induction_destruct isrec h =
+ abstract_tactic (TacSimpleInductionDestruct (isrec,h))
+ (if isrec then (simple_induct h) else (simple_destruct h))
+let h_simple_induction = h_simple_induction_destruct true
+let h_simple_destruct = h_simple_induction_destruct false
+
+let h_induction_destruct isrec ev l =
+ abstract_tactic (TacInductionDestruct (isrec,ev,List.map (fun (c,e,idl,cl) ->
+ List.map inj_ia c,Option.map inj_open_wb e,idl,cl) l))
+ (induction_destruct ev isrec l)
+let h_new_induction ev c e idl cl = h_induction_destruct ev true [c,e,idl,cl]
+let h_new_destruct ev c e idl cl = h_induction_destruct ev false [c,e,idl,cl]
+
let h_specialize n d = abstract_tactic (TacSpecialize (n,inj_open_wb d)) (specialize n d)
let h_lapply c = abstract_tactic (TacLApply (inj_open c)) (cut_and_apply c)
@@ -128,8 +131,8 @@ let h_symmetry c = abstract_tactic (TacSymmetry c) (intros_symmetry c)
let h_transitivity c =
abstract_tactic (TacTransitivity (inj_open c)) (intros_transitivity c)
-let h_simplest_apply c = h_apply false false (c,NoBindings)
-let h_simplest_eapply c = h_apply false true (c,NoBindings)
+let h_simplest_apply c = h_apply false false [c,NoBindings]
+let h_simplest_eapply c = h_apply false true [c,NoBindings]
let h_simplest_elim c = h_elim false (c,NoBindings) None
let h_simplest_case c = h_case false (c,NoBindings)
diff --git a/tactics/hiddentac.mli b/tactics/hiddentac.mli
index bb88518c9..8d15f864c 100644
--- a/tactics/hiddentac.mli
+++ b/tactics/hiddentac.mli
@@ -10,6 +10,7 @@
(*i*)
open Names
+open Util
open Term
open Proof_type
open Tacmach
@@ -25,7 +26,7 @@ open Clenv
(* Basic tactics *)
-val h_intro_move : identifier option -> identifier option -> tactic
+val h_intro_move : identifier option -> identifier move_location -> tactic
val h_intro : identifier -> tactic
val h_intros_until : quantified_hypothesis -> tactic
@@ -35,7 +36,7 @@ val h_exact_no_check : constr -> tactic
val h_vm_cast_no_check : constr -> tactic
val h_apply : advanced_flag -> evars_flag ->
- constr with_ebindings -> tactic
+ constr with_ebindings list -> tactic
val h_elim : evars_flag -> constr with_ebindings ->
constr with_ebindings option -> tactic
@@ -63,14 +64,20 @@ val h_instantiate : int -> Rawterm.rawconstr ->
val h_simple_induction : quantified_hypothesis -> tactic
val h_simple_destruct : quantified_hypothesis -> tactic
-val h_new_induction :
- evars_flag -> constr with_ebindings induction_arg list ->
- constr with_ebindings option -> intro_pattern_expr ->
- Tacticals.clause option -> tactic
-val h_new_destruct :
- evars_flag -> constr with_ebindings induction_arg list ->
- constr with_ebindings option -> intro_pattern_expr ->
- Tacticals.clause option -> tactic
+val h_simple_induction_destruct : rec_flag -> quantified_hypothesis -> tactic
+val h_new_induction : evars_flag ->
+ constr with_ebindings induction_arg list -> constr with_ebindings option ->
+ intro_pattern_expr located option * intro_pattern_expr located option ->
+ Tacticals.clause option -> tactic
+val h_new_destruct : evars_flag ->
+ constr with_ebindings induction_arg list -> constr with_ebindings option ->
+ intro_pattern_expr located option * intro_pattern_expr located option ->
+ Tacticals.clause option -> tactic
+val h_induction_destruct : rec_flag -> evars_flag ->
+ (constr with_ebindings induction_arg list * constr with_ebindings option *
+ (intro_pattern_expr located option * intro_pattern_expr located option) *
+ Tacticals.clause option) list -> tactic
+
val h_specialize : int option -> constr with_ebindings -> tactic
val h_lapply : constr -> tactic
@@ -80,7 +87,7 @@ val h_lapply : constr -> tactic
(* Context management *)
val h_clear : bool -> identifier list -> tactic
val h_clear_body : identifier list -> tactic
-val h_move : bool -> identifier -> identifier -> tactic
+val h_move : bool -> identifier -> identifier move_location -> tactic
val h_rename : (identifier*identifier) list -> tactic
val h_revert : identifier list -> tactic
@@ -110,4 +117,4 @@ val h_simplest_eapply : constr -> tactic
val h_simplest_elim : constr -> tactic
val h_simplest_case : constr -> tactic
-val h_intro_patterns : intro_pattern_expr list -> tactic
+val h_intro_patterns : intro_pattern_expr located list -> tactic
diff --git a/tactics/inv.ml b/tactics/inv.ml
index 4e06fffb7..5d02e621d 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -294,7 +294,7 @@ let rec tclMAP_i n tacfun = function
if n=0 then error "Too much names."
else tclTHEN (tacfun (Some a)) (tclMAP_i (n-1) tacfun l)
-let remember_first_eq id x = if !x = None then x := Some id
+let remember_first_eq id x = if !x = no_move then x := MoveAfter id
(* invariant: ProjectAndApply is responsible for erasing the clause
which it is given as input
@@ -321,7 +321,7 @@ let projectAndApply thin id eqname names depids gls =
[(if names <> [] then clear [id] else tclIDTAC);
(tclMAP_i neqns (fun idopt ->
tclTHEN
- (intro_move idopt None)
+ (intro_move idopt no_move)
(* try again to substitute and if still not a variable after *)
(* decomposition, arbitrarily try to rewrite RL !? *)
(tclTRY (onLastHyp (substHypIfVariable (subst_hyp false)))))
@@ -350,7 +350,7 @@ let rewrite_equations_gene othin neqns ba gl =
(onLastHyp
(fun id ->
tclTRY
- (projectAndApply thin id (ref None)
+ (projectAndApply thin id (ref no_move)
[] depids))));
onHyps (compose List.rev (afterHyp last)) bring_hyps;
onHyps (afterHyp last)
@@ -375,12 +375,12 @@ let rewrite_equations_gene othin neqns ba gl =
None: the equations are introduced, but not rewritten
Some thin: the equations are rewritten, and cleared if thin is true *)
-let rec get_names allow_conj = function
- | IntroWildcard _ ->
+let rec get_names allow_conj (loc,pat) = match pat with
+ | IntroWildcard ->
error "Discarding pattern not allowed for inversion equations."
| IntroAnonymous ->
error "Anonymous pattern not allowed for inversion equations."
- | IntroFresh _->
+ | IntroFresh _ ->
error "Fresh pattern not allowed for inversion equations."
| IntroRewrite _->
error "Rewriting pattern not allowed for inversion equations."
@@ -404,7 +404,7 @@ let rewrite_equations othin neqns names ba gl =
let names = List.map (get_names true) names in
let (depids,nodepids) = split_dep_and_nodep ba.assums gl in
let rewrite_eqns =
- let first_eq = ref None in
+ let first_eq = ref no_move in
match othin with
| Some thin ->
tclTHENSEQ
@@ -413,12 +413,12 @@ let rewrite_equations othin neqns names ba gl =
tclMAP_i neqns (fun o ->
let idopt,names = extract_eqn_names o in
(tclTHEN
- (intro_move idopt None)
+ (intro_move idopt no_move)
(onLastHyp (fun id ->
tclTRY (projectAndApply thin id first_eq names depids)))))
names;
tclMAP (fun (id,_,_) gl ->
- intro_move None (if thin then None else !first_eq) gl)
+ intro_move None (if thin then no_move else !first_eq) gl)
nodepids;
tclMAP (fun (id,_,_) -> tclTRY (clear [id])) depids]
| None -> tclIDTAC
@@ -524,15 +524,15 @@ open Tacexpr
let inv k = inv_gen false k NoDep
-let half_inv_tac id = inv SimpleInversion IntroAnonymous (NamedHyp id)
-let inv_tac id = inv FullInversion IntroAnonymous (NamedHyp id)
-let inv_clear_tac id = inv FullInversionClear IntroAnonymous (NamedHyp id)
+let half_inv_tac id = inv SimpleInversion None (NamedHyp id)
+let inv_tac id = inv FullInversion None (NamedHyp id)
+let inv_clear_tac id = inv FullInversionClear None (NamedHyp id)
let dinv k c = inv_gen false k (Dep c)
-let half_dinv_tac id = dinv SimpleInversion None IntroAnonymous (NamedHyp id)
-let dinv_tac id = dinv FullInversion None IntroAnonymous (NamedHyp id)
-let dinv_clear_tac id = dinv FullInversionClear None IntroAnonymous (NamedHyp id)
+let half_dinv_tac id = dinv SimpleInversion None None (NamedHyp id)
+let dinv_tac id = dinv FullInversion None None (NamedHyp id)
+let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id)
(* InvIn will bring the specified clauses into the conclusion, and then
* perform inversion on the named hypothesis. After, it will intro them
diff --git a/tactics/inv.mli b/tactics/inv.mli
index 086c9d7ce..322e139f0 100644
--- a/tactics/inv.mli
+++ b/tactics/inv.mli
@@ -9,6 +9,7 @@
(*i $Id$ i*)
(*i*)
+open Util
open Names
open Term
open Tacmach
@@ -21,20 +22,20 @@ type inversion_status = Dep of constr option | NoDep
val inv_gen :
bool -> inversion_kind -> inversion_status ->
- intro_pattern_expr -> quantified_hypothesis -> tactic
+ intro_pattern_expr located option -> quantified_hypothesis -> tactic
val invIn_gen :
- inversion_kind -> intro_pattern_expr -> identifier list ->
+ inversion_kind -> intro_pattern_expr located option -> identifier list ->
quantified_hypothesis -> tactic
val inv_clause :
- inversion_kind -> intro_pattern_expr -> identifier list ->
+ inversion_kind -> intro_pattern_expr located option -> identifier list ->
quantified_hypothesis -> tactic
-val inv : inversion_kind -> intro_pattern_expr ->
+val inv : inversion_kind -> intro_pattern_expr located option ->
quantified_hypothesis -> tactic
-val dinv : inversion_kind -> constr option -> intro_pattern_expr ->
- quantified_hypothesis -> tactic
+val dinv : inversion_kind -> constr option ->
+ intro_pattern_expr located option -> quantified_hypothesis -> tactic
val half_inv_tac : identifier -> tactic
val inv_tac : identifier -> tactic
diff --git a/tactics/tacinterp.ml b/tactics/tacinterp.ml
index a50b79720..a2e6587ee 100644
--- a/tactics/tacinterp.ml
+++ b/tactics/tacinterp.ml
@@ -51,7 +51,7 @@ open Pcoq
let safe_msgnl s =
try msgnl s with e ->
msgnl
- (str "bug in the debugger : " ++
+ (str "bug in the debugger: " ++
str "an exception is raised while printing debug information")
let error_syntactic_metavariables_not_allowed loc =
@@ -72,10 +72,10 @@ type ltac_type =
(* Values for interpretation *)
type value =
- | VTactic of loc * tactic (* For mixed ML/Ltac tactics (e.g. Tauto) *)
| VRTactic of (goal list sigma * validation) (* For Match results *)
(* Not a true value *)
- | VFun of (identifier*value) list * identifier option list * glob_tactic_expr
+ | VFun of ltac_trace * (identifier*value) list *
+ identifier option list * glob_tactic_expr
| VVoid
| VInteger of int
| VIntroPattern of intro_pattern_expr (* includes idents which are not *)
@@ -86,22 +86,20 @@ type value =
| VList of value list
| VRec of (identifier*value) list ref * glob_tactic_expr
-let locate_tactic_call loc = function
- | VTactic (_,t) -> VTactic (loc,t)
- | v -> v
-
-let locate_error_in_file dir = function
- | Stdpp.Exc_located (loc,e) -> Error_in_file ("",(true,dir,loc),e)
- | e -> Error_in_file ("",(true,dir,dummy_loc),e)
+let dloc = dummy_loc
-let catch_error loc tac g =
- try tac g
- with e when loc <> dummy_loc ->
- match e with
- | Stdpp.Exc_located (loc',e') ->
- if loc' = dummy_loc then raise (Stdpp.Exc_located (loc,e'))
- else raise e
- | e -> raise (Stdpp.Exc_located (loc,e))
+let catch_error call_trace tac g =
+ if call_trace = [] then tac g else try tac g with
+ | LtacLocated _ as e -> raise e
+ | Stdpp.Exc_located (_,LtacLocated _) as e -> raise e
+ | e ->
+ let (loc',c),tail = list_sep_last call_trace in
+ let loc,e' = match e with Stdpp.Exc_located(loc,e) -> loc,e | _ ->dloc,e in
+ if tail = [] then
+ let loc = if loc' = dloc then loc else loc' in
+ raise (Stdpp.Exc_located(loc,e'))
+ else
+ raise (Stdpp.Exc_located(loc',LtacLocated((c,tail,loc),e')))
(* Signature for interpretation: val_interp and interpretation functions *)
type interp_sign =
@@ -109,7 +107,7 @@ type interp_sign =
avoid_ids : identifier list; (* ids inherited from the call context
(needed to get fresh ids) *)
debug : debug_info;
- last_loc : loc }
+ trace : ltac_trace }
let check_is_value = function
| VRTactic _ -> (* These are goals produced by Match *)
@@ -129,10 +127,10 @@ let constr_of_VConstr_context = function
let rec pr_value env = function
| VVoid -> str "()"
| VInteger n -> int n
- | VIntroPattern ipat -> pr_intro_pattern ipat
+ | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
| VConstr c | VConstr_context c ->
(match env with Some env -> pr_lconstr_env env c | _ -> str "a term")
- | (VTactic _ | VRTactic _ | VFun _ | VRec _) -> str "a tactic"
+ | (VRTactic _ | VFun _ | VRec _) -> str "a tactic"
| VList [] -> str "an empty list"
| VList (a::_) ->
str "a list (first element is " ++ pr_value env a ++ str")"
@@ -142,24 +140,13 @@ let constr_of_id env id =
construct_reference (Environ.named_context env) id
(* To embed tactics *)
-let ((tactic_in : (interp_sign -> raw_tactic_expr) -> Dyn.t),
- (tactic_out : Dyn.t -> (interp_sign -> raw_tactic_expr))) =
+let ((tactic_in : (interp_sign -> glob_tactic_expr) -> Dyn.t),
+ (tactic_out : Dyn.t -> (interp_sign -> glob_tactic_expr))) =
create "tactic"
let ((value_in : value -> Dyn.t),
(value_out : Dyn.t -> value)) = create "value"
-let tacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t))
-let tacticOut = function
- | TacArg (TacDynamic (_,d)) ->
- if (tag d) = "tactic" then
- tactic_out d
- else
- anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic")
- | ast ->
- anomalylabstrm "tacticOut"
- (str "Not a Dynamic ast: " (* ++ print_ast ast*) )
-
let valueIn t = TacDynamic (dummy_loc,value_in t)
let valueOut = function
| TacDynamic (_,d) ->
@@ -181,8 +168,6 @@ let constrOut = function
| ast ->
anomalylabstrm "constrOut" (str "Not a Dynamic ast")
-let dloc = dummy_loc
-
(* Globalizes the identifier *)
let find_reference env qid =
(* We first look for a variable of the current proof *)
@@ -210,7 +195,7 @@ let _ =
"hnf", TacReduce(Hnf,nocl);
"simpl", TacReduce(Simpl None,nocl);
"compute", TacReduce(Cbv all_flags,nocl);
- "intro", TacIntroMove(None,None);
+ "intro", TacIntroMove(None,no_move);
"intros", TacIntroPattern [];
"assumption", TacAssumption;
"cofix", TacCofix None;
@@ -310,9 +295,15 @@ let lookup_genarg_glob id = let (f,_,_) = lookup_genarg id in f
let lookup_interp_genarg id = let (_,f,_) = lookup_genarg id in f
let lookup_genarg_subst id = let (_,_,f) = lookup_genarg id in f
-(* Dynamically check that an argument is a tactic, possibly unboxing VRec *)
+let propagate_trace ist loc id = function
+ | VFun (_,lfun,it,b) ->
+ let t = if it=[] then b else TacFun (it,b) in
+ VFun ((loc,LtacVarCall (id,t))::ist.trace,lfun,it,b)
+ | x -> x
+
+(* Dynamically check that an argument is a tactic *)
let coerce_to_tactic loc id = function
- | VTactic _ | VFun _ | VRTactic _ as a -> a
+ | VFun _ | VRTactic _ as a -> a
| _ -> user_err_loc
(loc, "", str "Variable " ++ pr_id id ++ str " should be bound to a tactic.")
@@ -421,6 +412,11 @@ let intern_constr_reference strict ist = function
let loc,_ as lqid = qualid_of_reference r in
RRef (loc,locate_global_with_alias lqid), if strict then None else Some (CRef r)
+let intern_move_location ist = function
+ | MoveAfter id -> MoveAfter (intern_hyp_or_metaid ist id)
+ | MoveBefore id -> MoveBefore (intern_hyp_or_metaid ist id)
+ | MoveToEnd toleft as x -> x
+
(* Internalize an isolated reference in position of tactic *)
let intern_isolated_global_tactic_reference r =
@@ -474,7 +470,7 @@ let intern_non_tactic_reference strict ist r =
with Not_found ->
(* By convention, use IntroIdentifier for unbound ident, when not in a def *)
match r with
- | Ident (_,id) when not strict -> IntroPattern (IntroIdentifier id)
+ | Ident (loc,id) when not strict -> IntroPattern (loc,IntroIdentifier id)
| _ ->
(* Reference not found *)
error_global_not_found_loc (qualid_of_reference r)
@@ -486,13 +482,14 @@ let intern_message_token ist = function
let intern_message ist = List.map (intern_message_token ist)
let rec intern_intro_pattern lf ist = function
- | IntroOrAndPattern l ->
- IntroOrAndPattern (intern_case_intro_pattern lf ist l)
- | IntroIdentifier id ->
- IntroIdentifier (intern_ident lf ist id)
- | IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _ as x -> x
-
-and intern_case_intro_pattern lf ist =
+ | loc, IntroOrAndPattern l ->
+ loc, IntroOrAndPattern (intern_or_and_intro_pattern lf ist l)
+ | loc, IntroIdentifier id ->
+ loc, IntroIdentifier (intern_ident lf ist id)
+ | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)
+ as x -> x
+
+and intern_or_and_intro_pattern lf ist =
List.map (List.map (intern_intro_pattern lf ist))
let intern_quantified_hypothesis ist = function
@@ -601,10 +598,10 @@ let intern_red_expr ist = function
let intern_inversion_strength lf ist = function
| NonDepInversion (k,idl,ids) ->
NonDepInversion (k,List.map (intern_hyp_or_metaid ist) idl,
- intern_intro_pattern lf ist ids)
+ Option.map (intern_intro_pattern lf ist) ids)
| DepInversion (k,copt,ids) ->
DepInversion (k, Option.map (intern_constr ist) copt,
- intern_intro_pattern lf ist ids)
+ Option.map (intern_intro_pattern lf ist) ids)
| InversionUsing (c,idl) ->
InversionUsing (intern_constr ist c, List.map (intern_hyp_or_metaid ist) idl)
@@ -641,7 +638,7 @@ let internalise_tacarg ch = G_xml.parse_tactic_arg ch
let extern_tacarg ch env sigma = function
| VConstr c -> !print_xml_term ch env sigma c
- | VTactic _ | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _
+ | VRTactic _ | VFun _ | VVoid | VInteger _ | VConstr_context _
| VIntroPattern _ | VRec _ | VList _ ->
error "Only externing of terms is implemented."
@@ -698,14 +695,15 @@ let rec intern_atomic lf ist x =
| TacIntroPattern l ->
TacIntroPattern (List.map (intern_intro_pattern lf ist) l)
| TacIntrosUntil hyp -> TacIntrosUntil (intern_quantified_hypothesis ist hyp)
- | TacIntroMove (ido,ido') ->
+ | TacIntroMove (ido,hto) ->
TacIntroMove (Option.map (intern_ident lf ist) ido,
- Option.map (intern_hyp ist) ido')
+ intern_move_location ist hto)
| TacAssumption -> TacAssumption
| TacExact c -> TacExact (intern_constr ist c)
| TacExactNoCheck c -> TacExactNoCheck (intern_constr ist c)
| TacVmCastNoCheck c -> TacVmCastNoCheck (intern_constr ist c)
- | TacApply (a,ev,cb) -> TacApply (a,ev,intern_constr_with_bindings ist cb)
+ | TacApply (a,ev,cb) ->
+ TacApply (a,ev,List.map (intern_constr_with_bindings ist) cb)
| TacElim (ev,cb,cbo) ->
TacElim (ev,intern_constr_with_bindings ist cb,
Option.map (intern_constr_with_bindings ist) cbo)
@@ -749,20 +747,15 @@ let rec intern_atomic lf ist x =
List.map (intern_constr ist) lems)
(* Derived basic tactics *)
- | TacSimpleInduction h ->
- TacSimpleInduction (intern_quantified_hypothesis ist h)
- | TacNewInduction (ev,lc,cbo,ids,cls) ->
- TacNewInduction (ev,List.map (intern_induction_arg ist) lc,
- Option.map (intern_constr_with_bindings ist) cbo,
- intern_intro_pattern lf ist ids,
- Option.map (clause_app (intern_hyp_location ist)) cls)
- | TacSimpleDestruct h ->
- TacSimpleDestruct (intern_quantified_hypothesis ist h)
- | TacNewDestruct (ev,c,cbo,ids,cls) ->
- TacNewDestruct (ev,List.map (intern_induction_arg ist) c,
+ | TacSimpleInductionDestruct (isrec,h) ->
+ TacSimpleInductionDestruct (isrec,intern_quantified_hypothesis ist h)
+ | TacInductionDestruct (ev,isrec,l) ->
+ TacInductionDestruct (ev,isrec,List.map (fun (lc,cbo,(ipato,ipats),cls) ->
+ (List.map (intern_induction_arg ist) lc,
Option.map (intern_constr_with_bindings ist) cbo,
- intern_intro_pattern lf ist ids,
- Option.map (clause_app (intern_hyp_location ist)) cls)
+ (Option.map (intern_intro_pattern lf ist) ipato,
+ Option.map (intern_intro_pattern lf ist) ipats),
+ Option.map (clause_app (intern_hyp_location ist)) cls)) l)
| TacDoubleInduction (h1,h2) ->
let h1 = intern_quantified_hypothesis ist h1 in
let h2 = intern_quantified_hypothesis ist h2 in
@@ -778,7 +771,7 @@ let rec intern_atomic lf ist x =
| TacClear (b,l) -> TacClear (b,List.map (intern_hyp_or_metaid ist) l)
| TacClearBody l -> TacClearBody (List.map (intern_hyp_or_metaid ist) l)
| TacMove (dep,id1,id2) ->
- TacMove (dep,intern_hyp_or_metaid ist id1,intern_hyp_or_metaid ist id2)
+ TacMove (dep,intern_hyp_or_metaid ist id1,intern_move_location ist id2)
| TacRename l ->
TacRename (List.map (fun (id1,id2) ->
intern_hyp_or_metaid ist id1,
@@ -826,8 +819,7 @@ let rec intern_atomic lf ist x =
TacExtend (adjust_loc loc,opn,List.map (intern_genarg ist) l)
| TacAlias (loc,s,l,(dir,body)) ->
let l = List.map (fun (id,a) -> (id,intern_genarg ist a)) l in
- try TacAlias (loc,s,l,(dir,body))
- with e -> raise (locate_error_in_file (string_of_dirpath dir) e)
+ TacAlias (loc,s,l,(dir,body))
and intern_tactic ist tac = (snd (intern_tactic_seq ist tac) : glob_tactic_expr)
@@ -1205,8 +1197,8 @@ let coerce_to_intro_pattern env = function
IntroIdentifier (destVar c)
| v -> raise (CannotCoerceTo "an introduction pattern")
-let interp_intro_pattern_var ist env id =
- try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env)(dloc,id)
+let interp_intro_pattern_var loc ist env id =
+ try try_interp_ltac_var (coerce_to_intro_pattern env) ist (Some env) (loc,id)
with Not_found -> IntroIdentifier id
let coerce_to_hint_base = function
@@ -1225,7 +1217,7 @@ let interp_int ist locid =
try try_interp_ltac_var coerce_to_int ist None locid
with Not_found ->
user_err_loc(fst locid,"interp_int",
- str "Unbound variable" ++ pr_id (snd locid) ++ str".")
+ str "Unbound variable " ++ pr_id (snd locid) ++ str".")
let interp_int_or_var ist = function
| ArgVar locid -> interp_int ist locid
@@ -1285,6 +1277,11 @@ let interp_clause_pattern ist gl (l,occl) =
| [] -> []
in (l,check [] occl)
+let interp_move_location ist gl = function
+ | MoveAfter id -> MoveAfter (interp_hyp ist gl id)
+ | MoveBefore id -> MoveBefore (interp_hyp ist gl id)
+ | MoveToEnd toleft as x -> x
+
(* Interprets a qualified name *)
let coerce_to_reference env v =
try match v with
@@ -1362,15 +1359,15 @@ let rec constr_list_aux env = function
let constr_list ist env = constr_list_aux env ist.lfun
(* Extract the identifier list from lfun: join all branches (what to do else?)*)
-let rec intropattern_ids = function
+let rec intropattern_ids (loc,pat) = match pat with
| IntroIdentifier id -> [id]
| IntroOrAndPattern ll ->
List.flatten (List.map intropattern_ids (List.flatten ll))
- | IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _ -> []
+ | IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _ -> []
let rec extract_ids ids = function
| (id,VIntroPattern ipat)::tl when not (List.mem id ids) ->
- intropattern_ids ipat @ extract_ids ids tl
+ intropattern_ids (dloc,ipat) @ extract_ids ids tl
| _::tl -> extract_ids ids tl
| [] -> []
@@ -1441,7 +1438,7 @@ let solve_remaining_evars env initial_sigma evd c =
proc_rec c
let interp_gen kind ist sigma env (c,ce) =
- let (ltacvars,unbndltacvars) = constr_list ist env in
+ let (ltacvars,unbndltacvars as vars) = constr_list ist env in
let typs = retype_list sigma env ltacvars in
let c = match ce with
| None -> c
@@ -1451,7 +1448,8 @@ let interp_gen kind ist sigma env (c,ce) =
| Some c ->
let ltacdata = (List.map fst ltacvars,unbndltacvars) in
intern_gen (kind = IsType) ~ltacvars:ltacdata sigma env c in
- understand_ltac sigma env (typs,unbndltacvars) kind c
+ let trace = (dloc,LtacConstrInterp (c,vars))::ist.trace in
+ catch_error trace (understand_ltac sigma env (typs,unbndltacvars) kind) c
(* Interprets a constr and solve remaining evars with default tactic *)
let interp_econstr kind ist sigma env cc =
@@ -1618,31 +1616,38 @@ let inj_may_eval = function
let message_of_value = function
| VVoid -> str "()"
| VInteger n -> int n
- | VIntroPattern ipat -> pr_intro_pattern ipat
+ | VIntroPattern ipat -> pr_intro_pattern (dloc,ipat)
| VConstr_context c | VConstr c -> pr_constr c
- | VRec _ | VTactic _ | VRTactic _ | VFun _ -> str "<tactic>"
+ | VRec _ | VRTactic _ | VFun _ -> str "<tactic>"
| VList _ -> str "<list>"
-let rec interp_message ist = function
- | [] -> mt()
- | MsgString s :: l -> pr_arg str s ++ interp_message ist l
- | MsgInt n :: l -> pr_arg int n ++ interp_message ist l
- | MsgIdent (loc,id) :: l ->
+let rec interp_message_token ist = function
+ | MsgString s -> str s
+ | MsgInt n -> int n
+ | MsgIdent (loc,id) ->
let v =
try List.assoc id ist.lfun
with Not_found -> user_err_loc (loc,"",pr_id id ++ str" not found.") in
- pr_arg message_of_value v ++ interp_message ist l
+ message_of_value v
let rec interp_message_nl ist = function
| [] -> mt()
- | l -> interp_message ist l ++ fnl()
+ | l -> prlist_with_sep spc (interp_message_token ist) l ++ fnl()
-let rec interp_intro_pattern ist gl = function
- | IntroOrAndPattern l -> IntroOrAndPattern (interp_case_intro_pattern ist gl l)
- | IntroIdentifier id -> interp_intro_pattern_var ist (pf_env gl) id
- | IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _ as x -> x
+let interp_message ist l =
+ (* Force evaluation of interp_message_token so that potential errors
+ are raised now and not at printing time *)
+ prlist (fun x -> spc () ++ x) (List.map (interp_message_token ist) l)
-and interp_case_intro_pattern ist gl =
+let rec interp_intro_pattern ist gl = function
+ | loc, IntroOrAndPattern l ->
+ loc, IntroOrAndPattern (interp_or_and_intro_pattern ist gl l)
+ | loc, IntroIdentifier id ->
+ loc, interp_intro_pattern_var loc ist (pf_env gl) id
+ | loc, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)
+ as x -> x
+
+and interp_or_and_intro_pattern ist gl =
List.map (List.map (interp_intro_pattern ist gl))
(* Quantified named or numbered hypothesis or hypothesis in context *)
@@ -1716,14 +1721,14 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
let value_interp ist = match tac with
(* Immediate evaluation *)
- | TacFun (it,body) -> VFun (ist.lfun,it,body)
+ | TacFun (it,body) -> VFun (ist.trace,ist.lfun,it,body)
| TacLetIn (true,l,u) -> interp_letrec ist gl l u
| TacLetIn (false,l,u) -> interp_letin ist gl l u
| TacMatchContext (lz,lr,lmr) -> interp_match_context ist gl lz lr lmr
| TacMatch (lz,c,lmr) -> interp_match ist gl lz c lmr
| TacArg a -> interp_tacarg ist gl a
(* Delayed evaluation *)
- | t -> VTactic (ist.last_loc,eval_tactic ist t)
+ | t -> VFun (ist.trace,ist.lfun,[],t)
in check_for_interrupt ();
match ist.debug with
@@ -1732,7 +1737,14 @@ let rec val_interp ist gl (tac:glob_tactic_expr) =
| _ -> value_interp ist
and eval_tactic ist = function
- | TacAtom (loc,t) -> fun gl -> catch_error loc (interp_atomic ist gl t) gl
+ | TacAtom (loc,t) ->
+ fun gl ->
+ let box = ref None in abstract_tactic_box := box;
+ let call = LtacAtomCall (t,box) in
+ let tac = (* catch error in the interpretation *)
+ catch_error ((dloc,call)::ist.trace) (interp_atomic ist gl) t in
+ (* catch error in the evaluation *)
+ catch_error ((loc,call)::ist.trace) tac gl
| TacFun _ | TacLetIn _ -> assert false
| TacMatchContext _ | TacMatch _ -> assert false
| TacId s -> tclIDTAC_MESSAGE (interp_message_nl ist s)
@@ -1767,31 +1779,33 @@ and force_vrec ist gl = function
| VRec (lfun,body) -> val_interp {ist with lfun = !lfun} gl body
| v -> v
-and interp_ltac_reference isapplied mustbetac ist gl = function
+and interp_ltac_reference loc' mustbetac ist gl = function
| ArgVar (loc,id) ->
let v = List.assoc id ist.lfun in
let v = force_vrec ist gl v in
+ let v = propagate_trace ist loc id v in
if mustbetac then coerce_to_tactic loc id v else v
| ArgArg (loc,r) ->
let ids = extract_ids [] ist.lfun in
+ let loc_info = ((if loc' = dloc then loc else loc'),LtacNameCall r) in
let ist =
{ lfun=[]; debug=ist.debug; avoid_ids=ids;
- last_loc = if isapplied then ist.last_loc else loc } in
+ trace = loc_info::ist.trace } in
val_interp ist gl (lookup r)
and interp_tacarg ist gl = function
| TacVoid -> VVoid
- | Reference r -> interp_ltac_reference false false ist gl r
+ | Reference r -> interp_ltac_reference dloc false ist gl r
| Integer n -> VInteger n
- | IntroPattern ipat -> VIntroPattern (interp_intro_pattern ist gl ipat)
+ | IntroPattern ipat -> VIntroPattern (snd (interp_intro_pattern ist gl ipat))
| ConstrMayEval c -> VConstr (interp_constr_may_eval ist gl c)
| MetaIdArg (loc,_,id) -> assert false
- | TacCall (loc,r,[]) -> interp_ltac_reference false true ist gl r
+ | TacCall (loc,r,[]) -> interp_ltac_reference loc true ist gl r
| TacCall (loc,f,l) ->
- let fv = interp_ltac_reference true true ist gl f
+ let fv = interp_ltac_reference loc true ist gl f
and largs = List.map (interp_tacarg ist gl) l in
List.iter check_is_value largs;
- interp_app ist gl fv largs loc
+ interp_app loc ist gl fv largs
| TacExternal (loc,com,req,la) ->
interp_external loc ist gl com req (List.map (interp_tacarg ist gl) la)
| TacFreshId l ->
@@ -1801,12 +1815,7 @@ and interp_tacarg ist gl = function
| TacDynamic(_,t) ->
let tg = (tag t) in
if tg = "tactic" then
- let f = (tactic_out t) in
- val_interp ist gl
- (intern_tactic {
- ltacvars = (List.map fst ist.lfun,[]); ltacrecvars = [];
- gsigma = project gl; genv = pf_env gl }
- (f ist))
+ val_interp ist gl (tactic_out t ist)
else if tg = "value" then
value_out t
else if tg = "constr" then
@@ -1816,32 +1825,34 @@ and interp_tacarg ist gl = function
(str "Unknown dynamic: <" ++ str (Dyn.tag t) ++ str ">"))
(* Interprets an application node *)
-and interp_app ist gl fv largs loc =
+and interp_app loc ist gl fv largs =
match fv with
- | VFun(olfun,var,body) ->
+ | VFun(trace,olfun,var,body) ->
let (newlfun,lvar,lval)=head_with_value (var,largs) in
if lvar=[] then
let v =
try
- let lloc = if lval=[] then loc else ist.last_loc in
- val_interp { ist with lfun=newlfun@olfun; last_loc=lloc } gl body
+ catch_error trace
+ (val_interp { ist with lfun=newlfun@olfun; trace=trace } gl) body
with e ->
debugging_exception_step ist false e (fun () -> str "evaluation");
raise e in
debugging_step ist (fun () ->
str "evaluation returns" ++ fnl() ++ pr_value (Some (pf_env gl)) v);
- if lval=[] then v else interp_app ist gl v lval loc
+ if lval=[] then v else interp_app loc ist gl v lval
else
- VFun(newlfun@olfun,lvar,body)
+ VFun(trace,newlfun@olfun,lvar,body)
| _ ->
user_err_loc (loc, "Tacinterp.interp_app",
(str"Illegal tactic application."))
(* Gives the tactic corresponding to the tactic value *)
-and tactic_of_value vle g =
+and tactic_of_value ist vle g =
match vle with
| VRTactic res -> res
- | VTactic (loc,tac) -> catch_error loc tac g
+ | VFun (trace,lfun,[],t) ->
+ let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
+ catch_error trace tac g
| VFun _ -> error "A fully applied tactic is expected."
| _ -> raise NotTactic
@@ -1849,15 +1860,19 @@ and tactic_of_value vle g =
and eval_with_fail ist is_lazy goal tac =
try
(match val_interp ist goal tac with
- | VTactic (loc,tac) when not is_lazy -> VRTactic (catch_error loc tac goal)
+ | VFun (trace,lfun,[],t) when not is_lazy ->
+ let tac = eval_tactic {ist with lfun=lfun; trace=trace} t in
+ VRTactic (catch_error trace tac goal)
| a -> a)
with
- | Stdpp.Exc_located (_,FailError (0,s)) | FailError (0,s) ->
+ | FailError (0,s) | Stdpp.Exc_located(_, FailError (0,s))
+ | Stdpp.Exc_located(_,LtacLocated (_,FailError (0,s))) ->
raise (Eval_fail s)
- | Stdpp.Exc_located (s',FailError (lvl,s)) ->
- raise (Stdpp.Exc_located (s',FailError (lvl - 1, s)))
- | FailError (lvl,s) ->
- raise (FailError (lvl - 1, s))
+ | FailError (lvl,s) -> raise (FailError (lvl - 1, s))
+ | Stdpp.Exc_located(s,FailError (lvl,s')) ->
+ raise (Stdpp.Exc_located(s,FailError (lvl - 1, s')))
+ | Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl,s'))) ->
+ raise (Stdpp.Exc_located(s,LtacLocated (s'',FailError (lvl - 1, s'))))
(* Interprets the clauses of a recursive LetIn *)
and interp_letrec ist gl llc u =
@@ -2119,9 +2134,8 @@ and interp_ltac_constr ist gl e =
str "offending expression: " ++ fnl() ++
Pptactic.pr_glob_tactic (pf_env gl) e ++ fnl() ++ str "this is a " ++
(match result with
- VTactic _ -> str "VTactic"
| VRTactic _ -> str "VRTactic"
- | VFun (il,ul,b) ->
+ | VFun (_,il,ul,b) ->
(str "VFun with body " ++ fnl() ++
Pptactic.pr_glob_tactic (pf_env gl) b ++ fnl() ++
str "instantiated arguments " ++ fnl() ++
@@ -2135,7 +2149,7 @@ and interp_ltac_constr ist gl e =
(match opt_id with
Some id -> str (string_of_id id)
| None -> str "_") ++ str ", " ++ s)
- ul (str ""))
+ ul (mt()))
| VVoid -> str "VVoid"
| VInteger _ -> str "VInteger"
| VConstr _ -> str "VConstr"
@@ -2146,9 +2160,8 @@ and interp_ltac_constr ist gl e =
(* Interprets tactic expressions : returns a "tactic" *)
and interp_tactic ist tac gl =
- try tactic_of_value (val_interp ist gl tac) gl
- with NotTactic ->
- errorlabstrm "" (str "Must be a command or must give a tactic value.")
+ try tactic_of_value ist (val_interp ist gl tac) gl
+ with NotTactic -> errorlabstrm "" (str "Not a tactic.")
(* Interprets a primitive tactic *)
and interp_atomic ist gl = function
@@ -2157,14 +2170,15 @@ and interp_atomic ist gl = function
h_intro_patterns (List.map (interp_intro_pattern ist gl) l)
| TacIntrosUntil hyp ->
h_intros_until (interp_quantified_hypothesis ist hyp)
- | TacIntroMove (ido,ido') ->
+ | TacIntroMove (ido,hto) ->
h_intro_move (Option.map (interp_fresh_ident ist gl) ido)
- (Option.map (interp_hyp ist gl) ido')
+ (interp_move_location ist gl hto)
| TacAssumption -> h_assumption
| TacExact c -> h_exact (pf_interp_casted_constr ist gl c)
| TacExactNoCheck c -> h_exact_no_check (pf_interp_constr ist gl c)
| TacVmCastNoCheck c -> h_vm_cast_no_check (pf_interp_constr ist gl c)
- | TacApply (a,ev,cb) -> h_apply a ev (interp_constr_with_bindings ist gl cb)
+ | TacApply (a,ev,cb) ->
+ h_apply a ev (List.map (interp_constr_with_bindings ist gl) cb)
| TacElim (ev,cb,cbo) ->
h_elim ev (interp_constr_with_bindings ist gl cb)
(Option.map (interp_constr_with_bindings ist gl) cbo)
@@ -2210,20 +2224,16 @@ and interp_atomic ist gl = function
(pf_interp_constr_list ist gl lems)
(* Derived basic tactics *)
- | TacSimpleInduction h ->
- h_simple_induction (interp_quantified_hypothesis ist h)
- | TacNewInduction (ev,lc,cbo,ids,cls) ->
- h_new_induction ev (List.map (interp_induction_arg ist gl) lc)
- (Option.map (interp_constr_with_bindings ist gl) cbo)
- (interp_intro_pattern ist gl ids)
- (Option.map (interp_clause ist gl) cls)
- | TacSimpleDestruct h ->
- h_simple_destruct (interp_quantified_hypothesis ist h)
- | TacNewDestruct (ev,c,cbo,ids,cls) ->
- h_new_destruct ev (List.map (interp_induction_arg ist gl) c)
- (Option.map (interp_constr_with_bindings ist gl) cbo)
- (interp_intro_pattern ist gl ids)
- (Option.map (interp_clause ist gl) cls)
+ | TacSimpleInductionDestruct (isrec,h) ->
+ h_simple_induction_destruct isrec (interp_quantified_hypothesis ist h)
+ | TacInductionDestruct (isrec,ev,l) ->
+ h_induction_destruct ev isrec
+ (List.map (fun (lc,cbo,(ipato,ipats),cls) ->
+ (List.map (interp_induction_arg ist gl) lc,
+ Option.map (interp_constr_with_bindings ist gl) cbo,
+ (Option.map (interp_intro_pattern ist gl) ipato,
+ Option.map (interp_intro_pattern ist gl) ipats),
+ Option.map (interp_clause ist gl) cls)) l)
| TacDoubleInduction (h1,h2) ->
let h1 = interp_quantified_hypothesis ist h1 in
let h2 = interp_quantified_hypothesis ist h2 in
@@ -2241,7 +2251,7 @@ and interp_atomic ist gl = function
| TacClear (b,l) -> h_clear b (interp_hyp_list ist gl l)
| TacClearBody l -> h_clear_body (interp_hyp_list ist gl l)
| TacMove (dep,id1,id2) ->
- h_move dep (interp_hyp ist gl id1) (interp_hyp ist gl id2)
+ h_move dep (interp_hyp ist gl id1) (interp_move_location ist gl id2)
| TacRename l ->
h_rename (List.map (fun (id1,id2) ->
interp_hyp ist gl id1,
@@ -2283,11 +2293,11 @@ and interp_atomic ist gl = function
(Option.map (interp_tactic ist) by)
| TacInversion (DepInversion (k,c,ids),hyp) ->
Inv.dinv k (Option.map (pf_interp_constr ist gl) c)
- (interp_intro_pattern ist gl ids)
+ (Option.map (interp_intro_pattern ist gl) ids)
(interp_declared_or_quantified_hypothesis ist gl hyp)
| TacInversion (NonDepInversion (k,idl,ids),hyp) ->
Inv.inv_clause k
- (interp_intro_pattern ist gl ids)
+ (Option.map (interp_intro_pattern ist gl) ids)
(interp_hyp_list ist gl idl)
(interp_declared_or_quantified_hypothesis ist gl hyp)
| TacInversion (InversionUsing (c,idl),hyp) ->
@@ -2298,10 +2308,9 @@ and interp_atomic ist gl = function
(* For extensions *)
| TacExtend (loc,opn,l) ->
let tac = lookup_tactic opn in
- fun gl ->
- let args = List.map (interp_genarg ist gl) l in
- abstract_extended_tactic opn args (tac args) gl
- | TacAlias (loc,_,l,(_,body)) -> fun gl ->
+ let args = List.map (interp_genarg ist gl) l in
+ abstract_extended_tactic opn args (tac args)
+ | TacAlias (loc,s,l,(_,body)) -> fun gl ->
let rec f x = match genarg_tag x with
| IntArgType ->
VInteger (out_gen globwit_int x)
@@ -2311,7 +2320,7 @@ and interp_atomic ist gl = function
failwith "pre-identifiers cannot be bound"
| IntroPatternArgType ->
VIntroPattern
- (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x))
+ (snd (interp_intro_pattern ist gl (out_gen globwit_intro_pattern x)))
| IdentArgType ->
VIntroPattern
(IntroIdentifier
@@ -2366,10 +2375,8 @@ and interp_atomic ist gl = function
in
let lfun = (List.map (fun (x,c) -> (x,f c)) l)@ist.lfun in
- let v = locate_tactic_call loc (val_interp { ist with lfun=lfun } gl body)
- in
- try tactic_of_value v gl
- with NotTactic -> user_err_loc (loc,"",str "Not a tactic.")
+ let trace = (loc,LtacNotationCall s)::ist.trace in
+ interp_tactic { ist with lfun=lfun; trace=trace } body gl
let make_empty_glob_sign () =
{ ltacvars = ([],[]); ltacrecvars = [];
@@ -2377,20 +2384,20 @@ let make_empty_glob_sign () =
(* Initial call for interpretation *)
let interp_tac_gen lfun avoid_ids debug t gl =
- interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; last_loc=dloc }
+ interp_tactic { lfun=lfun; avoid_ids=avoid_ids; debug=debug; trace=[] }
(intern_tactic {
ltacvars = (List.map fst lfun, []); ltacrecvars = [];
gsigma = project gl; genv = pf_env gl } t) gl
let eval_tactic t gls =
- interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); last_loc=dloc }
+ interp_tactic { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] }
t gls
let interp t = interp_tac_gen [] [] (get_debug()) t
let eval_ltac_constr gl t =
interp_ltac_constr
- { lfun=[]; avoid_ids=[]; debug=get_debug(); last_loc=dloc } gl
+ { lfun=[]; avoid_ids=[]; debug=get_debug(); trace=[] } gl
(intern_tactic (make_empty_glob_sign ()) t )
(* Hides interpretation for pretty-print *)
@@ -2453,7 +2460,7 @@ let subst_global_reference subst =
let subst_global ref =
let ref',t' = subst_global subst ref in
if not (eq_constr (constr_of_global ref') t') then
- ppnl (str "Warning: the reference " ++ pr_global ref ++ str " is not " ++
+ ppnl (str "Warning: The reference " ++ pr_global ref ++ str " is not " ++
str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++
pr_global ref') ;
ref'
@@ -2507,7 +2514,8 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
| TacExact c -> TacExact (subst_rawconstr subst c)
| TacExactNoCheck c -> TacExactNoCheck (subst_rawconstr subst c)
| TacVmCastNoCheck c -> TacVmCastNoCheck (subst_rawconstr subst c)
- | TacApply (a,ev,cb) -> TacApply (a,ev,subst_raw_with_bindings subst cb)
+ | TacApply (a,ev,cb) ->
+ TacApply (a,ev,List.map (subst_raw_with_bindings subst) cb)
| TacElim (ev,cb,cbo) ->
TacElim (ev,subst_raw_with_bindings subst cb,
Option.map (subst_raw_with_bindings subst) cbo)
@@ -2538,14 +2546,11 @@ let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with
| TacDAuto (n,p,lems) -> TacDAuto (n,p,List.map (subst_rawconstr subst) lems)
(* Derived basic tactics *)
- | TacSimpleInduction h as x -> x
- | TacNewInduction (ev,lc,cbo,ids,cls) ->
- TacNewInduction (ev,List.map (subst_induction_arg subst) lc,
- Option.map (subst_raw_with_bindings subst) cbo, ids, cls)
- | TacSimpleDestruct h as x -> x
- | TacNewDestruct (ev,c,cbo,ids,cls) ->
- TacNewDestruct (ev,List.map (subst_induction_arg subst) c,
- Option.map (subst_raw_with_bindings subst) cbo, ids, cls)
+ | TacSimpleInductionDestruct (isrec,h) as x -> x
+ | TacInductionDestruct (isrec,ev,l) ->
+ TacInductionDestruct (isrec,ev,List.map (fun (lc,cbo,ids,cls) ->
+ List.map (subst_induction_arg subst) lc,
+ Option.map (subst_raw_with_bindings subst) cbo, ids, cls) l)
| TacDoubleInduction (h1,h2) as x -> x
| TacDecomposeAnd c -> TacDecomposeAnd (subst_rawconstr subst c)
| TacDecomposeOr c -> TacDecomposeOr (subst_rawconstr subst c)
@@ -2771,7 +2776,7 @@ let print_ltac id =
try
let kn = Nametab.locate_tactic id in
let t = lookup kn in
- str "Ltac" ++ spc() ++ pr_qualid id ++ str ":=" ++ spc() ++
+ str "Ltac" ++ spc() ++ pr_qualid id ++ str " :=" ++ spc() ++
Pptactic.pr_glob_tactic (Global.env ()) t
with
Not_found ->
@@ -2846,17 +2851,33 @@ let glob_tactic_env l env x =
x
let interp_redexp env sigma r =
- let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); last_loc=dloc } in
+ let ist = { lfun=[]; avoid_ids=[]; debug=get_debug (); trace=[] } in
let gist = {(make_empty_glob_sign ()) with genv = env; gsigma = sigma } in
interp_red_expr ist sigma env (intern_red_expr gist r)
(***************************************************************************)
+(* Embed tactics in raw or glob tactic expr *)
+
+let globTacticIn t = TacArg (TacDynamic (dummy_loc,tactic_in t))
+let tacticIn t = globTacticIn (fun ist -> glob_tactic (t ist))
+
+let tacticOut = function
+ | TacArg (TacDynamic (_,d)) ->
+ if (tag d) = "tactic" then
+ tactic_out d
+ else
+ anomalylabstrm "tacticOut" (str "Dynamic tag should be tactic")
+ | ast ->
+ anomalylabstrm "tacticOut"
+ (str "Not a Dynamic ast: " (* ++ print_ast ast*) )
+
+(***************************************************************************)
(* Backwarding recursive needs of tactic glob/interp/eval functions *)
let _ = Auto.set_extern_interp
(fun l ->
let l = List.map (fun (id,c) -> (id,VConstr c)) l in
- interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); last_loc=dloc})
+ interp_tactic {lfun=l;avoid_ids=[];debug=get_debug(); trace=[]})
let _ = Auto.set_extern_intern_tac
(fun l ->
Flags.with_option strict_check
diff --git a/tactics/tacinterp.mli b/tactics/tacinterp.mli
index 2a490fdac..5c040821b 100644
--- a/tactics/tacinterp.mli
+++ b/tactics/tacinterp.mli
@@ -26,9 +26,9 @@ open Redexpr
(* Values for interpretation *)
type value =
- | VTactic of Util.loc * tactic (* For mixed ML/Ltac tactics (e.g. Tauto) *)
| VRTactic of (goal list sigma * validation)
- | VFun of (identifier * value) list * identifier option list * glob_tactic_expr
+ | VFun of ltac_trace * (identifier*value) list *
+ identifier option list * glob_tactic_expr
| VVoid
| VInteger of int
| VIntroPattern of intro_pattern_expr
@@ -42,18 +42,16 @@ and interp_sign =
{ lfun : (identifier * value) list;
avoid_ids : identifier list;
debug : debug_info;
- last_loc : loc }
+ trace : ltac_trace }
(* Transforms an id into a constr if possible *)
val constr_of_id : Environ.env -> identifier -> constr
(* To embed several objects in Coqast.t *)
val tacticIn : (interp_sign -> raw_tactic_expr) -> raw_tactic_expr
-val tacticOut : raw_tactic_expr -> (interp_sign -> raw_tactic_expr)
+val globTacticIn : (interp_sign -> glob_tactic_expr) -> raw_tactic_expr
val valueIn : value -> raw_tactic_arg
-val valueOut: raw_tactic_arg -> value
val constrIn : constr -> constr_expr
-val constrOut : constr_expr -> constr
(* Sets the debugger mode *)
val set_debug : debug_info -> unit
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 13ce33444..bbd9112d4 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -270,19 +270,28 @@ type branch_args = {
nassums : int; (* the number of assumptions to be introduced *)
branchsign : bool list; (* the signature of the branch.
true=recursive argument, false=constant *)
- branchnames : intro_pattern_expr list}
+ branchnames : intro_pattern_expr located list}
type branch_assumptions = {
ba : branch_args; (* the branch args *)
assums : named_context} (* the list of assumptions introduced *)
+let check_or_and_pattern_size loc names n =
+ if List.length names <> n then
+ if n = 1 then
+ user_err_loc (loc,"",str "Expects a conjunctive pattern.")
+ else
+ user_err_loc (loc,"",str "Expects a disjunctive pattern with " ++ int n
+ ++ str " branches.")
+
let compute_induction_names n = function
- | IntroAnonymous ->
+ | None ->
Array.make n []
- | IntroOrAndPattern names when List.length names = n ->
+ | Some (loc,IntroOrAndPattern names) ->
+ check_or_and_pattern_size loc names n;
Array.of_list names
| _ ->
- errorlabstrm "" (str "Expects " ++ int n ++ str " lists of names.")
+ error "Unexpected introduction pattern."
let compute_construtor_signatures isrec (_,k as ity) =
let rec analrec c recargs =
@@ -393,7 +402,7 @@ let elimination_then_using tac predicate bindings c gl =
let (ind,t) = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
let indclause = mk_clenv_from gl (c,t) in
general_elim_then_using gl_make_elim
- true IntroAnonymous tac predicate bindings ind indclause gl
+ true None tac predicate bindings ind indclause gl
let case_then_using =
general_elim_then_using gl_make_case_dep false
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index d7620acf2..8cc556c62 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -10,6 +10,7 @@
(*i*)
open Pp
+open Util
open Names
open Term
open Sign
@@ -124,23 +125,30 @@ type branch_args = {
nassums : int; (* the number of assumptions to be introduced *)
branchsign : bool list; (* the signature of the branch.
true=recursive argument, false=constant *)
- branchnames : intro_pattern_expr list}
+ branchnames : intro_pattern_expr located list}
type branch_assumptions = {
ba : branch_args; (* the branch args *)
assums : named_context} (* the list of assumptions introduced *)
+(* [check_disjunctive_pattern_size loc pats n] returns an appropriate *)
+(* error message if |pats| <> n *)
+val check_or_and_pattern_size :
+ Util.loc -> or_and_intro_pattern_expr -> int -> unit
+
(* Useful for [as intro_pattern] modifier *)
val compute_induction_names :
- int -> intro_pattern_expr -> intro_pattern_expr list array
+ int -> intro_pattern_expr located option ->
+ intro_pattern_expr located list array
val elimination_sort_of_goal : goal sigma -> sorts_family
val elimination_sort_of_hyp : identifier -> goal sigma -> sorts_family
val general_elim_then_using :
- (inductive -> goal sigma -> constr) -> rec_flag -> intro_pattern_expr ->
- (branch_args -> tactic) -> constr option ->
- (arg_bindings * arg_bindings) -> inductive -> clausenv -> tactic
+ (inductive -> goal sigma -> constr) -> rec_flag ->
+ intro_pattern_expr located option -> (branch_args -> tactic) ->
+ constr option -> (arg_bindings * arg_bindings) -> inductive -> clausenv ->
+ tactic
val elimination_then_using :
(branch_args -> tactic) -> constr option ->
@@ -151,12 +159,12 @@ val elimination_then :
(arg_bindings * arg_bindings) -> constr -> tactic
val case_then_using :
- intro_pattern_expr -> (branch_args -> tactic) ->
+ intro_pattern_expr located option -> (branch_args -> tactic) ->
constr option -> (arg_bindings * arg_bindings) ->
inductive -> clausenv -> tactic
val case_nodep_then_using :
- intro_pattern_expr -> (branch_args -> tactic) ->
+ intro_pattern_expr located option -> (branch_args -> tactic) ->
constr option -> (arg_bindings * arg_bindings) ->
inductive -> clausenv -> tactic
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index cb2acc9bd..23524e850 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -75,6 +75,8 @@ let inj_ebindings = function
| ExplicitBindings l ->
ExplicitBindings (List.map (fun (l,id,c) -> (l,id,inj_open c)) l)
+let dloc = dummy_loc
+
(*********************************************)
(* Tactics *)
(*********************************************)
@@ -126,15 +128,44 @@ let bad_tactic_args s l =
(******************************************)
let introduction = Tacmach.introduction
-let intro_replacing = Tacmach.intro_replacing
-let internal_cut = Tacmach.internal_cut
-let internal_cut_rev = Tacmach.internal_cut_rev
let refine = Tacmach.refine
let convert_concl = Tacmach.convert_concl
let convert_hyp = Tacmach.convert_hyp
-let thin = Tacmach.thin
let thin_body = Tacmach.thin_body
+let error_clear_dependency env id = function
+ | Evarutil.OccurHypInSimpleClause None ->
+ errorlabstrm "" (pr_id id ++ str " is used in conclusion.")
+ | Evarutil.OccurHypInSimpleClause (Some id') ->
+ errorlabstrm ""
+ (pr_id id ++ strbrk " is used in hypothesis " ++ pr_id id' ++ str".")
+ | Evarutil.EvarTypingBreak ev ->
+ errorlabstrm ""
+ (str "Cannot remove " ++ pr_id id ++
+ strbrk " without breaking the typing of " ++
+ Printer.pr_existential env ev ++ str".")
+
+let thin l gl =
+ try thin l gl
+ with Evarutil.ClearDependencyError (id,err) ->
+ error_clear_dependency (pf_env gl) id err
+
+let internal_cut_gen b d t gl =
+ try internal_cut b d t gl
+ with Evarutil.ClearDependencyError (id,err) ->
+ error_clear_dependency (pf_env gl) id err
+
+let internal_cut = internal_cut_gen false
+let internal_cut_replace = internal_cut_gen true
+
+let internal_cut_rev_gen b d t gl =
+ try internal_cut_rev b d t gl
+ with Evarutil.ClearDependencyError (id,err) ->
+ error_clear_dependency (pf_env gl) id err
+
+let internal_cut_rev = internal_cut_rev_gen false
+let internal_cut_rev_replace = internal_cut_rev_gen true
+
(* Moving hypotheses *)
let move_hyp = Tacmach.move_hyp
@@ -273,15 +304,19 @@ let fresh_id_avoid avoid id =
let fresh_id avoid id gl =
fresh_id_avoid (avoid@(pf_ids_of_hyps gl)) id
-let id_of_name_with_default s = function
- | Anonymous -> id_of_string s
+let id_of_name_with_default id = function
+ | Anonymous -> id
| Name id -> id
+let hid = id_of_string "H"
+let xid = id_of_string "X"
+
+let default_id_of_sort = function Prop _ -> hid | Type _ -> xid
+
let default_id env sigma = function
| (name,None,t) ->
- (match Typing.sort_of env sigma t with
- | Prop _ -> (id_of_name_with_default "H" name)
- | Type _ -> (id_of_name_with_default "X" name))
+ let dft = default_id_of_sort (Typing.sort_of env sigma t) in
+ id_of_name_with_default dft name
| (name,Some b,_) -> id_of_name_using_hdchar env b name
(* Non primitive introduction tactics are treated by central_intro
@@ -293,14 +328,14 @@ type intro_name_flag =
| IntroBasedOn of identifier * identifier list
| IntroMustBe of identifier
-let find_name decl gl = function
+let find_name loc decl gl = function
| IntroAvoid idl ->
(* this case must be compatible with [find_intro_names] below. *)
let id = fresh_id idl (default_id (pf_env gl) gl.sigma decl) gl in id
| IntroBasedOn (id,idl) -> fresh_id idl id gl
- | IntroMustBe id ->
+ | IntroMustBe id ->
let id' = fresh_id [] id gl in
- if id' <> id then error ((string_of_id id)^" is already used.");
+ if id'<>id then user_err_loc (loc,"",pr_id id ++ str" is already used.");
id'
(* Returns the names that would be created by intros, without doing
@@ -319,65 +354,72 @@ let find_intro_names ctxt gl =
ctxt (pf_env gl , []) in
List.rev res
-
let build_intro_tac id = function
- | None -> introduction id
- | Some dest -> tclTHEN (introduction id) (move_hyp true id dest)
+ | MoveToEnd true -> introduction id
+ | dest -> tclTHEN (introduction id) (move_hyp true id dest)
-let rec intro_gen name_flag move_flag force_flag gl =
+let rec intro_gen loc name_flag move_flag force_flag gl =
match kind_of_term (pf_concl gl) with
| Prod (name,t,_) ->
- build_intro_tac (find_name (name,None,t) gl name_flag) move_flag gl
+ build_intro_tac (find_name loc (name,None,t) gl name_flag) move_flag gl
| LetIn (name,b,t,_) ->
- build_intro_tac (find_name (name,Some b,t) gl name_flag) move_flag gl
+ build_intro_tac (find_name loc (name,Some b,t) gl name_flag) move_flag
+ gl
| _ ->
if not force_flag then raise (RefinerError IntroNeedsProduct);
try
tclTHEN
(reduce (Red true) onConcl)
- (intro_gen name_flag move_flag force_flag) gl
+ (intro_gen loc name_flag move_flag force_flag) gl
with Redelimination ->
- errorlabstrm "Intro" (str "No product even after head-reduction.")
+ user_err_loc(loc,"Intro",str "No product even after head-reduction.")
-let intro_mustbe_force id = intro_gen (IntroMustBe id) None true
-let intro_using id = intro_gen (IntroBasedOn (id,[])) None false
-let intro_force force_flag = intro_gen (IntroAvoid []) None force_flag
+let intro_mustbe_force id = intro_gen dloc (IntroMustBe id) no_move true
+let intro_using id = intro_gen dloc (IntroBasedOn (id,[])) no_move false
+let intro_force force_flag = intro_gen dloc (IntroAvoid []) no_move force_flag
let intro = intro_force false
let introf = intro_force true
-let intro_avoiding l = intro_gen (IntroAvoid l) None false
-
-let introf_move_name destopt = intro_gen (IntroAvoid []) destopt true
+let intro_avoiding l = intro_gen dloc (IntroAvoid l) no_move false
-(* For backwards compatibility *)
-let central_intro = intro_gen
+let introf_move_name destopt = intro_gen dloc (IntroAvoid []) destopt true
(**** Multiple introduction tactics ****)
let rec intros_using = function
- [] -> tclIDTAC
- | str::l -> tclTHEN (intro_using str) (intros_using l)
+ | [] -> tclIDTAC
+ | str::l -> tclTHEN (intro_using str) (intros_using l)
let intros = tclREPEAT (intro_force false)
let intro_erasing id = tclTHEN (thin [id]) (introduction id)
+let rec get_next_hyp_position id = function
+ | [] -> error ("No such hypothesis: " ^ string_of_id id)
+ | (hyp,_,_) :: right ->
+ if hyp = id then
+ match right with (id,_,_)::_ -> MoveBefore id | [] -> MoveToEnd true
+ else
+ get_next_hyp_position id right
+
+let intro_replacing id gl =
+ let next_hyp = get_next_hyp_position id (pf_hyps gl) in
+ tclTHENLIST [thin [id]; introduction id; move_hyp true id next_hyp] gl
+
let intros_replacing ids gl =
let rec introrec = function
| [] -> tclIDTAC
| id::tl ->
- (tclTHEN (tclORELSE (intro_replacing id)
- (tclORELSE (intro_erasing id) (* ?? *)
- (intro_using id)))
- (introrec tl))
+ tclTHEN (tclORELSE (intro_replacing id) (intro_using id))
+ (introrec tl)
in
introrec ids gl
(* User-level introduction tactics *)
-let intro_move idopt idopt' = match idopt with
- | None -> intro_gen (IntroAvoid []) idopt' true
- | Some id -> intro_gen (IntroMustBe id) idopt' true
+let intro_move idopt hto = match idopt with
+ | None -> intro_gen dloc (IntroAvoid []) hto true
+ | Some id -> intro_gen dloc (IntroMustBe id) hto true
let pf_lookup_hypothesis_as_renamed env ccl = function
| AnonHyp n -> pf_lookup_index_as_renamed env ccl n
@@ -435,7 +477,7 @@ let try_intros_until tac = function
let rec intros_move = function
| [] -> tclIDTAC
| (hyp,destopt) :: rest ->
- tclTHEN (intro_gen (IntroMustBe hyp) destopt false)
+ tclTHEN (intro_gen dloc (IntroMustBe hyp) destopt false)
(intros_move rest)
let dependent_in_decl a (_,c,t) =
@@ -443,33 +485,6 @@ let dependent_in_decl a (_,c,t) =
| None -> dependent a t
| Some body -> dependent a body || dependent a t
-let move_to_rhyp rhyp gl =
- let rec get_lhyp lastfixed depdecls = function
- | [] ->
- (match rhyp with
- | None -> lastfixed
- | Some h -> anomaly ("Hypothesis should occur: "^ (string_of_id h)))
- | (hyp,c,typ) as ht :: rest ->
- if Some hyp = rhyp then
- lastfixed
- else if List.exists (occur_var_in_decl (pf_env gl) hyp) depdecls then
- get_lhyp lastfixed (ht::depdecls) rest
- else
- get_lhyp (Some hyp) depdecls rest
- in
- let sign = pf_hyps gl in
- let (hyp,c,typ as decl) = List.hd sign in
- match get_lhyp None [decl] (List.tl sign) with
- | None -> tclIDTAC gl
- | Some hypto -> move_hyp true hyp hypto gl
-
-let rec intros_rmove = function
- | [] -> tclIDTAC
- | (hyp,destopt) :: rest ->
- tclTHENLIST [ introduction hyp;
- move_to_rhyp destopt;
- intros_rmove rest ]
-
(* Apply a tactic on a quantified hypothesis, an hypothesis in context
or a term with bindings *)
@@ -530,9 +545,7 @@ let cut_intro t = tclTHENFIRST (cut t) intro
(* cut_replacing échoue si l'hypothèse à remplacer apparaît dans le
but, ou dans une autre hypothèse *)
let cut_replacing id t tac =
- tclTHENS (cut t) [
- tclORELSE (intro_replacing id) (intro_erasing id);
- tac (refine_no_check (mkVar id)) ]
+ tclTHENS (cut t) [ intro_replacing id; tac (refine_no_check (mkVar id)) ]
let cut_in_parallel l =
let rec prec = function
@@ -644,6 +657,12 @@ let simplest_elim c = default_elim false (c,NoBindings)
(e.g. it could replace id:A->B->C by id:C, knowing A/\B)
*)
+let clenv_fchain_in id elim_flags mv elimclause hypclause =
+ try clenv_fchain ~allow_K:false ~flags:elim_flags mv elimclause hypclause
+ with PretypeError (env,NoOccurrenceFound (op,_)) ->
+ (* Set the hypothesis name in the message *)
+ raise (PretypeError (env,NoOccurrenceFound (op,Some id)))
+
let elimination_in_clause_scheme with_evars id elimclause indclause gl =
let (hypmv,indmv) =
match clenv_independent elimclause with
@@ -654,8 +673,8 @@ let elimination_in_clause_scheme with_evars id elimclause indclause gl =
let hyp = mkVar id in
let hyp_typ = pf_type_of gl hyp in
let hypclause = mk_clenv_from_n gl (Some 0) (hyp, hyp_typ) in
- let elimclause'' =
- clenv_fchain ~allow_K:false ~flags:elim_flags hypmv elimclause' hypclause in
+ let elimclause'' =
+ clenv_fchain_in id elim_flags hypmv elimclause' hypclause in
let new_hyp_typ = clenv_type elimclause'' in
if eq_constr hyp_typ new_hyp_typ then
errorlabstrm "general_rewrite_in"
@@ -752,16 +771,22 @@ let general_apply with_delta with_destruct with_evars (c,lbind) gl =
try_red_apply thm_ty0 in
try_main_apply c gl
-let apply_with_ebindings_gen b = general_apply b b
+let rec apply_with_ebindings_gen b e = function
+ | [] ->
+ tclIDTAC
+ | [cb] ->
+ general_apply b b e cb
+ | cb::cbl ->
+ tclTHENLAST (general_apply b b e cb) (apply_with_ebindings_gen b e cbl)
-let apply_with_ebindings = apply_with_ebindings_gen false false
-let eapply_with_ebindings = apply_with_ebindings_gen false true
+let apply_with_ebindings cb = apply_with_ebindings_gen false false [cb]
+let eapply_with_ebindings cb = apply_with_ebindings_gen false true [cb]
let apply_with_bindings (c,bl) =
apply_with_ebindings (c,inj_ebindings bl)
let eapply_with_bindings (c,bl) =
- apply_with_ebindings_gen false true (c,inj_ebindings bl)
+ apply_with_ebindings_gen false true [c,inj_ebindings bl]
let apply c =
apply_with_ebindings (c,NoBindings)
@@ -897,14 +922,10 @@ let clear_body = thin_body
let clear_wildcards ids =
tclMAP (fun (loc,id) gl ->
try with_check (Tacmach.thin_no_check [id]) gl
- with OccurHypInSimpleClause (id,ido) ->
+ with ClearDependencyError (id,err) ->
(* Intercept standard [thin] error message *)
- match ido with
- | None ->
- user_err_loc (loc,"",str "_ is used in conclusion.")
- | Some id ->
- user_err_loc
- (loc,"",str "_ is used in hypothesis " ++ pr_id id ++ str "."))
+ Stdpp.raise_with_loc loc
+ (error_clear_dependency (pf_env gl) (id_of_string "_") err))
ids
(* Takes a list of booleans, and introduces all the variables
@@ -946,12 +967,11 @@ let specialize mopt (c,lbind) g =
in
tclTHEN
(match evars with Some e -> tclEVARS e | _ -> tclIDTAC)
- (match kind_of_term (fst (decompose_app c)) with
- | Var id when List.exists (fun (i,_,_)-> i=id) (pf_hyps g) ->
- let id' = fresh_id [] id g in
- tclTHENS (fun g -> internal_cut id' (pf_type_of g term) g)
- [ exact_no_check term;
- tclTHEN (clear [id]) (rename_hyp [id',id]) ]
+ (match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with
+ | Var id when List.mem id (pf_ids_of_hyps g) ->
+ tclTHENFIRST
+ (fun g -> internal_cut_replace id (pf_type_of g term) g)
+ (exact_no_check term)
| _ -> tclTHENLAST
(fun g -> cut (pf_type_of g term) g)
(exact_no_check term))
@@ -1047,22 +1067,33 @@ let fix_empty_case nv l =
and "[ ]" for no clause at all; so we are a bit liberal here *)
if Array.length nv = 0 & l = [[]] then [] else l
-let intro_or_and_pattern ll l' tac =
+let error_unexpected_extra_pattern loc nb pat =
+ let s1,s2,s3 = match pat with
+ | IntroIdentifier _ -> "name", (plural nb " introduction pattern"), "no"
+ | _ -> "introduction pattern", "", "none" in
+ user_err_loc (loc,"",str "Unexpected " ++ str s1 ++ str " (" ++
+ (if nb = 0 then (str s3 ++ str s2) else
+ (str "at most " ++ int nb ++ str s2)) ++ spc () ++
+ str (if nb = 1 then "was" else "were") ++
+ strbrk " expected in the branch).")
+
+let intro_or_and_pattern loc b ll l' tac =
tclLAST_HYP (fun c gl ->
let ind,_ = pf_reduce_to_quantified_ind gl (pf_type_of gl c) in
let nv = mis_constr_nargs ind in
- let rec adjust_names_length tail n = function
- | [] when n = 0 or tail -> []
- | [] -> IntroAnonymous :: adjust_names_length tail (n-1) []
- | _ :: _ as l when n = 0 ->
- if tail then l else error "Too many names in some branch."
- | ip :: l -> ip :: adjust_names_length tail (n-1) l in
+ let bracketed = b or not (l'=[]) in
+ let rec adjust_names_length nb n = function
+ | [] when n = 0 or not bracketed -> []
+ | [] -> (dloc,IntroAnonymous) :: adjust_names_length nb (n-1) []
+ | (loc',pat) :: _ as l when n = 0 ->
+ if bracketed then error_unexpected_extra_pattern loc' nb pat;
+ l
+ | ip :: l -> ip :: adjust_names_length nb (n-1) l in
let ll = fix_empty_case nv ll in
- if List.length ll <> Array.length nv then
- error "Not the right number of patterns.";
+ check_or_and_pattern_size loc ll (Array.length nv);
tclTHENLASTn
(tclTHEN case_last clear_last)
- (array_map2 (fun n l -> tac ((adjust_names_length (l'=[]) n l)@l'))
+ (array_map2 (fun n l -> tac ((adjust_names_length n n l)@l'))
nv (Array.of_list ll))
gl)
@@ -1074,11 +1105,11 @@ let clear_if_atomic l2r id gl =
else tclIDTAC gl
let rec explicit_intro_names = function
-| IntroIdentifier id :: l ->
+| (_, IntroIdentifier id) :: l ->
id :: explicit_intro_names l
-| (IntroWildcard _ | IntroAnonymous | IntroFresh _ | IntroRewrite _) :: l ->
+| (_, (IntroWildcard | IntroAnonymous | IntroFresh _ | IntroRewrite _)) :: l ->
explicit_intro_names l
-| IntroOrAndPattern ll :: l' ->
+| (_, IntroOrAndPattern ll) :: l' ->
List.flatten (List.map (fun l -> explicit_intro_names (l@l')) ll)
| [] ->
[]
@@ -1087,84 +1118,90 @@ let rec explicit_intro_names = function
to ensure that dependent hypotheses are cleared in the right
dependency order (see bug #1000); we use fresh names, not used in
the tactic, for the hyps to clear *)
-let rec intros_patterns avoid thin destopt = function
- | IntroWildcard loc :: l ->
+let rec intros_patterns b avoid thin destopt = function
+ | (loc, IntroWildcard) :: l ->
tclTHEN
- (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) None true)
+ (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true)
(onLastHyp (fun id ->
tclORELSE
- (tclTHEN (clear [id]) (intros_patterns avoid thin destopt l))
- (intros_patterns avoid ((loc,id)::thin) destopt l)))
- | IntroIdentifier id :: l ->
+ (tclTHEN (clear [id]) (intros_patterns b avoid thin destopt l))
+ (intros_patterns b avoid ((loc,id)::thin) destopt l)))
+ | (loc, IntroIdentifier id) :: l ->
tclTHEN
- (intro_gen (IntroMustBe id) destopt true)
- (intros_patterns avoid thin destopt l)
- | IntroAnonymous :: l ->
+ (intro_gen loc (IntroMustBe id) destopt true)
+ (intros_patterns b avoid thin destopt l)
+ | (loc, IntroAnonymous) :: l ->
tclTHEN
- (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) destopt true)
- (intros_patterns avoid thin destopt l)
- | IntroFresh id :: l ->
+ (intro_gen loc (IntroAvoid (avoid@explicit_intro_names l))
+ destopt true)
+ (intros_patterns b avoid thin destopt l)
+ | (loc, IntroFresh id) :: l ->
tclTHEN
- (intro_gen (IntroBasedOn (id, avoid@explicit_intro_names l)) destopt true)
- (intros_patterns avoid thin destopt l)
- | IntroOrAndPattern ll :: l' ->
+ (intro_gen loc (IntroBasedOn (id, avoid@explicit_intro_names l))
+ destopt true)
+ (intros_patterns b avoid thin destopt l)
+ | (loc, IntroOrAndPattern ll) :: l' ->
tclTHEN
introf
- (intro_or_and_pattern ll l' (intros_patterns avoid thin destopt))
- | IntroRewrite l2r :: l ->
+ (intro_or_and_pattern loc b ll l'
+ (intros_patterns b avoid thin destopt))
+ | (loc, IntroRewrite l2r) :: l ->
tclTHEN
- (intro_gen (IntroAvoid (avoid@explicit_intro_names l)) None true)
+ (intro_gen loc (IntroAvoid(avoid@explicit_intro_names l)) no_move true)
(onLastHyp (fun id ->
tclTHENLIST [
!forward_general_multi_rewrite l2r false (mkVar id,NoBindings)
allClauses;
clear_if_atomic l2r id;
- intros_patterns avoid thin destopt l ]))
+ intros_patterns b avoid thin destopt l ]))
| [] -> clear_wildcards thin
-let intros_pattern = intros_patterns [] []
+let intros_pattern = intros_patterns false [] []
-let intro_pattern destopt pat = intros_patterns [] [] destopt [pat]
+let intro_pattern destopt pat = intros_patterns false [] [] destopt [dloc,pat]
let intro_patterns = function
| [] -> tclREPEAT intro
- | l -> intros_pattern None l
+ | l -> intros_pattern no_move l
(**************************)
(* Other cut tactics *)
(**************************)
-let hid = id_of_string "H"
-let xid = id_of_string "X"
-
-let make_id s = fresh_id [] (match s with Prop _ -> hid | Type _ -> xid)
+let make_id s = fresh_id [] (default_id_of_sort s)
-let prepare_intros s ipat gl = match ipat with
+let prepare_intros s (loc,ipat) gl = match ipat with
+ | IntroIdentifier id -> id, tclIDTAC
| IntroAnonymous -> make_id s gl, tclIDTAC
| IntroFresh id -> fresh_id [] id gl, tclIDTAC
- | IntroWildcard loc -> let id = make_id s gl in id, clear_wildcards [loc,id]
- | IntroIdentifier id -> id, tclIDTAC
+ | IntroWildcard -> let id = make_id s gl in id, clear_wildcards [dloc,id]
| IntroRewrite l2r ->
let id = make_id s gl in
id, !forward_general_multi_rewrite l2r false (mkVar id,NoBindings) allClauses
| IntroOrAndPattern ll -> make_id s gl,
- (tclTHENS
- (tclTHEN case_last clear_last)
- (List.map (intros_pattern None) ll))
+ intro_or_and_pattern loc true ll [] (intros_patterns true [] [] no_move)
let ipat_of_name = function
| Anonymous -> IntroAnonymous
| Name id -> IntroIdentifier id
+let allow_replace c gl = function (* A rather arbitrary condition... *)
+ | _, IntroIdentifier id ->
+ fst (decompose_app (snd (decompose_lam_assum c))) = mkVar id
+ | _ ->
+ false
+
let assert_as first ipat c gl =
match kind_of_term (hnf_type_of gl c) with
| Sort s ->
let id,tac = prepare_intros s ipat gl in
- tclTHENS ((if first then internal_cut else internal_cut_rev) id c)
+ let repl = allow_replace c gl ipat in
+ tclTHENS
+ ((if first then internal_cut_gen else internal_cut_rev_gen) repl id c)
(if first then [tclIDTAC; tac] else [tac; tclIDTAC]) gl
| _ -> error "Not a proposition or a type."
-let assert_tac first na = assert_as first (ipat_of_name na)
+let assert_tac first na = assert_as first (dloc,ipat_of_name na)
let true_cut = assert_tac true
(**************************)
@@ -1363,7 +1400,8 @@ let letin_abstract id c occs gl =
let ccl = match occurrences_of_goal occs with
| None -> pf_concl gl
| Some occ -> subst1 (mkVar id) (subst_term_occ occ c (pf_concl gl)) in
- let lastlhyp = if depdecls = [] then None else Some(pi1(list_last depdecls)) in
+ let lastlhyp =
+ if depdecls = [] then no_move else MoveAfter(pi1(list_last depdecls)) in
(depdecls,lastlhyp,ccl)
let letin_tac with_eq name c occs gl =
@@ -1375,19 +1413,25 @@ let letin_tac with_eq name c occs gl =
let (depdecls,lastlhyp,ccl)= letin_abstract id c occs gl in
let t = pf_type_of gl c in
let newcl,eq_tac = match with_eq with
- | Some lr ->
- let heq = fresh_id [] (add_prefix "Heq" id) gl in
+ | Some (lr,(loc,ido)) ->
+ let heq = match ido with
+ | IntroAnonymous -> fresh_id [id] (add_prefix "Heq" id) gl
+ | IntroFresh heq_base -> fresh_id [id] heq_base gl
+ | IntroIdentifier id -> id
+ | _ -> error"Expect an introduction pattern naming one hypothesis." in
let eqdata = build_coq_eq_data () in
let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in
let eq = applist (eqdata.eq,args) in
let refl = applist (eqdata.refl, [t;mkVar id]) in
mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)),
- tclTHEN (intro_gen (IntroMustBe heq) lastlhyp true) (thin_body [heq;id])
+ tclTHEN
+ (intro_gen loc (IntroMustBe heq) lastlhyp true)
+ (thin_body [heq;id])
| None ->
mkNamedLetIn id c t ccl, tclIDTAC in
tclTHENLIST
[ convert_concl_no_check newcl DEFAULTcast;
- intro_gen (IntroMustBe id) lastlhyp true;
+ intro_gen dloc (IntroMustBe id) lastlhyp true;
eq_tac;
tclMAP convert_hyp_no_check depdecls ] gl
@@ -1467,76 +1511,85 @@ let unfold_all x gl =
let check_unused_names names =
if names <> [] & Flags.is_verbose () then
- let s = if List.tl names = [] then " " else "s " in
msg_warning
- (str"Unused introduction pattern" ++ str s ++
- str": " ++ prlist_with_sep spc pr_intro_pattern names)
-
-let rec first_name_buggy = function
- | IntroOrAndPattern [] -> None
- | IntroOrAndPattern ([]::l) -> first_name_buggy (IntroOrAndPattern l)
- | IntroOrAndPattern ((p::_)::_) -> first_name_buggy p
- | IntroWildcard _ -> None
- | IntroRewrite _ -> None
- | IntroIdentifier id -> Some id
+ (str"Unused introduction " ++ str (plural (List.length names) "pattern")
+ ++ str": " ++ prlist_with_sep spc pr_intro_pattern names)
+
+let rec first_name_buggy avoid gl (loc,pat) = match pat with
+ | IntroOrAndPattern [] -> no_move
+ | IntroOrAndPattern ([]::l) ->
+ first_name_buggy avoid gl (loc,IntroOrAndPattern l)
+ | IntroOrAndPattern ((p::_)::_) -> first_name_buggy avoid gl p
+ | IntroWildcard -> no_move
+ | IntroRewrite _ -> no_move
+ | IntroIdentifier id -> MoveAfter id
| IntroAnonymous | IntroFresh _ -> assert false
let consume_pattern avoid id gl = function
- | [] -> (IntroIdentifier (fresh_id avoid id gl), [])
- | IntroAnonymous::names ->
+ | [] -> ((dloc, IntroIdentifier (fresh_id avoid id gl)), [])
+ | (loc,IntroAnonymous)::names ->
let avoid = avoid@explicit_intro_names names in
- (IntroIdentifier (fresh_id avoid id gl), names)
+ ((loc,IntroIdentifier (fresh_id avoid id gl)), names)
+ | (loc,IntroFresh id')::names ->
+ let avoid = avoid@explicit_intro_names names in
+ ((loc,IntroIdentifier (fresh_id avoid id' gl)), names)
| pat::names -> (pat,names)
let re_intro_dependent_hypotheses tophyp (lstatus,rstatus) =
let newlstatus = (* if some IH has taken place at the top of hyps *)
- List.map (function (hyp,None) -> (hyp,tophyp) | x -> x) lstatus in
+ List.map (function (hyp,MoveToEnd true) -> (hyp,tophyp) | x -> x) lstatus
+ in
tclTHEN
- (intros_rmove rstatus)
+ (intros_move rstatus)
(intros_move newlstatus)
+let update destopt tophyp = if destopt = no_move then tophyp else destopt
+
type elim_arg_kind = RecArg | IndArg | OtherArg
let induct_discharge statuslists destopt avoid' (avoid,ra) names gl =
let avoid = avoid @ avoid' in
- let rec peel_tac ra names tophyp gl = match ra with
+ let rec peel_tac ra names tophyp gl =
+ match ra with
| (RecArg,recvarname) ::
(IndArg,hyprecname) :: ra' ->
let recpat,names = match names with
- | [IntroIdentifier id as pat] ->
- let id = next_ident_away (add_prefix "IH" id) avoid in
- (pat, [IntroIdentifier id])
+ | [loc,IntroIdentifier id as pat] ->
+ let id' = next_ident_away (add_prefix "IH" id) avoid in
+ (pat, [dloc, IntroIdentifier id'])
| _ -> consume_pattern avoid recvarname gl names in
let hyprec,names = consume_pattern avoid hyprecname gl names in
(* IH stays at top: we need to update tophyp *)
(* This is buggy for intro-or-patterns with different first hypnames *)
(* Would need to pass peel_tac as a continuation of intros_patterns *)
(* (or to have hypotheses classified by blocks...) *)
- let tophyp = if tophyp=None then first_name_buggy hyprec else tophyp in
+ let newtophyp =
+ if tophyp=no_move then first_name_buggy avoid gl hyprec else tophyp
+ in
tclTHENLIST
- [ intros_patterns avoid [] destopt [recpat];
- intros_patterns avoid [] None [hyprec];
- peel_tac ra' names tophyp] gl
+ [ intros_patterns true avoid [] (update destopt tophyp) [recpat];
+ intros_patterns true avoid [] no_move [hyprec];
+ peel_tac ra' names newtophyp] gl
| (IndArg,hyprecname) :: ra' ->
(* Rem: does not happen in Coq schemes, only in user-defined schemes *)
let pat,names = consume_pattern avoid hyprecname gl names in
- tclTHEN (intros_patterns avoid [] destopt [pat])
+ tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat])
(peel_tac ra' names tophyp) gl
| (RecArg,recvarname) :: ra' ->
let pat,names = consume_pattern avoid recvarname gl names in
- tclTHEN (intros_patterns avoid [] destopt [pat])
+ tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat])
(peel_tac ra' names tophyp) gl
| (OtherArg,_) :: ra' ->
let pat,names = match names with
- | [] -> IntroAnonymous, []
+ | [] -> (dloc, IntroAnonymous), []
| pat::names -> pat,names in
- tclTHEN (intros_patterns avoid [] destopt [pat])
+ tclTHEN (intros_patterns true avoid [] (update destopt tophyp) [pat])
(peel_tac ra' names tophyp) gl
| [] ->
check_unused_names names;
re_intro_dependent_hypotheses tophyp statuslists gl
in
- peel_tac ra names None gl
+ peel_tac ra names no_move gl
(* - le recalcul de indtyp à chaque itération de atomize_one est pour ne pas
s'embêter à regarder si un letin_tac ne fait pas des
@@ -1594,7 +1647,7 @@ let find_atomic_param_of_ind nparams indtyp =
Idset.elements !indvars;
- (* [cook_sign] builds the lists [indhyps] of hyps that must be
+(* [cook_sign] builds the lists [indhyps] of hyps that must be
erased, the lists of hyps to be generalize [(hdeps,tdeps)] on the
goal together with the places [(lstatus,rstatus)] where to re-intro
them after induction. To know where to re-intro the dep hyp, we
@@ -1605,7 +1658,7 @@ let find_atomic_param_of_ind nparams indtyp =
more ancient (on the right) to more recent hyp (on the left) but
the computation of [lhyp] progresses from the other way, [cook_hyp]
is in two passes (an alternative would have been to write an
- higher-order algorithm). We strongly use references to reduce
+ higher-order algorithm). We use references to reduce
the accumulation of arguments.
To summarize, the situation looks like this
@@ -1657,7 +1710,7 @@ let find_atomic_param_of_ind nparams indtyp =
*)
-exception Shunt of identifier option
+exception Shunt of identifier move_location
let cook_sign hyp0_opt indvars_init env =
let hyp0,indvars =
@@ -1679,7 +1732,7 @@ let cook_sign hyp0_opt indvars_init env =
(* If there was no main induction hypotheses, then hyp is one of
indvars too, so add it to indhyps. *)
(if hyp0_opt=None then indhyps := hyp::!indhyps);
- None (* fake value *)
+ MoveToEnd false (* fake value *)
end else if List.mem hyp indvars then begin
(* warning: hyp can still occur after induction *)
(* e.g. if the goal (t hyp hyp0) with other occs of hyp in t *)
@@ -1695,11 +1748,11 @@ let cook_sign hyp0_opt indvars_init env =
rstatus := (hyp,rhyp)::!rstatus
else
ldeps := hyp::!ldeps; (* status computed in 2nd phase *)
- Some hyp end
+ MoveBefore hyp end
else
- Some hyp
+ MoveBefore hyp
in
- let _ = fold_named_context seek_deps env ~init:None in
+ let _ = fold_named_context seek_deps env ~init:(MoveToEnd false) in
(* 2nd phase from R to L: get left hyp of [hyp0] and [lhyps] *)
let compute_lstatus lhyp (hyp,_,_) =
if hyp = hyp0 then raise (Shunt lhyp);
@@ -1707,15 +1760,16 @@ let cook_sign hyp0_opt indvars_init env =
lstatus := (hyp,lhyp)::!lstatus;
lhyp
end else
- if List.mem hyp !indhyps then lhyp else (Some hyp)
+ if List.mem hyp !indhyps then lhyp else MoveAfter hyp
in
try
- let _ = fold_named_context_reverse compute_lstatus ~init:None env in
-(* anomaly "hyp0 not found" *)
- raise (Shunt (None)) (* ?? FIXME *)
+ let _ =
+ fold_named_context_reverse compute_lstatus ~init:(MoveToEnd true) env in
+ raise (Shunt (MoveToEnd true)) (* ?? FIXME *)
with Shunt lhyp0 ->
let statuslists = (!lstatus,List.rev !rstatus) in
- (statuslists, (if hyp0_opt=None then None else lhyp0) , !indhyps, !decldeps)
+ (statuslists, (if hyp0_opt=None then MoveToEnd true else lhyp0),
+ !indhyps, !decldeps)
(*
@@ -1801,9 +1855,9 @@ let make_base n id =
(* digits *)
id_of_string (atompart_of_id (make_ident (string_of_id id) (Some 0)))
-(* Builds tw different names from an optional inductive type and a
+(* Builds two different names from an optional inductive type and a
number, also deals with a list of names to avoid. If the inductive
- type is None, then hyprecname is HIi where i is a number. *)
+ type is None, then hyprecname is IHi where i is a number. *)
let make_up_names n ind_opt cname =
let is_hyp = atompart_of_id cname = "H" in
let base = string_of_id (make_base n cname) in
@@ -2032,11 +2086,11 @@ let cut_list n l =
res
-(* This functions splits the products of the induction scheme [elimt] in three
+(* This function splits the products of the induction scheme [elimt] into four
parts:
- - branches, easily detectable (they are not referred by rels in the subterm)
- - what was found before branches (acc1) that is: parameters and predicates
- - what was found after branches (acc3) that is: args and indarg if any
+ - branches, easily detectable (they are not referred by rels in the subterm)
+ - what was found before branches (acc1) that is: parameters and predicates
+ - what was found after branches (acc3) that is: args and indarg if any
if there is no branch, we try to fill in acc3 with args/indargs.
We also return the conclusion.
*)
@@ -2079,7 +2133,7 @@ let exchange_hd_app subst_hd t =
(* [rebuild_elimtype_from_scheme scheme] rebuilds the type of an
eliminator from its [scheme_info]. The idea is to build variants of
- eliminator by modifying there scheme_info, then rebuild the
+ eliminator by modifying their scheme_info, then rebuild the
eliminator type, then prove it (with tactics). *)
let rebuild_elimtype_from_scheme (scheme:elim_scheme): types =
let hiconcl =
@@ -2096,7 +2150,7 @@ let rebuild_elimtype_from_scheme (scheme:elim_scheme): types =
exception NoLastArg
exception NoLastArgCcl
-(* Builds an elim_scheme frome its type and calling form (const+binding) We
+(* Builds an elim_scheme from its type and calling form (const+binding). We
first separate branches. We obtain branches, hyps before (params + preds),
hyps after (args <+ indarg if present>) and conclusion. Then we proceed as
follows:
@@ -2184,17 +2238,17 @@ let compute_elim_sig ?elimc elimt =
extra final argument of the form (f x y ...) in the conclusion. In
the non standard case, naming of generated hypos is slightly
different. *)
-let compute_elim_signature elimc elimt names_info =
+let compute_elim_signature elimc elimt names_info ind_type_guess =
let scheme = compute_elim_sig ~elimc:elimc elimt in
let f,l = decompose_app scheme.concl in
(* Vérifier que les arguments de Qi sont bien les xi. *)
match scheme.indarg with
| Some (_,Some _,_) -> error "Strange letin, cannot recognize an induction scheme."
| None -> (* Non standard scheme *)
- let npred = List.length scheme.predicates in
let is_pred n c =
let hd = fst (decompose_app c) in match kind_of_term hd with
- | Rel q when n < q & q <= n+npred -> IndArg
+ | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
+ | _ when hd = ind_type_guess & not scheme.farg_in_concl -> RecArg
| _ -> OtherArg in
let rec check_branch p c =
match kind_of_term c with
@@ -2223,10 +2277,9 @@ let compute_elim_signature elimc elimt names_info =
| Some ( _,None,ind) -> (* Standard scheme from an inductive type *)
let indhd,indargs = decompose_app ind in
- let npred = List.length scheme.predicates in
let is_pred n c =
let hd = fst (decompose_app c) in match kind_of_term hd with
- | Rel q when n < q & q <= n+npred -> IndArg
+ | Rel q when n < q & q <= n+scheme.npredicates -> IndArg
| _ when hd = indhd -> RecArg
| _ -> OtherArg in
let rec check_branch p c = match kind_of_term c with
@@ -2266,7 +2319,7 @@ let compute_elim_signature elimc elimt names_info =
let find_elim_signature isrec elim hyp0 gl =
let tmptyp0 = pf_get_hyp_typ gl hyp0 in
- let (elimc,elimt) = match elim with
+ let (elimc,elimt),ind = match elim with
| None ->
let mind,_ = pf_reduce_to_quantified_ind gl tmptyp0 in
let s = elimination_sort_of_goal gl in
@@ -2274,21 +2327,15 @@ let find_elim_signature isrec elim hyp0 gl =
if isrec then lookup_eliminator mind s
else pf_apply make_case_gen gl mind s in
let elimt = pf_type_of gl elimc in
- ((elimc, NoBindings), elimt)
- | Some (elimc,lbind as e) ->
- (e, pf_type_of gl elimc) in
- let indsign,elim_scheme = compute_elim_signature elimc elimt hyp0 in
+ ((elimc, NoBindings), elimt), mkInd mind
+ | Some (elimc,lbind as e) ->
+ let ind_type_guess,_ = decompose_app (snd (decompose_prod tmptyp0)) in
+ (e, pf_type_of gl elimc), ind_type_guess in
+ let indsign,elim_scheme =
+ compute_elim_signature elimc elimt hyp0 ind in
(indsign,elim_scheme)
-let mapi f l =
- let rec mapi_aux f i l =
- match l with
- | [] -> []
- | e::l' -> f e i :: mapi_aux f (i+1) l' in
- mapi_aux f 0 l
-
-
(* Instantiate all meta variables of elimclause using lid, some elts
of lid are parameters (first ones), the other are
arguments. Returns the clause obtained. *)
@@ -2307,12 +2354,13 @@ let recolle_clenv scheme lid elimclause gl =
let nidargs = List.length lidargs in
(* parameters correspond to first elts of lid. *)
let clauses_params =
- mapi (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i)) lidparams in
+ list_map_i (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(i))
+ 0 lidparams in
(* arguments correspond to last elts of lid. *)
let clauses_args =
- mapi
- (fun id i -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i))
- lidargs in
+ list_map_i
+ (fun i id -> mkVar id , pf_get_hyp_typ gl id , lindmv.(nmv-nidargs+i))
+ 0 lidargs in
let clause_indarg =
match scheme.indarg with
| None -> []
@@ -2336,7 +2384,7 @@ let recolle_clenv scheme lid elimclause gl =
(elimc ?i ?j ?k...?l). This solves partly meta variables (and may
produce new ones). Then refine with the resulting term with holes.
*)
-let induction_tac_felim with_evars indvars (* (elimc,lbindelimc) elimt *) scheme gl =
+let induction_tac_felim with_evars indvars scheme gl =
let elimt = scheme.elimt in
let elimc,lbindelimc =
match scheme.elimc with | Some x -> x | None -> error "No definition of the principle." in
@@ -2349,6 +2397,29 @@ let induction_tac_felim with_evars indvars (* (elimc,lbindelimc) elimt *) scheme
let resolved = clenv_unique_resolver true elimclause' gl in
clenv_refine with_evars resolved gl
+let apply_induction_in_context isrec hyp0 indsign indvars names induct_tac gl =
+ let env = pf_env gl in
+ let statlists,lhyp0,indhyps,deps = cook_sign hyp0 indvars env in
+ let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
+ let names = compute_induction_names (Array.length indsign) names in
+ let dephyps = List.map (fun (id,_,_) -> id) deps in
+ let deps_cstr =
+ List.fold_left
+ (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
+ tclTHENLIST
+ [
+ (* Generalize dependent hyps (but not args) *)
+ if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
+ (* clear dependent hyps *)
+ thin dephyps;
+ (* side-conditions in elim (resp case) schemes come last (resp first) *)
+ (if isrec then tclTHENFIRSTn else tclTHENLASTn)
+ (tclTHEN induct_tac (tclTRY (thin (List.rev indhyps))))
+ (array_map2
+ (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
+ ]
+ gl
+
(* Induction with several induction arguments, main differences with
induction_from_context is that there is no main induction argument,
so we chose one to be the positioning reference. On the other hand,
@@ -2364,7 +2435,6 @@ let induction_from_context_l isrec with_evars elim_info lid names gl =
(* Number of given induction args must be exact. *)
if List.length lid <> nargs_indarg_farg + scheme.nparams then
error "Not the right number of arguments given to induction scheme.";
- let env = pf_env gl in
(* hyp0 is used for re-introducing hyps at the right place afterward.
We chose the first element of the list of variables on which to
induct. It is probably the first of them appearing in the
@@ -2376,12 +2446,6 @@ let induction_from_context_l isrec with_evars elim_info lid names gl =
let nargs_without_first = nargs_indarg_farg - 1 in
let ivs,lp = cut_list nargs_without_first l in
e, ivs, lp in
- let statlists,lhyp0,indhyps,deps = cook_sign None (hyp0::indvars) env in
- let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
- let names = compute_induction_names (Array.length indsign) names in
- let dephyps = List.map (fun (id,_,_) -> id) deps in
- let deps_cstr =
- List.fold_left (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
(* terms to patternify we must patternify indarg or farg if present in concl *)
let lid_in_pattern =
if scheme.indarg <> None & not scheme.indarg_in_concl then List.rev indvars
@@ -2390,68 +2454,32 @@ let induction_from_context_l isrec with_evars elim_info lid names gl =
let realindvars = (* hyp0 is a real induction arg if it is not the
farg in the conclusion of the induction scheme *)
List.rev ((if scheme.farg_in_concl then indvars else hyp0::indvars) @ lid_params) in
- (* Magistral effet de bord: comme dans induction_from_context. *)
- tclTHENLIST
- [
- (* Generalize dependent hyps (but not args) *)
- if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
- thin dephyps; (* clear dependent hyps *)
- (* pattern to make the predicate appear. *)
- reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl;
- (* FIXME: Tester ca avec un principe dependant et non-dependant *)
- (if isrec then tclTHENFIRSTn else tclTHENLASTn)
- (tclTHENLIST [
- (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all
- possible holes using arguments given by the user (but the
- functional one). *)
- induction_tac_felim with_evars realindvars scheme;
- tclTRY (thin (List.rev (indhyps)));
- ])
- (array_map2
- (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
- ]
- gl
-
-
+ let induct_tac = tclTHENLIST [
+ (* pattern to make the predicate appear. *)
+ reduce (Pattern (List.map inj_with_occurrences lidcstr)) onConcl;
+ (* Induction by "refine (indscheme ?i ?j ?k...)" + resolution of all
+ possible holes using arguments given by the user (but the
+ functional one). *)
+ (* FIXME: Tester ca avec un principe dependant et non-dependant *)
+ induction_tac_felim with_evars realindvars scheme
+ ] in
+ apply_induction_in_context isrec
+ None indsign (hyp0::indvars) names induct_tac gl
let induction_from_context isrec with_evars elim_info (hyp0,lbind) names gl =
let indsign,scheme = elim_info in
let indref = match scheme.indref with | None -> assert false | Some x -> x in
let tmptyp0 = pf_get_hyp_typ gl hyp0 in
let typ0 = pf_apply reduce_to_quantified_ref gl indref tmptyp0 in
-
- let env = pf_env gl in
- let indvars = find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in
- (* induction_from_context_l isrec elim_info (hyp0::List.rev indvars) names gl *)
- let statlists,lhyp0,indhyps,deps = cook_sign (Some hyp0) indvars env in
- let tmpcl = it_mkNamedProd_or_LetIn (pf_concl gl) deps in
- let names = compute_induction_names (Array.length indsign) names in
- let dephyps = List.map (fun (id,_,_) -> id) deps in
- let deps_cstr =
- List.fold_left
- (fun a (id,b,_) -> if b = None then (mkVar id)::a else a) [] deps in
-
- (* Magistral effet de bord: si hyp0 a des arguments, ceux d'entre
- eux qui ouvrent de nouveaux buts arrivent en premier dans la
- liste des sous-buts du fait qu'ils sont le plus à gauche dans le
- combinateur engendré par make_case_gen (un "Cases (hyp0 ?) of
- ...") et il faut alors appliquer tclTHENLASTn; en revanche,
- comme lookup_eliminator renvoie un combinateur de la forme
- "ind_rec ... (hyp0 ?)", les buts correspondant à des arguments de
- hyp0 sont maintenant à la fin et c'est tclTHENFIRSTn qui marche !!! *)
- tclTHENLIST
- [ if deps = [] then tclIDTAC else apply_type tmpcl deps_cstr;
- thin dephyps;
- (if isrec then tclTHENFIRSTn else tclTHENLASTn)
- (tclTHENLIST
- [ induction_tac with_evars (hyp0,lbind) typ0 scheme;
- tclTHEN (tclTRY (unfold_body hyp0)) (thin [hyp0]);
- tclTRY (thin indhyps) ])
- (array_map2
- (induct_discharge statlists lhyp0 (List.rev dephyps)) indsign names)
- ]
- gl
-
+ let indvars =
+ find_atomic_param_of_ind scheme.nparams (snd (decompose_prod typ0)) in
+ let induct_tac = tclTHENLIST [
+ induction_tac with_evars (hyp0,lbind) typ0 scheme;
+ tclTRY (unfold_body hyp0);
+ thin [hyp0]
+ ] in
+ apply_induction_in_context isrec
+ (Some hyp0) indsign indvars names induct_tac gl
exception TryNewInduct of exn
@@ -2484,17 +2512,22 @@ let induction_without_atomization isrec with_evars elim names lid gl =
then error "Not the right number of induction arguments."
else induction_from_context_l isrec with_evars elim_info lid names gl
-let new_induct_gen isrec with_evars elim names (c,lbind) cls gl =
+let new_induct_gen isrec with_evars elim (eqname,names) (c,lbind) cls gl =
match kind_of_term c with
| Var id when not (mem_named_context id (Global.named_context()))
- & lbind = NoBindings & not with_evars & cls = None ->
+ & lbind = NoBindings & not with_evars & cls = None
+ & eqname = None ->
induction_with_atomization_of_ind_arg
isrec with_evars elim names (id,lbind) gl
| _ ->
let x = id_of_name_using_hdchar (Global.env()) (pf_type_of gl c)
Anonymous in
let id = fresh_id [] x gl in
- let with_eq = if cls <> None then Some (not (isVar c)) else None in
+ let with_eq =
+ match eqname with
+ | Some eq -> Some (false,eq)
+ | _ ->
+ if cls <> None then Some (false,(dloc,IntroAnonymous)) else None in
tclTHEN
(letin_tac with_eq (Name id) c (Option.default allClauses cls))
(induction_with_atomization_of_ind_arg
@@ -2505,7 +2538,10 @@ let new_induct_gen isrec with_evars elim names (c,lbind) cls gl =
that all arguments and parameters of the scheme are given
(mandatory for the moment), so we don't need to deal with
parameters of the inductive type as in new_induct_gen. *)
-let new_induct_gen_l isrec with_evars elim names lc gl =
+let new_induct_gen_l isrec with_evars elim (eqname,names) lc gl =
+ if eqname <> None then
+ errorlabstrm "" (str "Do not know what to do with " ++
+ pr_intro_pattern (Option.get eqname));
let newlc = ref [] in
let letids = ref [] in
let rec atomize_list l gl =
@@ -2566,7 +2602,7 @@ let induct_destruct_l isrec with_evars lc elim names cls =
principles).
TODO: really unify induction with one and induction with several
args *)
-let induct_destruct isrec with_evars lc elim names cls =
+let induct_destruct isrec with_evars (lc,elim,names,cls) =
assert (List.length lc > 0); (* ensured by syntax, but if called inside caml? *)
if List.length lc = 1 then (* induction on one arg: use old mechanism *)
try
@@ -2580,11 +2616,16 @@ let induct_destruct isrec with_evars lc elim names cls =
with _ -> raise x)
else induct_destruct_l isrec with_evars lc elim names cls
+let induction_destruct isrec with_evars = function
+ | [] -> tclIDTAC
+ | [a] -> induct_destruct isrec with_evars a
+ | a::l ->
+ tclTHEN
+ (induct_destruct isrec with_evars a)
+ (tclMAP (induct_destruct false with_evars) l)
-
-
-let new_induct = induct_destruct true
-let new_destruct = induct_destruct false
+let new_induct ev lc e idl cls = induct_destruct true ev (lc,e,idl,cls)
+let new_destruct ev lc e idl cls = induct_destruct false ev (lc,e,idl,cls)
(* The registered tactic, which calls the default elimination
* if no elimination constant is provided. *)
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index 9070e2617..56597f58e 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -9,6 +9,7 @@
(*i $Id$ i*)
(*i*)
+open Util
open Names
open Term
open Environ
@@ -68,7 +69,8 @@ val find_intro_names : rel_context -> goal sigma -> identifier list
val intro : tactic
val introf : tactic
val intro_force : bool -> tactic
-val intro_move : identifier option -> identifier option -> tactic
+val intro_move : identifier option -> identifier move_location -> tactic
+
(* [intro_avoiding idl] acts as intro but prevents the new identifier
to belong to [idl] *)
val intro_avoiding : identifier list -> tactic
@@ -110,9 +112,10 @@ val onInductionArg :
(*s Introduction tactics with eliminations. *)
-val intro_pattern : identifier option -> intro_pattern_expr -> tactic
-val intro_patterns : intro_pattern_expr list -> tactic
-val intros_pattern : identifier option -> intro_pattern_expr list -> tactic
+val intro_pattern : identifier move_location -> intro_pattern_expr -> tactic
+val intro_patterns : intro_pattern_expr located list -> tactic
+val intros_pattern :
+ identifier move_location -> intro_pattern_expr located list -> tactic
(*s Exact tactics. *)
@@ -167,7 +170,7 @@ val keep : identifier list -> tactic
val specialize : int option -> constr with_ebindings -> tactic
-val move_hyp : bool -> identifier -> identifier -> tactic
+val move_hyp : bool -> identifier -> identifier move_location -> tactic
val rename_hyp : (identifier * identifier) list -> tactic
val revert : identifier list -> tactic
@@ -183,7 +186,7 @@ val apply_without_reduce : constr -> tactic
val apply_list : constr list -> tactic
val apply_with_ebindings_gen :
- advanced_flag -> evars_flag -> constr with_ebindings -> tactic
+ advanced_flag -> evars_flag -> constr with_ebindings list -> tactic
val apply_with_bindings : constr with_bindings -> tactic
val eapply_with_bindings : constr with_bindings -> tactic
@@ -260,7 +263,9 @@ val elim :
val simple_induct : quantified_hypothesis -> tactic
val new_induct : evars_flag -> constr with_ebindings induction_arg list ->
- constr with_ebindings option -> intro_pattern_expr -> clause option -> tactic
+ constr with_ebindings option ->
+ intro_pattern_expr located option * intro_pattern_expr located option ->
+ clause option -> tactic
(*s Case analysis tactics. *)
@@ -269,7 +274,18 @@ val simplest_case : constr -> tactic
val simple_destruct : quantified_hypothesis -> tactic
val new_destruct : evars_flag -> constr with_ebindings induction_arg list ->
- constr with_ebindings option -> intro_pattern_expr -> clause option -> tactic
+ constr with_ebindings option ->
+ intro_pattern_expr located option * intro_pattern_expr located option ->
+ clause option -> tactic
+
+(*s Generic case analysis / induction tactics. *)
+
+val induction_destruct : evars_flag -> rec_flag ->
+ (constr with_ebindings induction_arg list *
+ constr with_ebindings option *
+ (intro_pattern_expr located option * intro_pattern_expr located option) *
+ clause option) list ->
+ tactic
(*s Eliminations giving the type instead of the proof. *)
@@ -330,9 +346,10 @@ val cut_replacing :
identifier -> constr -> (tactic -> tactic) -> tactic
val cut_in_parallel : constr list -> tactic
-val assert_as : bool -> intro_pattern_expr -> constr -> tactic
-val forward : tactic option -> intro_pattern_expr -> constr -> tactic
-val letin_tac : bool option -> name -> constr -> clause -> tactic
+val assert_as : bool -> intro_pattern_expr located -> constr -> tactic
+val forward : tactic option -> intro_pattern_expr located -> constr -> tactic
+val letin_tac : (bool * intro_pattern_expr located) option -> name ->
+ constr -> clause -> tactic
val true_cut : name -> constr -> tactic
val assert_tac : bool -> name -> constr -> tactic
val generalize : constr list -> tactic
diff --git a/tactics/tauto.ml4 b/tactics/tauto.ml4
index 90705c8c9..d3dd2959c 100644
--- a/tactics/tauto.ml4
+++ b/tactics/tauto.ml4
@@ -142,7 +142,7 @@ let rec tauto_intuit t_reduce solver ist =
and t_simplif = tacticIn simplif
and t_is_disj = tacticIn is_disj
and t_tauto_intuit = tacticIn (tauto_intuit t_reduce solver) in
- let t_solver = Tacexpr.TacArg (valueIn (VTactic (dummy_loc,solver))) in
+ let t_solver = globTacticIn (fun _ist -> solver) in
<:tactic<
($t_simplif;$t_axioms
|| match reverse goal with
@@ -165,16 +165,14 @@ let rec tauto_intuit t_reduce solver ist =
$t_solver
) >>
-let reduction_not_iff=interp
+let reduction_not_iff _ist =
<:tactic<repeat
match goal with
| |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff
| H:_ |- _ => progress unfold Coq.Init.Logic.not, Coq.Init.Logic.iff in H
end >>
-
-let t_reduction_not_iff =
- Tacexpr.TacArg (valueIn (VTactic (dummy_loc,reduction_not_iff)))
+let t_reduction_not_iff = tacticIn reduction_not_iff
let intuition_gen tac =
interp (tacticIn (tauto_intuit t_reduction_not_iff tac))
@@ -182,12 +180,12 @@ let intuition_gen tac =
let simplif_gen = interp (tacticIn simplif)
let tauto g =
- try intuition_gen (interp <:tactic<fail>>) g
+ try intuition_gen <:tactic<fail>> g
with
Refiner.FailError _ | UserError _ ->
errorlabstrm "tauto" (str "tauto failed.")
-let default_intuition_tac = interp <:tactic< auto with * >>
+let default_intuition_tac = <:tactic< auto with * >>
TACTIC EXTEND tauto
| [ "tauto" ] -> [ tauto ]
@@ -195,5 +193,5 @@ END
TACTIC EXTEND intuition
| [ "intuition" ] -> [ intuition_gen default_intuition_tac ]
-| [ "intuition" tactic(t) ] -> [ intuition_gen (snd t) ]
+| [ "intuition" tactic(t) ] -> [ intuition_gen (fst t) ]
END
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-09 23:22:20 +0000