aboutsummaryrefslogtreecommitdiff
path: root/plugins/ltac
diff options
context:
space:
mode:
Diffstat (limited to 'plugins/ltac')
-rw-r--r--plugins/ltac/evar_tactics.ml2
-rw-r--r--plugins/ltac/extratactics.ml44
-rw-r--r--plugins/ltac/g_ltac.ml418
-rw-r--r--plugins/ltac/ltac_plugin.mlpack4
-rw-r--r--plugins/ltac/pptactic.ml28
-rw-r--r--plugins/ltac/pptactic.mli4
-rw-r--r--plugins/ltac/profile_ltac.ml25
-rw-r--r--plugins/ltac/rewrite.ml14
-rw-r--r--plugins/ltac/rewrite.mli2
-rw-r--r--plugins/ltac/tacentries.ml39
-rw-r--r--plugins/ltac/tacentries.mli3
-rw-r--r--plugins/ltac/tacenv.ml44
-rw-r--r--plugins/ltac/tacenv.mli10
-rw-r--r--plugins/ltac/tacexpr.mli3
-rw-r--r--plugins/ltac/tacintern.ml6
-rw-r--r--plugins/ltac/tacinterp.ml38
-rw-r--r--plugins/ltac/tacinterp.mli4
17 files changed, 178 insertions, 70 deletions
diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml
index 4cab6ef336..d9150a7bbd 100644
--- a/plugins/ltac/evar_tactics.ml
+++ b/plugins/ltac/evar_tactics.ml
@@ -88,7 +88,7 @@ let let_evar name typ =
let id = match name with
| Name.Anonymous ->
let id = Namegen.id_of_name_using_hdchar env sigma typ name in
- Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env))
+ Namegen.next_ident_away_in_goal id (Termops.vars_of_env env)
| Name.Name id -> id
in
let (sigma, evar) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in
diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4
index b4c6f9c90e..a7aebf9e15 100644
--- a/plugins/ltac/extratactics.ml4
+++ b/plugins/ltac/extratactics.ml4
@@ -665,7 +665,7 @@ let hResolve id c occ t =
let sigma = Proofview.Goal.sigma gl in
let env = Termops.clear_named_body id (Proofview.Goal.env gl) in
let concl = Proofview.Goal.concl gl in
- let env_ids = Termops.ids_of_context env in
+ let env_ids = Termops.vars_of_env env in
let c_raw = Detyping.detype Detyping.Now true env_ids env sigma c in
let t_raw = Detyping.detype Detyping.Now true env_ids env sigma t in
let rec resolve_hole t_hole =
@@ -764,7 +764,7 @@ let case_eq_intros_rewrite x =
mkCaseEq x;
Proofview.Goal.enter begin fun gl ->
let concl = Proofview.Goal.concl gl in
- let hyps = Tacmach.New.pf_ids_of_hyps gl in
+ let hyps = Tacmach.New.pf_ids_set_of_hyps gl in
let n' = nb_prod (Tacmach.New.project gl) concl in
let h = fresh_id_in_env hyps (Id.of_string "heq") (Proofview.Goal.env gl) in
Tacticals.New.tclTHENLIST [
diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4
index 2ea0f60ebc..c577cb2198 100644
--- a/plugins/ltac/g_ltac.ml4
+++ b/plugins/ltac/g_ltac.ml4
@@ -340,7 +340,7 @@ GEXTEND Gram
command:
[ [ IDENT "Proof"; "with"; ta = Pltac.tactic;
l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] ->
- Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l)
+ Vernacexpr.VernacProof (Some (in_tac ta), l)
| IDENT "Proof"; "using"; l = G_vernac.section_subset_expr;
ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] ->
Vernacexpr.VernacProof (ta,Some l) ] ]
@@ -388,16 +388,7 @@ let vernac_solve n info tcom b =
p,status) in
if not status then Feedback.feedback Feedback.AddedAxiom
-let pr_range_selector (i, j) =
- if Int.equal i j then int i
- else int i ++ str "-" ++ int j
-
-let pr_ltac_selector = function
-| SelectNth i -> int i ++ str ":"
-| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
- str "]" ++ str ":"
-| SelectId id -> str "[" ++ Id.print id ++ str "]" ++ str ":"
-| SelectAll -> str "all" ++ str ":"
+let pr_ltac_selector s = Pptactic.pr_goal_selector ~toplevel:true s
VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector
| [ toplevel_selector(s) ] -> [ s ]
@@ -491,6 +482,11 @@ VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY
[ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ]
END
+VERNAC COMMAND EXTEND VernacLocateLtac CLASSIFIED AS QUERY
+| [ "Locate" "Ltac" reference(r) ] ->
+ [ Tacentries.print_located_tactic r ]
+END
+
let pr_ltac_ref = Libnames.pr_reference
let pr_tacdef_body tacdef_body =
diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack
index 12b4c81fc4..3972b7aac3 100644
--- a/plugins/ltac/ltac_plugin.mlpack
+++ b/plugins/ltac/ltac_plugin.mlpack
@@ -1,9 +1,9 @@
Tacarg
+Tacsubst
+Tacenv
Pptactic
Pltac
Taccoerce
-Tacsubst
-Tacenv
Tactic_debug
Tacintern
Tacentries
diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml
index f4e3ba633f..d588c888c4 100644
--- a/plugins/ltac/pptactic.ml
+++ b/plugins/ltac/pptactic.ml
@@ -336,7 +336,7 @@ type 'a extra_genarg_printer =
let pr_ltac_constant kn =
if !Flags.in_debugger then KerName.print kn
else try
- pr_qualid (Nametab.shortest_qualid_of_tactic kn)
+ pr_qualid (Tacenv.shortest_qualid_of_tactic kn)
with Not_found -> (* local tactic not accessible anymore *)
str "<" ++ KerName.print kn ++ str ">"
@@ -477,12 +477,14 @@ type 'a extra_genarg_printer =
if Int.equal i j then int i
else int i ++ str "-" ++ int j
- let pr_goal_selector = function
- | SelectNth i -> int i ++ str ":"
- | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++
- str "]" ++ str ":"
- | SelectId id -> str "[" ++ Id.print id ++ str "]" ++ str ":"
- | SelectAll -> str "all" ++ str ":"
+let pr_goal_selector toplevel = function
+ | SelectNth i -> int i ++ str ":"
+ | SelectList l -> prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ str ":"
+ | SelectId id -> str "[" ++ Id.print id ++ str "]:"
+ | SelectAll -> assert toplevel; str "all:"
+
+let pr_goal_selector ~toplevel s =
+ (if toplevel then mt () else str "only ") ++ pr_goal_selector toplevel s
let pr_lazy = function
| General -> keyword "multi"
@@ -662,14 +664,14 @@ type 'a extra_genarg_printer =
let names =
List.fold_left
(fun ln (nal,_) -> List.fold_left
- (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln)
+ (fun ln na -> match na with (_,Name id) -> Id.Set.add id ln | _ -> ln)
ln nal)
- [] bll in
+ Id.Set.empty bll in
let idarg,bll = set_nth_name names n bll in
- let annot = match names with
- | [_] ->
+ let annot =
+ if Int.equal (Id.Set.cardinal names) 1 then
mt ()
- | _ ->
+ else
spc() ++ str"{"
++ keyword "struct" ++ spc ()
++ pr_id idarg ++ str"}"
@@ -988,7 +990,7 @@ type 'a extra_genarg_printer =
keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet
| TacComplete t ->
pr_tac (lcomplete,E) t, lcomplete
- | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom
+ | TacSelect (s, tac) -> pr_goal_selector ~toplevel:false s ++ spc () ++ pr_tac ltop tac, latom
| TacId l ->
keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom
| TacAtom (loc,t) ->
diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli
index 1f6ebaf448..d9da954fe6 100644
--- a/plugins/ltac/pptactic.mli
+++ b/plugins/ltac/pptactic.mli
@@ -53,6 +53,8 @@ type pp_tactic = {
pptac_prods : grammar_terminals;
}
+val pr_goal_selector : toplevel:bool -> goal_selector -> Pp.t
+
val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit
val pr_with_occurrences :
@@ -91,7 +93,7 @@ val pr_alias_key : Names.KerName.t -> Pp.t
val pr_alias : (Val.t -> Pp.t) ->
int -> Names.KerName.t -> Val.t list -> Pp.t
-val pr_ltac_constant : Nametab.ltac_constant -> Pp.t
+val pr_ltac_constant : ltac_constant -> Pp.t
val pr_raw_tactic : raw_tactic_expr -> Pp.t
diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml
index 32494a8793..9ae8bfe65b 100644
--- a/plugins/ltac/profile_ltac.ml
+++ b/plugins/ltac/profile_ltac.ml
@@ -367,18 +367,30 @@ let do_profile s call_trace tac =
let get_local_profiling_results () = List.hd Local.(!stack)
-module SM = Map.Make(Stateid.Self)
+(* We maintain our own cache of document data, given that the
+ semantics of the STM implies that synchronized state for opaque
+ proofs will be lost on QED. This provides some complications later
+ on as we will have to simulate going back on the document on our
+ own. *)
+module DData = struct
+ type t = Feedback.doc_id * Stateid.t
+ let compare x y = Pervasives.compare x y
+end
+
+module SM = Map.Make(DData)
let data = ref SM.empty
let _ =
Feedback.(add_feeder (function
- | { id = s; contents = Custom (_, "ltacprof_results", xml) } ->
+ | { doc_id = d;
+ span_id = s;
+ contents = Custom (_, "ltacprof_results", xml) } ->
let results = to_ltacprof_results xml in
let other_results = (* Multi success can cause this *)
- try SM.find s !data
+ try SM.find (d,s) !data
with Not_found -> empty_treenode root in
- data := SM.add s (merge_roots results other_results) !data
+ data := SM.add (d,s) (merge_roots results other_results) !data
| _ -> ()))
let reset_profile () =
@@ -388,7 +400,10 @@ let reset_profile () =
(* ******************** *)
let print_results_filter ~cutoff ~filter =
- let valid id _ = Stm.state_of_id id <> `Expired in
+ (* The STM doesn't provide yet a proper document query and traversal
+ API, thus we need to re-check if some states are current anymore
+ (due to backtracking) using the `state_of_id` API. *)
+ let valid (did,id) _ = Stm.(state_of_id ~doc:(get_doc did) id) <> `Expired in
data := SM.filter valid !data;
let results =
SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in
diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml
index 3d01cbe8dd..1809f0fcdb 100644
--- a/plugins/ltac/rewrite.ml
+++ b/plugins/ltac/rewrite.ml
@@ -664,7 +664,7 @@ type rewrite_result =
type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *)
env : Environ.env ;
- unfresh : Id.t list ; (* Unfresh names *)
+ unfresh : Id.Set.t; (* Unfresh names *)
term1 : constr ;
ty1 : types ; (* first term and its type (convertible to rew_from) *)
cstr : (bool (* prop *) * constr option) ;
@@ -1614,7 +1614,7 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause =
in
try
let res =
- cl_rewrite_clause_aux ?abs strat env [] sigma ty clause
+ cl_rewrite_clause_aux ?abs strat env Id.Set.empty sigma ty clause
in
let sigma = match origsigma with None -> sigma | Some sigma -> sigma in
treat sigma res <*>
@@ -1935,7 +1935,12 @@ let default_morphism sign m =
let evars, mor = resolve_one_typeclass env (goalevars evars) morph in
mor, proper_projection sigma mor morph
+let warn_add_setoid_deprecated =
+ CWarnings.create ~name:"add-setoid" ~category:"deprecated" (fun () ->
+ Pp.(str "Add Setoid is deprecated, please use Add Parametric Relation."))
+
let add_setoid global binders a aeq t n =
+ warn_add_setoid_deprecated ?loc:a.CAst.loc ();
init_setoid ();
let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in
let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in
@@ -1954,7 +1959,12 @@ let make_tactic name =
let tacname = Qualid (Loc.tag tacpath) in
TacArg (Loc.tag @@ TacCall (Loc.tag (tacname, [])))
+let warn_add_morphism_deprecated =
+ CWarnings.create ~name:"add-morphism" ~category:"deprecated" (fun () ->
+ Pp.(str "Add Morphism f : id is deprecated, please use Add Morphism f with signature (...) as id"))
+
let add_morphism_infer glob m n =
+ warn_add_morphism_deprecated ?loc:m.CAst.loc ();
init_setoid ();
let poly = Flags.is_universe_polymorphism () in
let instance_id = add_suffix n "_Proper" in
diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli
index 23767c12f5..63e891b455 100644
--- a/plugins/ltac/rewrite.mli
+++ b/plugins/ltac/rewrite.mli
@@ -110,7 +110,7 @@ val setoid_transitivity : constr option -> unit Proofview.tactic
val apply_strategy :
strategy ->
Environ.env ->
- Names.Id.t list ->
+ Names.Id.Set.t ->
constr ->
bool * constr ->
evars -> rewrite_result
diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml
index a8d518fbd8..0bf6e3d155 100644
--- a/plugins/ltac/tacentries.ml
+++ b/plugins/ltac/tacentries.ml
@@ -409,7 +409,7 @@ let create_ltac_quotation name cast (e, l) =
type tacdef_kind =
| NewTac of Id.t
- | UpdateTac of Nametab.ltac_constant
+ | UpdateTac of Tacexpr.ltac_constant
let is_defined_tac kn =
try ignore (Tacenv.interp_ltac kn); true with Not_found -> false
@@ -441,7 +441,7 @@ let register_ltac local tacl =
| Tacexpr.TacticRedefinition (ident, body) ->
let loc = loc_of_reference ident in
let kn =
- try Nametab.locate_tactic (snd (qualid_of_reference ident))
+ try Tacenv.locate_tactic (snd (qualid_of_reference ident))
with Not_found ->
CErrors.user_err ?loc
(str "There is no Ltac named " ++ pr_reference ident ++ str ".")
@@ -464,18 +464,20 @@ let register_ltac local tacl =
let defs () =
(** Register locally the tactic to handle recursivity. This function affects
the whole environment, so that we transactify it afterwards. *)
- let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in
+ let iter_rec (sp, kn) = Tacenv.push_tactic (Nametab.Until 1) sp kn in
let () = List.iter iter_rec recvars in
List.map map rfun
in
- let defs = Future.transactify defs () in
+ (* STATE XXX: Review what is going on here. Why does this needs
+ protection? Why is not the STM level protection enough? Fishy *)
+ let defs = States.with_state_protection defs () in
let iter (def, tac) = match def with
| NewTac id ->
Tacenv.register_ltac false local id tac;
Flags.if_verbose Feedback.msg_info (Id.print id ++ str " is defined")
| UpdateTac kn ->
Tacenv.redefine_ltac local kn tac;
- let name = Nametab.shortest_qualid_of_tactic kn in
+ let name = Tacenv.shortest_qualid_of_tactic kn in
Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined")
in
List.iter iter defs
@@ -488,7 +490,7 @@ let print_ltacs () =
let entries = List.sort sort entries in
let map (kn, entry) =
let qid =
- try Some (Nametab.shortest_qualid_of_tactic kn)
+ try Some (Tacenv.shortest_qualid_of_tactic kn)
with Not_found -> None
in
match qid with
@@ -506,6 +508,31 @@ let print_ltacs () =
in
Feedback.msg_notice (prlist_with_sep fnl pr_entry entries)
+let locatable_ltac = "Ltac"
+
+let () =
+ let open Prettyp in
+ let locate qid = try Some (Tacenv.locate_tactic qid) with Not_found -> None in
+ let locate_all = Tacenv.locate_extended_all_tactic in
+ let shortest_qualid = Tacenv.shortest_qualid_of_tactic in
+ let name kn = str "Ltac" ++ spc () ++ pr_path (Tacenv.path_of_tactic kn) in
+ let print kn =
+ let qid = qualid_of_path (Tacenv.path_of_tactic kn) in
+ Tacintern.print_ltac qid
+ in
+ let about = name in
+ register_locatable locatable_ltac {
+ locate;
+ locate_all;
+ shortest_qualid;
+ name;
+ print;
+ about;
+ }
+
+let print_located_tactic qid =
+ Feedback.msg_notice (Prettyp.print_located_other locatable_ltac qid)
+
(** Grammar *)
let () =
diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli
index aa8f4efe65..ab2c6b3073 100644
--- a/plugins/ltac/tacentries.mli
+++ b/plugins/ltac/tacentries.mli
@@ -62,3 +62,6 @@ val create_ltac_quotation : string ->
val print_ltacs : unit -> unit
(** Display the list of ltac definitions currently available. *)
+
+val print_located_tactic : Libnames.reference -> unit
+(** Display the absolute name of a tactic. *)
diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml
index 13b44f0e2c..8c59a36fa6 100644
--- a/plugins/ltac/tacenv.ml
+++ b/plugins/ltac/tacenv.ml
@@ -11,6 +11,42 @@ open Pp
open Names
open Tacexpr
+(** Nametab for tactics *)
+
+(** TODO: Share me somewhere *)
+module FullPath =
+struct
+ open Libnames
+ type t = full_path
+ let equal = eq_full_path
+ let to_string = string_of_path
+ let repr sp =
+ let dir,id = repr_path sp in
+ id, (DirPath.repr dir)
+end
+
+module KnTab = Nametab.Make(FullPath)(KerName)
+
+let tactic_tab = Summary.ref ~name:"LTAC-NAMETAB" (KnTab.empty, KNmap.empty)
+
+let push_tactic vis sp kn =
+ let (tab, revtab) = !tactic_tab in
+ let tab = KnTab.push vis sp kn tab in
+ let revtab = KNmap.add kn sp revtab in
+ tactic_tab := (tab, revtab)
+
+let locate_tactic qid = KnTab.locate qid (fst !tactic_tab)
+
+let locate_extended_all_tactic qid = KnTab.find_prefixes qid (fst !tactic_tab)
+
+let exists_tactic kn = KnTab.exists kn (fst !tactic_tab)
+
+let path_of_tactic kn = KNmap.find kn (snd !tactic_tab)
+
+let shortest_qualid_of_tactic kn =
+ let sp = KNmap.find kn (snd !tactic_tab) in
+ KnTab.shortest_qualid Id.Set.empty sp (fst !tactic_tab)
+
(** Tactic notations (TacAlias) *)
type alias = KerName.t
@@ -103,19 +139,19 @@ let replace kn path t =
let load_md i ((sp, kn), (local, id, b, t)) = match id with
| None ->
- let () = if not local then Nametab.push_tactic (Until i) sp kn in
+ let () = if not local then push_tactic (Until i) sp kn in
add kn b t
| Some kn0 -> replace kn0 kn t
let open_md i ((sp, kn), (local, id, b, t)) = match id with
| None ->
- let () = if not local then Nametab.push_tactic (Exactly i) sp kn in
+ let () = if not local then push_tactic (Exactly i) sp kn in
add kn b t
| Some kn0 -> replace kn0 kn t
let cache_md ((sp, kn), (local, id ,b, t)) = match id with
| None ->
- let () = Nametab.push_tactic (Until 1) sp kn in
+ let () = push_tactic (Until 1) sp kn in
add kn b t
| Some kn0 -> replace kn0 kn t
@@ -128,7 +164,7 @@ let subst_md (subst, (local, id, b, t)) =
let classify_md (local, _, _, _ as o) = Substitute o
-let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj =
+let inMD : bool * ltac_constant option * bool * glob_tactic_expr -> obj =
declare_object {(default_object "TAC-DEFINITION") with
cache_function = cache_md;
load_function = load_md;
diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli
index 958109e5a7..4ecc978fea 100644
--- a/plugins/ltac/tacenv.mli
+++ b/plugins/ltac/tacenv.mli
@@ -7,11 +7,21 @@
(************************************************************************)
open Names
+open Libnames
open Tacexpr
open Geninterp
(** This module centralizes the various ways of registering tactics. *)
+(** {5 Tactic naming} *)
+
+val push_tactic : Nametab.visibility -> full_path -> ltac_constant -> unit
+val locate_tactic : qualid -> ltac_constant
+val locate_extended_all_tactic : qualid -> ltac_constant list
+val exists_tactic : full_path -> bool
+val path_of_tactic : ltac_constant -> full_path
+val shortest_qualid_of_tactic : ltac_constant -> qualid
+
(** {5 Tactic notations} *)
type alias = KerName.t
diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli
index 64da097deb..2c36faeff4 100644
--- a/plugins/ltac/tacexpr.mli
+++ b/plugins/ltac/tacexpr.mli
@@ -10,13 +10,14 @@ open Loc
open Names
open Constrexpr
open Libnames
-open Nametab
open Genredexpr
open Genarg
open Pattern
open Misctypes
open Locus
+type ltac_constant = KerName.t
+
type direction_flag = bool (* true = Left-to-right false = right-to-right *)
type lazy_flag =
| General (* returns all possible successes *)
diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml
index fc6ee6aab6..99d7684d36 100644
--- a/plugins/ltac/tacintern.ml
+++ b/plugins/ltac/tacintern.ml
@@ -118,7 +118,7 @@ let intern_constr_reference strict ist = function
let intern_isolated_global_tactic_reference r =
let (loc,qid) = qualid_of_reference r in
- TacCall (Loc.tag ?loc (ArgArg (loc,locate_tactic qid),[]))
+ TacCall (Loc.tag ?loc (ArgArg (loc,Tacenv.locate_tactic qid),[]))
let intern_isolated_tactic_reference strict ist r =
(* An ltac reference *)
@@ -137,7 +137,7 @@ let intern_isolated_tactic_reference strict ist r =
let intern_applied_global_tactic_reference r =
let (loc,qid) = qualid_of_reference r in
- ArgArg (loc,locate_tactic qid)
+ ArgArg (loc,Tacenv.locate_tactic qid)
let intern_applied_tactic_reference ist r =
(* An ltac reference *)
@@ -722,7 +722,7 @@ let pr_ltac_fun_arg n = spc () ++ Name.print n
let print_ltac id =
try
- let kn = Nametab.locate_tactic id in
+ let kn = Tacenv.locate_tactic id in
let entries = Tacenv.ltac_entries () in
let tac = KNmap.find kn entries in
let filter mp =
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index 8fa95ffb02..20f117ff4f 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -139,7 +139,7 @@ let name_vfun appl vle =
module TacStore = Geninterp.TacStore
-let f_avoid_ids : Id.t list TacStore.field = TacStore.field ()
+let f_avoid_ids : Id.Set.t TacStore.field = TacStore.field ()
(* ids inherited from the call context (needed to get fresh ids) *)
let f_debug : debug_info TacStore.field = TacStore.field ()
let f_trace : ltac_trace TacStore.field = TacStore.field ()
@@ -501,29 +501,29 @@ let extract_ltac_constr_values ist env =
could barely be defined as a feature... *)
(* Extract the identifier list from lfun: join all branches (what to do else?)*)
-let rec intropattern_ids (loc,pat) = match pat with
- | IntroNaming (IntroIdentifier id) -> [id]
+let rec intropattern_ids accu (loc,pat) = match pat with
+ | IntroNaming (IntroIdentifier id) -> Id.Set.add id accu
| IntroAction (IntroOrAndPattern (IntroAndPattern l)) ->
- List.flatten (List.map intropattern_ids l)
+ List.fold_left intropattern_ids accu l
| IntroAction (IntroOrAndPattern (IntroOrPattern ll)) ->
- List.flatten (List.map intropattern_ids (List.flatten ll))
+ List.fold_left intropattern_ids accu (List.flatten ll)
| IntroAction (IntroInjection l) ->
- List.flatten (List.map intropattern_ids l)
- | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat
+ List.fold_left intropattern_ids accu l
+ | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids accu pat
| IntroNaming (IntroAnonymous | IntroFresh _)
| IntroAction (IntroWildcard | IntroRewrite _)
- | IntroForthcoming _ -> []
+ | IntroForthcoming _ -> accu
-let extract_ids ids lfun =
+let extract_ids ids lfun accu =
let fold id v accu =
let v = Value.normalize v in
if has_type v (topwit wit_intro_pattern) then
let (_, ipat) = out_gen (topwit wit_intro_pattern) v in
if Id.List.mem id ids then accu
- else accu @ intropattern_ids (Loc.tag ipat)
+ else intropattern_ids accu (Loc.tag ipat)
else accu
in
- Id.Map.fold fold lfun []
+ Id.Map.fold fold lfun accu
let default_fresh_id = Id.of_string "H"
@@ -534,10 +534,10 @@ let interp_fresh_id ist env sigma l =
with Not_found -> id in
let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in
let avoid = match TacStore.get ist.extra f_avoid_ids with
- | None -> []
+ | None -> Id.Set.empty
| Some l -> l
in
- let avoid = (extract_ids ids ist.lfun) @ avoid in
+ let avoid = extract_ids ids ist.lfun avoid in
let id =
if List.is_empty l then default_fresh_id
else
@@ -1303,7 +1303,7 @@ and interp_ltac_reference ?loc' mustbetac ist r : Val.t Ftactic.t =
if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v
end
| ArgArg (loc,r) ->
- let ids = extract_ids [] ist.lfun in
+ let ids = extract_ids [] ist.lfun Id.Set.empty in
let loc_info = (Option.default loc loc',LtacNameCall r) in
let extra = TacStore.set ist.extra f_avoid_ids ids in
push_trace loc_info ist >>= fun trace ->
@@ -1394,7 +1394,13 @@ and interp_app loc ist fv largs : Val.t Ftactic.t =
if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval
else
Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body)))
- | _ -> fail
+ | (VFun(appl,trace,olfun,[],body)) ->
+ let extra_args = List.length largs in
+ Tacticals.New.tclZEROMSG (str "Illegal tactic application: got " ++
+ str (string_of_int extra_args) ++
+ str " extra " ++ str (String.plural extra_args "argument") ++
+ str ".")
+ | VRec(_,_) -> fail
else fail
(* Gives the tactic corresponding to the tactic value *)
@@ -1956,7 +1962,7 @@ let interp_tac_gen lfun avoid_ids debug t =
(intern_pure_tactic { (Genintern.empty_glob_sign env) with ltacvars } t)
end
-let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t
+let interp t = interp_tac_gen Id.Map.empty Id.Set.empty (get_debug()) t
(* Used to hide interpretation for pretty-print, now just launch tactics *)
(* [global] means that [t] should be internalized outside of goals. *)
diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli
index c1ab2b4c49..d0a0a81d4c 100644
--- a/plugins/ltac/tacinterp.mli
+++ b/plugins/ltac/tacinterp.mli
@@ -40,7 +40,7 @@ type interp_sign = Geninterp.interp_sign = {
lfun : value Id.Map.t;
extra : TacStore.t }
-val f_avoid_ids : Id.t list TacStore.field
+val f_avoid_ids : Id.Set.t TacStore.field
val f_debug : debug_info TacStore.field
val extract_ltac_constr_values : interp_sign -> Environ.env ->
@@ -113,7 +113,7 @@ val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic
(** Globalization + interpretation *)
-val interp_tac_gen : value Id.Map.t -> Id.t list ->
+val interp_tac_gen : value Id.Map.t -> Id.Set.t ->
debug_info -> raw_tactic_expr -> unit Proofview.tactic
val interp : raw_tactic_expr -> unit Proofview.tactic
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 17:47:34 +0000