aboutsummaryrefslogtreecommitdiffhomepage
path: root/vernac
diff options
context:
space:
mode:
Diffstat (limited to 'vernac')
-rw-r--r--vernac/command.ml3
-rw-r--r--vernac/discharge.ml30
-rw-r--r--vernac/lemmas.ml5
-rw-r--r--vernac/metasyntax.ml181
-rw-r--r--vernac/mltop.ml3
-rw-r--r--vernac/vernacentries.ml30
-rw-r--r--vernac/vernacprop.ml3
7 files changed, 126 insertions, 129 deletions
diff --git a/vernac/command.ml b/vernac/command.ml
index 59f59e530..120f9590f 100644
--- a/vernac/command.ml
+++ b/vernac/command.ml
@@ -9,7 +9,6 @@
open Pp
open CErrors
open Util
-open Flags
open Term
open Vars
open Termops
@@ -692,7 +691,7 @@ let declare_mutual_inductive_with_eliminations mie pl impls =
constrimpls)
impls;
let warn_prim = match mie.mind_entry_record with Some (Some _) -> not prim | _ -> false in
- if_verbose Feedback.msg_info (minductive_message warn_prim names);
+ Flags.if_verbose Feedback.msg_info (minductive_message warn_prim names);
if mie.mind_entry_private == None
then declare_default_schemes mind;
mind
diff --git a/vernac/discharge.ml b/vernac/discharge.ml
index 474c0b4dd..0e4bbd299 100644
--- a/vernac/discharge.ml
+++ b/vernac/discharge.ml
@@ -36,32 +36,32 @@ let detype_param =
I1..Ip:(B1 y1..yq)..(Bp y1..yq) |- ci : (y1..yq:C1..Cq)Ti[Ij:=(Ij y1..yq)]
*)
-let abstract_inductive hyps nparams inds =
+let abstract_inductive decls nparamdecls inds =
let ntyp = List.length inds in
- let nhyp = Context.Named.length hyps in
- let args = Context.Named.to_instance mkVar (List.rev hyps) in
+ let ndecls = Context.Named.length decls in
+ let args = Context.Named.to_instance mkVar (List.rev decls) in
let args = Array.of_list args in
- let subs = List.init ntyp (fun k -> lift nhyp (mkApp(mkRel (k+1),args))) in
+ let subs = List.init ntyp (fun k -> lift ndecls (mkApp(mkRel (k+1),args))) in
let inds' =
List.map
(function (tname,arity,template,cnames,lc) ->
let lc' = List.map (substl subs) lc in
- let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b hyps) lc' in
- let arity' = Termops.it_mkNamedProd_wo_LetIn arity hyps in
+ let lc'' = List.map (fun b -> Termops.it_mkNamedProd_wo_LetIn b decls) lc' in
+ let arity' = Termops.it_mkNamedProd_wo_LetIn arity decls in
(tname,arity',template,cnames,lc''))
inds in
- let nparams' = nparams + Array.length args in
+ let nparamdecls' = nparamdecls + Array.length args in
(* To be sure to be the same as before, should probably be moved to process_inductive *)
let params' = let (_,arity,_,_,_) = List.hd inds' in
- let (params,_) = decompose_prod_n_assum nparams' arity in
+ let (params,_) = decompose_prod_n_assum nparamdecls' arity in
List.map detype_param params
in
let ind'' =
List.map
(fun (a,arity,template,c,lc) ->
- let _, short_arity = decompose_prod_n_assum nparams' arity in
+ let _, short_arity = decompose_prod_n_assum nparamdecls' arity in
let shortlc =
- List.map (fun c -> snd (decompose_prod_n_assum nparams' c)) lc in
+ List.map (fun c -> snd (decompose_prod_n_assum nparamdecls' c)) lc in
{ mind_entry_typename = a;
mind_entry_arity = short_arity;
mind_entry_template = template;
@@ -77,9 +77,9 @@ let refresh_polymorphic_type_of_inductive (_,mip) =
let ctx = List.rev mip.mind_arity_ctxt in
mkArity (List.rev ctx, Type ar.template_level), true
-let process_inductive (sechyps,_,_ as info) modlist mib =
- let sechyps = Lib.named_of_variable_context sechyps in
- let nparams = mib.mind_nparams in
+let process_inductive (section_decls,_,_ as info) modlist mib =
+ let section_decls = Lib.named_of_variable_context section_decls in
+ let nparamdecls = Context.Rel.length mib.mind_params_ctxt in
let subst, ind_univs =
match mib.mind_universes with
| Monomorphic_ind ctx -> Univ.empty_level_subst, Monomorphic_ind_entry ctx
@@ -105,8 +105,8 @@ let process_inductive (sechyps,_,_ as info) modlist mib =
Array.to_list mip.mind_consnames,
Array.to_list lc))
mib.mind_packets in
- let sechyps' = Context.Named.map discharge sechyps in
- let (params',inds') = abstract_inductive sechyps' nparams inds in
+ let section_decls' = Context.Named.map discharge section_decls in
+ let (params',inds') = abstract_inductive section_decls' nparamdecls inds in
let record = match mib.mind_record with
| Some (Some (id, _, _)) -> Some (Some id)
| Some None -> Some None
diff --git a/vernac/lemmas.ml b/vernac/lemmas.ml
index 391e78bcd..4b36c2d07 100644
--- a/vernac/lemmas.ml
+++ b/vernac/lemmas.ml
@@ -11,7 +11,6 @@
open CErrors
open Util
-open Flags
open Pp
open Names
open Term
@@ -137,7 +136,7 @@ let find_mutually_recursive_statements thms =
assert (List.is_empty rest);
(* One occ. of common coind ccls and no common inductive hyps *)
if not (List.is_empty common_same_indhyp) then
- if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements.");
+ Flags.if_verbose Feedback.msg_info (str "Assuming mutual coinductive statements.");
flush_all ();
indccl, true, []
| [], _::_ ->
@@ -145,7 +144,7 @@ let find_mutually_recursive_statements thms =
| ind :: _ ->
if List.distinct_f ind_ord (List.map pi1 ind)
then
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(strbrk
("Coinductive statements do not follow the order of "^
"definition, assuming the proof to be by induction."));
diff --git a/vernac/metasyntax.ml b/vernac/metasyntax.ml
index c424b1d50..5298ef2e4 100644
--- a/vernac/metasyntax.ml
+++ b/vernac/metasyntax.ml
@@ -7,7 +7,6 @@
(************************************************************************)
open Pp
-open Flags
open CErrors
open Util
open Names
@@ -99,18 +98,24 @@ let pr_grammar = function
let parse_format ((loc, str) : lstring) =
let len = String.length str in
- let push_token a = function
- | cur::l -> (a::cur)::l
- | [] -> [[a]] in
- let push_white n l =
- if Int.equal n 0 then l else push_token (UnpTerminal (String.make n ' ')) l in
- let close_box i b = function
- | a::(_::_ as l) -> push_token (UnpBox (b,a)) l
- | _ -> user_err Pp.(str "Non terminated box in format.") in
- let close_quotation i =
- if i < len && str.[i] == '\'' && (Int.equal (i+1) len || str.[i+1] == ' ')
- then i+1
- else user_err Pp.(str "Incorrectly terminated quoted expression.") in
+ (* TODO: update the line of the location when the string contains newlines *)
+ let make_loc i j = Option.map (Loc.shift_loc (i+1) (j-len)) loc in
+ let push_token loc a = function
+ | (i,cur)::l -> (i,(loc,a)::cur)::l
+ | [] -> assert false in
+ let push_white i n l =
+ if Int.equal n 0 then l else push_token (make_loc i (i+n)) (UnpTerminal (String.make n ' ')) l in
+ let close_box start stop b = function
+ | (_,a)::(_::_ as l) -> push_token (make_loc start stop) (UnpBox (b,a)) l
+ | [a] -> user_err ?loc:(make_loc start stop) Pp.(str "Non terminated box in format.")
+ | [] -> assert false in
+ let close_quotation start i =
+ if i < len && str.[i] == '\'' then
+ if (Int.equal (i+1) len || str.[i+1] == ' ')
+ then i+1
+ else user_err ?loc:(make_loc (i+1) (i+1)) Pp.(str "Space expected after quoted expression.")
+ else
+ user_err ?loc:(make_loc start (i-1)) Pp.(str "Beginning of quoted expression expected to be ended by a quote.") in
let rec spaces n i =
if i < len && str.[i] == ' ' then spaces (n+1) (i+1)
else n in
@@ -118,81 +123,78 @@ let parse_format ((loc, str) : lstring) =
if i < len && str.[i] != ' ' then
if str.[i] == '\'' && quoted &&
(i+1 >= len || str.[i+1] == ' ')
- then if Int.equal n 0 then user_err Pp.(str "Empty quoted token.") else n
+ then if Int.equal n 0 then user_err ?loc:(make_loc (i-1) i) Pp.(str "Empty quoted token.") else n
else nonspaces quoted (n+1) (i+1)
else
- if quoted then user_err Pp.(str "Spaces are not allowed in (quoted) symbols.")
+ if quoted then user_err ?loc:(make_loc i i) Pp.(str "Spaces are not allowed in (quoted) symbols.")
else n in
let rec parse_non_format i =
let n = nonspaces false 0 i in
- push_token (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n))
+ push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str i n)) (parse_token 1 (i+n))
and parse_quoted n i =
if i < len then match str.[i] with
(* Parse " // " *)
- | '/' when i <= len && str.[i+1] == '/' ->
- (* We forget the useless n spaces... *)
- push_token (UnpCut PpFnl)
- (parse_token 1 (close_quotation (i+2)))
+ | '/' when i+1 < len && str.[i+1] == '/' ->
+ (* We discard the useless n spaces... *)
+ push_token (make_loc (i-n) (i+1)) (UnpCut PpFnl)
+ (parse_token 1 (close_quotation i (i+2)))
(* Parse " .. / .. " *)
- | '/' when i <= len ->
+ | '/' when i+1 < len ->
let p = spaces 0 (i+1) in
- push_token (UnpCut (PpBrk (n,p)))
- (parse_token 1 (close_quotation (i+p+1)))
+ push_token (make_loc (i-n) (i+p)) (UnpCut (PpBrk (n,p)))
+ (parse_token 1 (close_quotation i (i+p+1)))
| c ->
(* The spaces are real spaces *)
- push_white n (match c with
+ push_white i n (match c with
| '[' ->
- if i <= len then match str.[i+1] with
+ if i+1 < len then match str.[i+1] with
(* Parse " [h .. ", *)
| 'h' when i+1 <= len && str.[i+2] == 'v' ->
- (parse_box (fun n -> PpHVB n) (i+3))
+ (parse_box i (fun n -> PpHVB n) (i+3))
(* Parse " [v .. ", *)
| 'v' ->
- parse_box (fun n -> PpVB n) (i+2)
+ parse_box i (fun n -> PpVB n) (i+2)
(* Parse " [ .. ", *)
| ' ' | '\'' ->
- parse_box (fun n -> PpHOVB n) (i+1)
- | _ -> user_err Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.")
- else user_err Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.")
+ parse_box i (fun n -> PpHOVB n) (i+1)
+ | _ -> user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\", \" \" expected after \"[\" in format.")
+ else user_err ?loc:(make_loc i i) Pp.(str "\"v\", \"hv\" or \" \" expected after \"[\" in format.")
(* Parse "]" *)
| ']' ->
- ([] :: parse_token 1 (close_quotation (i+1)))
+ ((i,[]) :: parse_token 1 (close_quotation i (i+1)))
(* Parse a non formatting token *)
| c ->
let n = nonspaces true 0 i in
- push_token (UnpTerminal (String.sub str (i-1) (n+2)))
- (parse_token 1 (close_quotation (i+n))))
+ push_token (make_loc i (i+n-1)) (UnpTerminal (String.sub str (i-1) (n+2)))
+ (parse_token 1 (close_quotation i (i+n))))
else
if Int.equal n 0 then []
- else user_err Pp.(str "Ending spaces non part of a format annotation.")
- and parse_box box i =
+ else user_err ?loc:(make_loc (len-n) len) Pp.(str "Ending spaces non part of a format annotation.")
+ and parse_box start box i =
let n = spaces 0 i in
- close_box i (box n) (parse_token 1 (close_quotation (i+n)))
+ close_box start (i+n-1) (box n) (parse_token 1 (close_quotation i (i+n)))
and parse_token k i =
let n = spaces 0 i in
let i = i+n in
if i < len then match str.[i] with
(* Parse a ' *)
| '\'' when i+1 >= len || str.[i+1] == ' ' ->
- push_white (n-k) (push_token (UnpTerminal "'") (parse_token 1 (i+1)))
+ push_white (i-n) (n-k) (push_token (make_loc i (i+1)) (UnpTerminal "'") (parse_token 1 (i+1)))
(* Parse the beginning of a quoted expression *)
| '\'' ->
parse_quoted (n-k) (i+1)
(* Otherwise *)
| _ ->
- push_white (n-k) (parse_non_format i)
- else push_white n [[]]
+ push_white (i-n) (n-k) (parse_non_format i)
+ else push_white (i-n) n [(len,[])]
in
- try
- if not (String.is_empty str) then match parse_token 0 0 with
- | [l] -> l
- | _ -> user_err Pp.(str "Box closed without being opened in format.")
- else
- []
- with reraise ->
- let (e, info) = CErrors.push reraise in
- let info = Option.cata (Loc.add_loc info) info loc in
- iraise (e, info)
+ if not (String.is_empty str) then
+ match parse_token 0 0 with
+ | [_,l] -> l
+ | (i,_)::_ -> user_err ?loc:(make_loc i i) Pp.(str "Box closed without being opened.")
+ | [] -> assert false
+ else
+ []
(***********************)
(* Analyzing notations *)
@@ -383,11 +385,11 @@ let is_next_terminal = function Terminal _ :: _ -> true | _ -> false
let is_next_break = function Break _ :: _ -> true | _ -> false
-let add_break n l = UnpCut (PpBrk(n,0)) :: l
+let add_break n l = (None,UnpCut (PpBrk(n,0))) :: l
let add_break_if_none n = function
- | ((UnpCut (PpBrk _) :: _) | []) as l -> l
- | l -> UnpCut (PpBrk(n,0)) :: l
+ | (((_,UnpCut (PpBrk _)) :: _) | []) as l -> l
+ | l -> (None,UnpCut (PpBrk(n,0))) :: l
let check_open_binder isopen sl m =
let pr_token = function
@@ -413,30 +415,30 @@ let make_hunks etyps symbols from =
let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
let u = UnpMetaVar (i,prec) in
if is_next_non_terminal prods then
- u :: add_break_if_none 1 (make prods)
+ (None,u) :: add_break_if_none 1 (make prods)
else
- u :: make_with_space prods
+ (None,u) :: make_with_space prods
| Terminal s :: prods when List.exists is_non_terminal prods ->
if (is_comma s || is_operator s) then
(* Always a breakable space after comma or separator *)
- UnpTerminal s :: add_break_if_none 1 (make prods)
+ (None,UnpTerminal s) :: add_break_if_none 1 (make prods)
else if is_right_bracket s && is_next_terminal prods then
(* Always no space after right bracked, but possibly a break *)
- UnpTerminal s :: add_break_if_none 0 (make prods)
+ (None,UnpTerminal s) :: add_break_if_none 0 (make prods)
else if is_left_bracket s && is_next_non_terminal prods then
- UnpTerminal s :: make prods
+ (None,UnpTerminal s) :: make prods
else if not (is_next_break prods) then
(* Add rigid space, no break, unless user asked for something *)
- UnpTerminal (s^" ") :: make prods
+ (None,UnpTerminal (s^" ")) :: make prods
else
(* Rely on user spaces *)
- UnpTerminal s :: make prods
+ (None,UnpTerminal s) :: make prods
| Terminal s :: prods ->
(* Separate but do not cut a trailing sequence of terminal *)
(match prods with
- | Terminal _ :: _ -> UnpTerminal (s^" ") :: make prods
- | _ -> UnpTerminal s :: make prods)
+ | Terminal _ :: _ -> (None,UnpTerminal (s^" ")) :: make prods
+ | _ -> (None,UnpTerminal s) :: make prods)
| Break n :: prods ->
add_break n (make prods)
@@ -451,12 +453,12 @@ let make_hunks etyps symbols from =
(* We add NonTerminal for simulation but remove it afterwards *)
else snd (List.sep_last (make (sl@[NonTerminal m]))) in
let hunk = match typ with
- | ETConstr _ -> UnpListMetaVar (i,prec,sl')
+ | ETConstr _ -> UnpListMetaVar (i,prec,List.map snd sl')
| ETBinder isopen ->
check_open_binder isopen sl m;
- UnpBinderListMetaVar (i,isopen,sl')
+ UnpBinderListMetaVar (i,isopen,List.map snd sl')
| _ -> assert false in
- hunk :: make_with_space prods
+ (None,hunk) :: make_with_space prods
| [] -> []
@@ -465,7 +467,7 @@ let make_hunks etyps symbols from =
| Terminal s' :: prods'->
if is_operator s' then
(* A rigid space before operator and a breakable after *)
- UnpTerminal (" "^s') :: add_break_if_none 1 (make prods')
+ (None,UnpTerminal (" "^s')) :: add_break_if_none 1 (make prods')
else if is_comma s' then
(* No space whatsoever before comma *)
make prods
@@ -486,58 +488,63 @@ let make_hunks etyps symbols from =
(* Build default printing rules from explicit format *)
-let error_format () = user_err Pp.(str "The format does not match the notation.")
+let error_format ?loc () = user_err ?loc Pp.(str "The format does not match the notation.")
let rec split_format_at_ldots hd = function
- | UnpTerminal s :: fmt when String.equal s (Id.to_string ldots_var) -> List.rev hd, fmt
+ | (loc,UnpTerminal s) :: fmt when String.equal s (Id.to_string ldots_var) -> loc, List.rev hd, fmt
| u :: fmt ->
check_no_ldots_in_box u;
split_format_at_ldots (u::hd) fmt
| [] -> raise Exit
and check_no_ldots_in_box = function
- | UnpBox (_,fmt) ->
+ | (_,UnpBox (_,fmt)) ->
(try
- let _ = split_format_at_ldots [] fmt in
- user_err Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse."))
+ let loc,_,_ = split_format_at_ldots [] fmt in
+ user_err ?loc Pp.(str ("The special symbol \"..\" must occur at the same formatting depth than the variables of which it is the ellipse."))
with Exit -> ())
| _ -> ()
+let error_not_same ?loc () =
+ user_err ?loc Pp.(str "The format is not the same on the right- and left-hand sides of the special token \"..\".")
+
let skip_var_in_recursive_format = function
- | UnpTerminal _ :: sl (* skip first var *) ->
+ | (_,UnpTerminal s) :: sl (* skip first var *) when not (List.for_all (fun c -> c = " ") (String.explode s)) ->
(* To do, though not so important: check that the names match
the names in the notation *)
sl
- | _ -> error_format ()
+ | (loc,_) :: _ -> error_not_same ?loc ()
+ | [] -> assert false
let read_recursive_format sl fmt =
let get_head fmt =
let sl = skip_var_in_recursive_format fmt in
- try split_format_at_ldots [] sl with Exit -> error_format () in
+ try split_format_at_ldots [] sl with Exit -> error_not_same ?loc:(fst (List.last (if sl = [] then fmt else sl))) () in
let rec get_tail = function
- | a :: sepfmt, b :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *)
+ | (loc,a) :: sepfmt, (_,b) :: fmt when Pervasives.(=) a b -> get_tail (sepfmt, fmt) (* FIXME *)
| [], tail -> skip_var_in_recursive_format tail
- | _ -> user_err Pp.(str "The format is not the same on the right and left hand side of the special token \"..\".") in
- let slfmt, fmt = get_head fmt in
+ | (loc,_) :: _, ([] | (_,UnpTerminal _) :: _)-> error_not_same ?loc ()
+ | _, (loc,_)::_ -> error_not_same ?loc () in
+ let loc, slfmt, fmt = get_head fmt in
slfmt, get_tail (slfmt, fmt)
let hunks_of_format (from,(vars,typs)) symfmt =
let rec aux = function
- | symbs, (UnpTerminal s' as u) :: fmt
+ | symbs, (_,(UnpTerminal s' as u)) :: fmt
when String.equal s' (String.make (String.length s') ' ') ->
let symbs, l = aux (symbs,fmt) in symbs, u :: l
- | Terminal s :: symbs, (UnpTerminal s') :: fmt
+ | Terminal s :: symbs, (_,UnpTerminal s') :: fmt
when String.equal s (String.drop_simple_quotes s') ->
let symbs, l = aux (symbs,fmt) in symbs, UnpTerminal s :: l
- | NonTerminal s :: symbs, UnpTerminal s' :: fmt when Id.equal s (Id.of_string s') ->
+ | NonTerminal s :: symbs, (_,UnpTerminal s') :: fmt when Id.equal s (Id.of_string s') ->
let i = index_id s vars in
let _,prec = precedence_of_entry_type from (List.nth typs (i-1)) in
let symbs, l = aux (symbs,fmt) in symbs, UnpMetaVar (i,prec) :: l
- | symbs, UnpBox (a,b) :: fmt ->
+ | symbs, (_,UnpBox (a,b)) :: fmt ->
let symbs', b' = aux (symbs,b) in
let symbs', l = aux (symbs',fmt) in
- symbs', UnpBox (a,b') :: l
- | symbs, (UnpCut _ as u) :: fmt ->
+ symbs', UnpBox (a,List.map (fun x -> (None,x)) b') :: l
+ | symbs, (_,(UnpCut _ as u)) :: fmt ->
let symbs, l = aux (symbs,fmt) in symbs, u :: l
| SProdList (m,sl) :: symbs, fmt ->
let i = index_id m vars in
@@ -545,7 +552,7 @@ let hunks_of_format (from,(vars,typs)) symfmt =
let _,prec = precedence_of_entry_type from typ in
let slfmt,fmt = read_recursive_format sl fmt in
let sl, slfmt = aux (sl,slfmt) in
- if not (List.is_empty sl) then error_format ();
+ if not (List.is_empty sl) then error_format ?loc:(fst (List.last fmt)) ();
let symbs, l = aux (symbs,fmt) in
let hunk = match typ with
| ETConstr _ -> UnpListMetaVar (i,prec,slfmt)
@@ -555,7 +562,7 @@ let hunks_of_format (from,(vars,typs)) symfmt =
| _ -> assert false in
symbs, hunk :: l
| symbs, [] -> symbs, []
- | _, _ -> error_format ()
+ | _, fmt -> error_format ?loc:(fst (List.hd fmt)) ()
in
match aux symfmt with
| [], l -> l
@@ -794,7 +801,7 @@ type notation_modifier = {
(* common to syn_data below *)
only_parsing : bool;
only_printing : bool;
- compat : compat_version option;
+ compat : Flags.compat_version option;
format : string Loc.located option;
extra : (string * string) list;
}
@@ -1073,7 +1080,7 @@ module SynData = struct
(* Fields coming from the vernac-level modifiers *)
only_parsing : bool;
only_printing : bool;
- compat : compat_version option;
+ compat : Flags.compat_version option;
format : string Loc.located option;
extra : (string * string) list;
@@ -1389,7 +1396,7 @@ let add_notation_interpretation ((loc,df),c,sc) =
let set_notation_for_interpretation impls ((_,df),c,sc) =
(try ignore
- (silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ());
+ (Flags.silently (fun () -> add_notation_interpretation_core false df ~impls c sc false false None) ());
with NoSyntaxRule ->
user_err Pp.(str "Parsing rule for this notation has to be previously declared."));
Option.iter (fun sc -> Notation.open_close_scope (false,true,sc)) sc
diff --git a/vernac/mltop.ml b/vernac/mltop.ml
index e8a0ba3dd..1edbd1a85 100644
--- a/vernac/mltop.ml
+++ b/vernac/mltop.ml
@@ -9,7 +9,6 @@
open CErrors
open Util
open Pp
-open Flags
open Libobject
open System
@@ -365,7 +364,7 @@ let trigger_ml_object verb cache reinit ?path name =
else begin
let file = file_of_name (Option.default name path) in
let path =
- if_verbose_load (verb && not !quiet) load_ml_object name ?path file in
+ if_verbose_load (verb && not !Flags.quiet) load_ml_object name ?path file in
add_loaded_module name (Some path);
if cache then perform_cache_obj name
end
diff --git a/vernac/vernacentries.ml b/vernac/vernacentries.ml
index c90d038f6..ee84ff101 100644
--- a/vernac/vernacentries.ml
+++ b/vernac/vernacentries.ml
@@ -11,7 +11,6 @@
open Pp
open CErrors
open Util
-open Flags
open Names
open Nameops
open Term
@@ -657,7 +656,7 @@ let vernac_declare_module export (loc, id) binders_ast mty_ast =
id binders_ast (Enforce mty_ast) []
in
Dumpglob.dump_moddef ?loc mp "mod";
- if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared");
+ Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is declared");
Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)]) export
let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
@@ -678,7 +677,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
export id binders_ast mty_ast_o
in
Dumpglob.dump_moddef ?loc mp "mod";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Interactive Module " ++ pr_id id ++ str " started");
List.iter
(fun (export,id) ->
@@ -696,7 +695,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
id binders_ast mty_ast_o mexpr_ast_l
in
Dumpglob.dump_moddef ?loc mp "mod";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Module " ++ pr_id id ++ str " is defined");
Option.iter (fun export -> vernac_import export [Ident (Loc.tag id)])
export
@@ -704,7 +703,7 @@ let vernac_define_module export (loc, id) binders_ast mty_ast_o mexpr_ast_l =
let vernac_end_module export (loc,id as lid) =
let mp = Declaremods.end_module () in
Dumpglob.dump_modref ?loc mp "mod";
- if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined");
+ Flags.if_verbose Feedback.msg_info (str "Module " ++ pr_id id ++ str " is defined");
Option.iter (fun export -> vernac_import export [Ident lid]) export
let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
@@ -725,7 +724,7 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
id binders_ast mty_sign
in
Dumpglob.dump_moddef ?loc mp "modtype";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Interactive Module Type " ++ pr_id id ++ str " started");
List.iter
(fun (export,id) ->
@@ -744,13 +743,13 @@ let vernac_declare_module_type (loc,id) binders_ast mty_sign mty_ast_l =
id binders_ast mty_sign mty_ast_l
in
Dumpglob.dump_moddef ?loc mp "modtype";
- if_verbose Feedback.msg_info
+ Flags.if_verbose Feedback.msg_info
(str "Module Type " ++ pr_id id ++ str " is defined")
let vernac_end_modtype (loc,id) =
let mp = Declaremods.end_modtype () in
Dumpglob.dump_modref ?loc mp "modtype";
- if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined")
+ Flags.if_verbose Feedback.msg_info (str "Module Type " ++ pr_id id ++ str " is defined")
let vernac_include l =
Declaremods.declare_include Modintern.interp_module_ast l
@@ -818,7 +817,7 @@ let vernac_coercion locality poly local ref qids qidt =
let source = cl_of_qualid qids in
let ref' = smart_global ref in
Class.try_add_new_coercion_with_target ref' ~local poly ~source ~target;
- if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion")
+ Flags.if_verbose Feedback.msg_info (pr_global ref' ++ str " is now a coercion")
let vernac_identity_coercion locality poly local id qids qidt =
let local = enforce_locality locality local in
@@ -920,7 +919,7 @@ let vernac_chdir = function
so we make it an error. *)
user_err Pp.(str ("Cd failed: " ^ err))
end;
- if_verbose Feedback.msg_info (str (Sys.getcwd()))
+ Flags.if_verbose Feedback.msg_info (str (Sys.getcwd()))
(********************)
@@ -1302,7 +1301,7 @@ let _ =
optname = "automatic introduction of variables";
optkey = ["Automatic";"Introduction"];
optread = Flags.is_auto_intros;
- optwrite = make_auto_intros }
+ optwrite = Flags.make_auto_intros }
let _ =
declare_bool_option
@@ -1924,7 +1923,6 @@ let interp ?proof ?loc locality poly c =
| VernacTime _ -> assert false
| VernacRedirect _ -> assert false
| VernacTimeout _ -> assert false
- | VernacStm _ -> assert false
(* The STM should handle that, but LOAD bypasses the STM... *)
| VernacAbortAll -> CErrors.user_err (str "AbortAll cannot be used through the Load command")
@@ -2050,7 +2048,7 @@ let interp ?proof ?loc locality poly c =
| VernacSearch (s,g,r) -> vernac_search ?loc s g r
| VernacLocate l -> vernac_locate l
| VernacRegister (id, r) -> vernac_register id r
- | VernacComments l -> if_verbose Feedback.msg_info (str "Comments ok\n")
+ | VernacComments l -> Flags.if_verbose Feedback.msg_info (str "Comments ok\n")
(* Proof management *)
| VernacGoal t -> vernac_start_proof locality poly Theorem [None,([],t)]
@@ -2176,7 +2174,7 @@ let with_fail b f =
| HasNotFailed ->
user_err ~hdr:"Fail" (str "The command has not failed!")
| HasFailed msg ->
- if not !Flags.quiet || !test_mode || !ide_slave then Feedback.msg_info
+ if not !Flags.quiet || !Flags.test_mode || !Flags.ide_slave then Feedback.msg_info
(str "The command has indeed failed with message:" ++ fnl () ++ msg)
| _ -> assert false
end
@@ -2185,10 +2183,6 @@ let interp ?(verbosely=true) ?proof (loc,c) =
let orig_program_mode = Flags.is_program_mode () in
let rec aux ?locality ?polymorphism isprogcmd = function
- (* This assert case will be removed when fake_ide can understand
- completion feedback *)
- | VernacStm _ -> assert false (* Done by Stm *)
-
| VernacProgram c when not isprogcmd -> aux ?locality ?polymorphism true c
| VernacProgram _ -> user_err Pp.(str "Program mode specified twice")
| VernacLocal (b, c) when Option.is_empty locality ->
diff --git a/vernac/vernacprop.ml b/vernac/vernacprop.ml
index fc11bcf4a..3cff1f14c 100644
--- a/vernac/vernacprop.ml
+++ b/vernac/vernacprop.ml
@@ -17,8 +17,7 @@ let rec is_navigation_vernac = function
| VernacResetName _
| VernacBacktrack _
| VernacBackTo _
- | VernacBack _
- | VernacStm _ -> true
+ | VernacBack _ -> true
| VernacRedirect (_, (_,c))
| VernacTime (_,c) ->
is_navigation_vernac c (* Time Back* is harmless *)
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-19 06:47:16 +0000