aboutsummaryrefslogtreecommitdiff
path: root/plugins
diff options
context:
space:
mode:
Diffstat (limited to 'plugins')
-rw-r--r--plugins/extraction/common.ml5
-rw-r--r--plugins/extraction/scheme.ml6
-rw-r--r--plugins/extraction/table.ml4
-rw-r--r--plugins/ltac/g_tactic.ml45
-rw-r--r--plugins/ltac/profile_ltac.ml2
-rw-r--r--plugins/ltac/tacentries.ml12
-rw-r--r--plugins/ltac/tacentries.mli2
-rw-r--r--plugins/ltac/tacintern.ml4
-rw-r--r--plugins/ltac/tacinterp.ml15
-rw-r--r--plugins/ltac/tacsubst.ml4
10 files changed, 30 insertions, 29 deletions
diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml
index de97ba97c3..0a591e786f 100644
--- a/plugins/extraction/common.ml
+++ b/plugins/extraction/common.ml
@@ -91,10 +91,7 @@ let begins_with_CoqXX s =
let unquote s =
if lang () != Scheme then s
- else
- let s = String.copy s in
- for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done;
- s
+ else String.map (fun c -> if c == '\'' then '~' else c) s
let rec qualify delim = function
| [] -> assert false
diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml
index a6309e61f9..8d0cc4a0db 100644
--- a/plugins/extraction/scheme.ml
+++ b/plugins/extraction/scheme.ml
@@ -40,11 +40,7 @@ let preamble _ comment _ usf =
(if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ())
let pr_id id =
- let s = Id.to_string id in
- for i = 0 to String.length s - 1 do
- if s.[i] == '\'' then s.[i] <- '~'
- done;
- str s
+ str @@ String.map (fun c -> if c == '\'' then '~' else c) (Id.to_string id)
let paren = pp_par true
diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml
index 5e7d810c93..d6a334c5fe 100644
--- a/plugins/extraction/table.ml
+++ b/plugins/extraction/table.ml
@@ -773,9 +773,7 @@ let file_of_modfile mp =
| MPfile f -> Id.to_string (List.hd (DirPath.repr f))
| _ -> assert false
in
- let s = String.copy (string_of_modfile mp) in
- if s.[0] != s0.[0] then s.[0] <- s0.[0];
- s
+ String.mapi (fun i c -> if i = 0 then s0.[0] else c) (string_of_modfile mp)
let add_blacklist_entries l =
blacklist_table :=
diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4
index 685c07c9a8..fa01baab75 100644
--- a/plugins/ltac/g_tactic.ml4
+++ b/plugins/ltac/g_tactic.ml4
@@ -325,8 +325,9 @@ GEXTEND Gram
l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] ->
let loc0,pat = pat in
let f c pat =
- let loc = Loc.merge loc0 (Constrexpr_ops.constr_loc c) in
- IntroAction (IntroApplyOn (c,(loc,pat))) in
+ let loc1 = Constrexpr_ops.constr_loc c in
+ let loc = Loc.merge loc0 loc1 in
+ IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in
!@loc, List.fold_right f l pat ] ]
;
simple_intropattern_closed:
diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml
index 2514ededb0..58123f63ef 100644
--- a/plugins/ltac/profile_ltac.ml
+++ b/plugins/ltac/profile_ltac.ml
@@ -257,7 +257,7 @@ let string_of_call ck =
(Pptactic.pr_glob_tactic (Global.env ())
te)
) in
- for i = 0 to String.length s - 1 do if s.[i] = '\n' then s.[i] <- ' ' done;
+ let s = String.map (fun c -> if c = '\n' then ' ' else c) s in
let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in
CString.strip s
diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml
index 75edf150e3..cd8c9e471e 100644
--- a/plugins/ltac/tacentries.ml
+++ b/plugins/ltac/tacentries.ml
@@ -302,9 +302,9 @@ let cons_production_parameter = function
| TacTerm _ -> None
| TacNonTerm (_, _, id) -> Some id
-let add_glob_tactic_notation local n prods forml ids tac =
+let add_glob_tactic_notation local ~level prods forml ids tac =
let parule = {
- tacgram_level = n;
+ tacgram_level = level;
tacgram_prods = prods;
} in
let tacobj = {
@@ -360,7 +360,7 @@ let extend_atomic_tactic name entries =
in
List.iteri add_atomic entries
-let add_ml_tactic_notation name prods =
+let add_ml_tactic_notation name ~level prods =
let len = List.length prods in
let iter i prods =
let open Tacexpr in
@@ -372,10 +372,12 @@ let add_ml_tactic_notation name prods =
let entry = { mltac_name = name; mltac_index = len - i - 1 } in
let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in
let tac = TacML (Loc.ghost, entry, List.map map ids) in
- add_glob_tactic_notation false 0 prods true ids tac
+ add_glob_tactic_notation false ~level prods true ids tac
in
List.iteri iter (List.rev prods);
- extend_atomic_tactic name prods
+ (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at
+ tactic_expr level 0) *)
+ if Int.equal level 0 then extend_atomic_tactic name prods
(**********************************************************************)
(** Ltac quotations *)
diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli
index 969c118fb5..0695044736 100644
--- a/plugins/ltac/tacentries.mli
+++ b/plugins/ltac/tacentries.mli
@@ -45,7 +45,7 @@ val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -
to finding an argument by name (as in {!Genarg}) if there is none
matching. *)
-val add_ml_tactic_notation : ml_tactic_name ->
+val add_ml_tactic_notation : ml_tactic_name -> level:int ->
argument grammar_tactic_prod_item_expr list list -> unit
(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND
ML-side macro. *)
diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml
index 1a8f26b264..3f83f104e9 100644
--- a/plugins/ltac/tacintern.ml
+++ b/plugins/ltac/tacintern.ml
@@ -248,8 +248,8 @@ and intern_intro_pattern_action lf ist = function
| IntroInjection l ->
IntroInjection (List.map (intern_intro_pattern lf ist) l)
| IntroWildcard | IntroRewrite _ as x -> x
- | IntroApplyOn (c,pat) ->
- IntroApplyOn (intern_constr ist c, intern_intro_pattern lf ist pat)
+ | IntroApplyOn ((loc,c),pat) ->
+ IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat)
and intern_or_and_intro_pattern lf ist = function
| IntroAndPattern l ->
diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml
index aa646aa517..155cb31d85 100644
--- a/plugins/ltac/tacinterp.ml
+++ b/plugins/ltac/tacinterp.ml
@@ -520,7 +520,7 @@ let rec intropattern_ids (loc,pat) = match pat with
List.flatten (List.map intropattern_ids (List.flatten ll))
| IntroAction (IntroInjection l) ->
List.flatten (List.map intropattern_ids l)
- | IntroAction (IntroApplyOn (c,pat)) -> intropattern_ids pat
+ | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat
| IntroNaming (IntroAnonymous | IntroFresh _)
| IntroAction (IntroWildcard | IntroRewrite _)
| IntroForthcoming _ -> []
@@ -913,14 +913,14 @@ and interp_intro_pattern_action ist env sigma = function
| IntroInjection l ->
let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in
sigma, IntroInjection l
- | IntroApplyOn (c,ipat) ->
+ | IntroApplyOn ((loc,c),ipat) ->
let c = { delayed = fun env sigma ->
let sigma = Sigma.to_evar_map sigma in
let (sigma, c) = interp_open_constr ist env sigma c in
Sigma.Unsafe.of_pair (c, sigma)
} in
let sigma,ipat = interp_intro_pattern ist env sigma ipat in
- sigma, IntroApplyOn (c,ipat)
+ sigma, IntroApplyOn ((loc,c),ipat)
| IntroWildcard | IntroRewrite _ as x -> sigma, x
and interp_or_and_intro_pattern ist env sigma = function
@@ -1422,7 +1422,14 @@ and tactic_of_value ist vle =
extra = TacStore.set ist.extra f_trace []; } in
let tac = name_if_glob appl (eval_tactic ist t) in
Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac)
- | (VFun _|VRec _) -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
+ | VFun (_, _, _,vars,_) ->
+ let numargs = List.length vars in
+ Tacticals.New.tclZEROMSG
+ (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++
+ Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++
+ Pp.str (String.plural numargs "variable") ++ Pp.str " " ++
+ pr_enum pr_name vars ++ Pp.str ".")
+ | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.")
else if has_type vle (topwit wit_tactic) then
let tac = out_gen (topwit wit_tactic) vle in
tactic_of_value ist tac
diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml
index b09bdda65c..fe3a9f3b2a 100644
--- a/plugins/ltac/tacsubst.ml
+++ b/plugins/ltac/tacsubst.ml
@@ -51,8 +51,8 @@ let rec subst_intro_pattern subst = function
| loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x
and subst_intro_pattern_action subst = function
- | IntroApplyOn (t,pat) ->
- IntroApplyOn (subst_glob_constr subst t,subst_intro_pattern subst pat)
+ | IntroApplyOn ((loc,t),pat) ->
+ IntroApplyOn ((loc,subst_glob_constr subst t),subst_intro_pattern subst pat)
| IntroOrAndPattern l ->
IntroOrAndPattern (subst_intro_or_and_pattern subst l)
| IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 07:50:33 +0000