From 4fcdeca24c2c3977a85cc45497ddd36a4c533923 Mon Sep 17 00:00:00 2001
From: Pascal Raymond <Pascal.Raymond@imag.fr>
Date: Tue, 10 Jul 2012 11:24:40 +0200
Subject: [PATCH] reutilise le MainArgs de lutin, plus joli ...
---
ALIRE.compil-des-nodes | 6 +-
Makefile | 2 +
overload.lus | 13 +-
src/compile.ml | 2 +-
src/lazyCompiler.ml | 27 +++-
src/main.ml | 164 ++---------------------
src/mainArgs.ml | 288 +++++++++++++++++++++++++++++++++++++++++
src/mainArgs.mli | 12 ++
src/name.ml | 7 +-
src/verbose.ml | 43 ++++--
src/verbose.mli | 24 +++-
11 files changed, 401 insertions(+), 187 deletions(-)
create mode 100644 src/mainArgs.ml
create mode 100644 src/mainArgs.mli
diff --git a/ALIRE.compil-des-nodes b/ALIRE.compil-des-nodes
index bd61621d..cb7aedf9 100644
--- a/ALIRE.compil-des-nodes
+++ b/ALIRE.compil-des-nodes
@@ -8,7 +8,5 @@ compile_all_item node_check_interface ->
node_check_interface_do
-node_check
-
-node_check_do
-
+ node_check: cache on node_check_do
+ + node_check_do en plus pour l'interface (prov)
diff --git a/Makefile b/Makefile
index 94d7dd62..69e40a46 100644
--- a/Makefile
+++ b/Makefile
@@ -100,6 +100,8 @@ SOURCES = \
$(OBJDIR)/lazyCompiler.ml \
$(OBJDIR)/lazyCompiler.mli \
$(OBJDIR)/compile.ml \
+ $(OBJDIR)/mainArgs.ml \
+ $(OBJDIR)/mainArgs.mli \
$(OBJDIR)/main.ml
#
diff --git a/overload.lus b/overload.lus
index b20d1c8e..fe73618a 100644
--- a/overload.lus
+++ b/overload.lus
@@ -1,9 +1,12 @@
-node titi = map<<+,4>>;
+node overplus = map<<+,4>>;
-node toto(x,y: int^4) returns (o: int^4);
-let o = titi(x,y); tel
+node do_int(x,y: int^4) returns (o: int^4);
+let o = overplus(x,y); tel
-node tutu(x,y: real^4) returns (o: real^4);
-let o = titi(x,y); tel
+node do_real(x,y: real^4) returns (o: real^4);
+let o = overplus(x,y); tel
+
+node do_bool(x,y: real^4) returns (o: real^4);
+let o = overplus(x,y); tel
diff --git a/src/compile.ml b/src/compile.ml
index 948be3a4..19f0f403 100644
--- a/src/compile.ml
+++ b/src/compile.ml
@@ -28,7 +28,7 @@ let (doit : SyntaxTree.pack_or_model list -> Ident.idref option -> unit) =
priorité dans l'ordre
*)
let lzcomp = LazyCompiler.create syntax_tab in
- if Verbose.get_level () > 2 then SyntaxTab.dump syntax_tab;
+ Verbose.exe ~level:2 (fun () -> SyntaxTab.dump syntax_tab);
Ident.set_dft_pack_name (first_pack_in srclist);
let zelic = match main_node with
diff --git a/src/lazyCompiler.ml b/src/lazyCompiler.ml
index 70e718ee..cb389265 100644
--- a/src/lazyCompiler.ml
+++ b/src/lazyCompiler.ml
@@ -623,6 +623,11 @@ and (node_check_interface_do: t -> Eff.node_key -> Lxm.t ->
SymbolTab.t -> Ident.pack_name -> SyntaxTreeCore.node_info srcflagged ->
Eff.node_exp) =
fun this nk lxm symbols pn node_def ->
+ (* DEUX checks :
+ - le "complet" donne 'body_node_exp_eff' qui sera stocké comme le vrai résultat
+ - le "provide" donne 'prov_node_exp_eff', non stocké, sert à vérifier la
+ cohérence avec l'éventuelle déclaration 'provide'
+ *)
let body_node_exp_eff = node_check this nk lxm in
let prov_node_exp_eff = node_check_do this nk lxm symbols true pn node_def in
(** [type_eff_are_compatible t1 t2] checks that t1 is compatible with t2, i.e.,
@@ -698,10 +703,22 @@ and (node_check_interface_do: t -> Eff.node_key -> Lxm.t ->
| _,_ ->
prov_node_exp_eff
-and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
- bool -> Ident.pack_name -> SyntaxTreeCore.node_info srcflagged ->
- Eff.node_exp) =
- fun this nk lxm symbols provide_flag pack_name node_def ->
+(*
+LE GROS DU BOULOT
+- suivant "provide_flag" : check d'interface (provide) ou le check de la définition
+ (n.b. provide_flag influence la résolution des idents dans l'env local de check)
+*)
+and node_check_do
+ (this: t)
+ (nk: Eff.node_key)
+ (lxm: Lxm.t)
+ (symbols: SymbolTab.t)
+ (provide_flag: bool)
+ (pack_name: Ident.pack_name)
+ (node_def: SyntaxTreeCore.node_info srcflagged)
+ : Eff.node_exp =
+(* START node_check_do *)
+(
let lxm = node_def.src in
(* Creates a local_env with just the global bindings,
local bindinds will be added later (side effect)
@@ -1071,6 +1088,8 @@ and (node_check_do: t -> Eff.node_key -> Lxm.t -> SymbolTab.t ->
let _ = UniqueOutput.check res node_def.src in
(* gen_code provide_flag current_env res; *)
res
+)
+(*END node_check_do *)
(*
[make_alias_node aliased_node alias_nk node_id_solver_vars_opt lxm]
diff --git a/src/main.ml b/src/main.ml
index 61cf8db4..b798a221 100644
--- a/src/main.ml
+++ b/src/main.ml
@@ -59,157 +59,6 @@ let test_lex ( lexbuf ) = (
done
)
-(*---------------------------------------------------------
-Les args sont des variables GLOBALES
----------------------------------------------------------*)
-
-let print_version = function (x: unit) -> (
- print_string (Version.str ^ "\n")
-)
-
-let usage_msg =
- "usage: "^(Version.tool)^" [options] <lustre files>\nwhere [options] can be:"
-
-let rec arg_list = [
- ( "--node", Arg.String(fun x -> Global.main_node := x; Global.compile_all_items := false),
- "<node>"
- );
- ( "-n", Arg.String(fun x -> Global.main_node := x; Global.compile_all_items := false),
- "<node>\n\t Set the main node (all items are compiled if unset)"
- );
-
- ( "--output-file", Arg.String(fun x -> Global.outfile := x), "<file>"
- );
- ( "-o", Arg.String(fun x -> Global.outfile := x),
- "<file>\n\t Set the output file name."
- );
-
- ( "--keep-nested-calls", Arg.Unit (fun _ -> Global.one_op_per_equation := false),
- ""
- );
- ( "-knc", Arg.Unit (fun _ -> Global.one_op_per_equation := false),
- "\n\t Keep nested calls. By default, only one node per equation is generated."
- );
-
- ( "--expand-iterators", Arg.Unit (fun _ -> Global.inline_iterator := true),
- ""
- );
- ( "-ei", Arg.Unit (fun _ -> Global.inline_iterator := true),
- "\n\t Expand array iterators (i.e., generate iterator-free code)."
- );
-
- ( "--expand-enums", Arg.Unit (fun _ -> Global.expand_enums := true),
- ""
- );
- ( "-ee", Arg.Unit (fun _ -> Global.expand_enums := true),
- "\n\t Translate enums into integers."
- );
-
- ( "--expand-structs-and-arrays", Arg.Unit
- (fun _ -> Global.expand_structs := true;Global.inline_iterator := true),
- ""
- );
- ( "-esa", Arg.Unit
- (fun _ -> Global.expand_structs := true;Global.inline_iterator := true),
- "\n\t Expand structures and arrays using as many variables as necessary (automatically impose '-ei')."
- );
-
- ( "--expand-nodes", Arg.Unit (fun _ -> Global.expand_nodes := true),
- ""
- );
- ( "-en", Arg.Unit (fun _ -> Global.expand_nodes := true),
- "\n\t Expand the main node (use the first node if no one is specified)."
- );
-
- ( "--do-not-expand-node", Arg.String add_dont_expand_nodes,
- "<node>"
- );
- ( "-den", Arg.String add_dont_expand_nodes,
- "<node>\n\t Do not expand node (useful in the expand mode only of course)."
- );
-
- ( "--lustre-v4", Arg.Unit
- (fun _ -> set_v4_options ()),
- "\t"
- );
-
- ( "-lv4", Arg.Unit
- (fun _ -> set_v4_options ()),
- "\n\t Use Lustre V4 syntax (automatically impose '-ei -ee -esa')."
- );
-
- ( "--expanded-code", Arg.Unit
- (fun _ -> set_ec_options ()),
- ""
- );
- ( "-ec", Arg.Unit
- (fun _ -> set_ec_options ()),
- "\n\t Generate ec (actually just an alias for '-en -lv4 --no-prefix')."
- );
-
- ( "-np", Arg.Set Global.no_prefix, "");
- ( "--no-prefix", Arg.Set Global.no_prefix,
- "\n\t Do not prefix variable names by their module (beware: variable names may clash with this option)."
- );
-
- ("--test-lexer",Arg.Set Global.tlex,"Internal option used to test the lexer");
- ("-tlex",Arg.Set Global.tlex,"");
-
- ( "--verbose-level", Arg.Int(fun vl -> Verbose.set_level vl ), "<int>"
- );
- ( "-vl", Arg.Int(fun vl -> Verbose.set_level vl ),
- "<int>\n\t Set the verbose level."
- );
-
- ( "--verbose", Arg.Unit (fun vl -> Verbose.set_level 1 ),
- ""
- );
- ( "-v", Arg.Unit (fun vl -> Verbose.set_level 1 ),
- "\n\t Set the verbose level to 1."
- );
-
- ( "--version", Arg.Unit(fun x -> print_version () ; exit 0),
- ""
- );
- ( "-version", Arg.Unit(fun x -> print_version () ; exit 0),
- "\n\t Display the current version of the tool."
- );
-
- ( "-unit", Arg.Unit (fun x -> Global.run_unit_test := true),
- "\n\t Run some (internal) unit tests"
- );
-
- ("--nonreg-test", Arg.Unit(fun _ -> Global.nonreg_test := true),
- "");
-
- ("-h", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)), "" );
- ("-help", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)),"" );
- ("--help", Arg.Unit (fun _ -> (Arg.usage arg_list usage_msg; exit 0)),
- "\n\t Display this message." )
-]
-and set_v4_options () =
- Global.lv4 := true;
- Global.inline_iterator := true;
- Global.expand_enums := true;
- Global.expand_structs := true
-and set_ec_options () =
- set_v4_options ();
- Global.ec := true;
- Global.no_prefix := true;
- Global.expand_nodes := true
-
-and add_dont_expand_nodes str =
- Global.dont_expand_nodes := str::!Global.dont_expand_nodes
-and
- parse_args () = (
- Arg.parse arg_list (* liste des options *)
- Global.add_infile (* arg par defaut = fichier d'entree *)
- usage_msg (* message d'erreur *)
- ;
- ()
- )
-
-
(* Retourne un SyntaxTree.t *)
let lus_load lexbuf =
let tree = Parser.program Lexer.lexer lexbuf in
@@ -373,14 +222,17 @@ let my_exit i =
let main = (
(* Compile.init_appli () ; *)
- parse_args ();
- if Verbose.get_level() > 2 then Gc.set { (Gc.get ()) with Gc.verbose = 0x01 };
+ (* parse_args (); *)
+ let args = MainArgs.parse Sys.argv in
+ Verbose.exe ~level:3 (fun () ->
+ Gc.set { (Gc.get ()) with Gc.verbose = 0x01 }
+ );
if !Global.run_unit_test then (
UnifyType.unit_test ();
exit 0
);
if (!Global.infiles = []) then (
- Arg.usage arg_list usage_msg ;
+ MainArgs.usage stderr args;
exit 1
);
try (
@@ -396,7 +248,9 @@ let main = (
(* OBSOLETE
LicDump.dump_type_alias !Global.oc;
*)
- if Verbose.get_level() > 2 then Gc.print_stat stdout;
+ Verbose.exe ~level:3 (fun () ->
+ Gc.print_stat stdout
+ );
close_out !Global.oc
) with
Sys_error(s) ->
diff --git a/src/mainArgs.ml b/src/mainArgs.ml
new file mode 100644
index 00000000..56f09d4c
--- /dev/null
+++ b/src/mainArgs.ml
@@ -0,0 +1,288 @@
+(*
+Le manager d'argument adapté de celui de lutin, plus joli
+N.B. solution un peu batarde : les options sont stockées, comme avant, dans Global,
+du coup, le fait de rendre un type "t" est une koketerie !
+*)
+open Version
+open Verbose
+open Arg
+
+let tool_name = Version.tool
+let usage_msg = "usage: "^tool_name^" [options] <file> | "^tool_name^" -help"
+
+type t = {
+ mutable _opts : (string * Arg.spec * string) list; (* classical Arg option tab used by Arg.parse *)
+ mutable _user_man : (string * string list) list; (* ad hoc tab for pretty prtting usage *)
+ mutable _hidden_man: (string * string list) list; (* ad hoc tab for pretty prtting usage *)
+ mutable _others: string list;
+ mutable _margin : int;
+
+}
+
+let (make_opt : unit -> t) =
+ fun () ->
+ {
+ _opts = [];
+ _user_man = [];
+ _hidden_man = [];
+ _others = [];
+ _margin = 12;
+}
+
+
+(* all unrecognized options are accumulated *)
+let (add_other : t -> string -> unit) =
+ fun opt s ->
+ opt._others <- s::opt._others
+
+let pspec os opt (c, ml) = (
+ let (m1, oth) = match ml with
+ | h::t -> (h,t)
+ | _ -> ("",[])
+ in
+ let t2 = String.make opt._margin ' ' in
+ let cl = String.length c in
+ let t1 = if (cl < opt._margin ) then
+ String.make (opt._margin - cl) ' '
+ else
+ "\n"^t2
+ in
+ Printf.fprintf os "%s%s%s" c t1 m1;
+ List.iter (function x -> Printf.fprintf os "\n%s%s" t2 x) oth ;
+ Printf.fprintf os "\n" ;
+)
+
+let usage os opt = (
+ let l = List.rev opt._user_man in
+ Printf.fprintf os "%s\n\n" usage_msg;
+ List.iter (pspec os opt) l
+)
+let help opt ()= (
+ usage stdout opt;
+ exit 0
+)
+let full_usage os opt = (
+ Printf.fprintf os "%s\n" usage_msg;
+ let l = List.rev opt._user_man in
+ List.iter (pspec os opt) l;
+ let l = List.rev (opt._hidden_man) in
+ List.iter (pspec os opt) l
+)
+let full_help opt ()= (
+ full_usage stdout opt;
+ exit 0
+)
+
+let unexpected s opt = (
+ prerr_string ("unexpected argument \""^s^"\"");
+ prerr_newline ();
+ usage stderr opt;
+ exit 1
+)
+let file_notfound f opt = (
+ prerr_string ("File not found: \""^f^"\"");
+ prerr_newline ();
+ usage stderr opt;
+ exit 1
+)
+
+let debug_options_list =
+ [
+ "CkType";
+ "Expand";
+ "LutExe";
+ "Run";
+ "LutProg";
+ "LucProg";
+ "AutoGen"; "AutoExplore"; "Guard"
+ ]
+
+let (mkopt : t -> string list -> ?hide:bool -> ?arg:string -> Arg.spec -> string list -> unit) =
+ fun opt ol ?(hide=false) ?(arg="") se ml ->
+ let treto o = opt._opts <- (o, se, "")::opt._opts in
+ List.iter treto ol ;
+ let col1 = (String.concat ", " ol)^arg in
+ if hide
+ then opt._hidden_man <- (col1, ml)::opt._hidden_man
+ else opt._user_man <- (col1, ml)::opt._user_man
+ (*
+ let tabs = String.make (col - (String.length o) - (String.length arg)) ' ' in
+ (* (o, se, arg^tabs^m) *)
+ (o, se, arg^"\n "^m)
+ *)
+
+(* utils *)
+let set_v4_options () =
+ Global.lv4 := true;
+ Global.inline_iterator := true;
+ Global.expand_enums := true;
+ Global.expand_structs := true
+let set_ec_options () =
+ set_v4_options ();
+ Global.ec := true;
+ Global.no_prefix := true;
+ Global.expand_nodes := true
+
+(*** USER OPTIONS TAB **)
+let mkoptab (opt:t) : unit = (
+ mkopt opt
+ ["-n";"-node"]
+ ~arg:" <string>"
+ (Arg.String(function x ->
+ Global.main_node := x;
+ Global.compile_all_items := false))
+ ["Set the main node (all items are compiled if unset)"]
+ ;
+ mkopt opt
+ ["-o";"--output-file"]
+ ~arg:" <string>"
+ (Arg.String(function x ->
+ Global.outfile := x))
+ ["Set the output file name"]
+ ;
+ mkopt opt
+ ["-knc"; "--keep-nested-calls"]
+ (Arg.Unit (fun _ -> Global.one_op_per_equation := false))
+ ["Keep nested calls. By default, only one node per equation is generated."]
+ ;
+ mkopt opt
+ ["-ei"; "--expand-iterators"]
+ (Arg.Unit (fun _ -> Global.inline_iterator := true))
+ ["Expand array iterators (i.e., generate iterator-free code)."]
+ ;
+ mkopt opt
+ ["-ee"; "--expand-enums"]
+ (Arg.Unit (fun _ -> Global.expand_enums := true))
+ [" Translate enums into integers."]
+ ;
+ mkopt opt
+ ["-esa"; "--expand-structs-and-arrays"]
+ (Arg.Unit (fun _ ->
+ Global.expand_structs := true;
+ Global.inline_iterator := true))
+ ["Expand structures and arrays using as many variables as necessary (automatically impose '-ei')"]
+ ;
+ mkopt opt
+ ["-en"; "--expand-nodes"]
+ (Arg.Unit (fun _ -> Global.expand_nodes := true))
+ ["Expand the main node (use the first node if no one is specified)."]
+ ;
+ mkopt opt
+ ["-den"; "--do_not-expand-nodes"]
+ ~arg:" <string>"
+ (Arg.String (fun str ->
+ Global.dont_expand_nodes := str::!Global.dont_expand_nodes
+ ))
+ ["Do not expand node (useful in the expand mode only of course)."]
+ ;
+ mkopt opt
+ ["-lv4"; "--lustre-v4"]
+ (Arg.Unit (fun _ -> set_v4_options ()))
+ ["Use Lustre V4 syntax (automatically impose '-ei -ee -esa')."]
+ ;
+ mkopt opt
+ ["-ec"; "--expanded-code"]
+ (Arg.Unit (fun _ -> set_ec_options ()))
+ ["Generate ec (actually just an alias for '-en -lv4 --no-prefix')."]
+ ;
+ mkopt opt
+ ["-np"; "--no-prefix"]
+ (Arg.Set Global.no_prefix)
+ ["Do not prefix variable names by their module (beware: variable names may clash with this option)."]
+ ;
+
+ mkopt opt
+ ["-version"]
+ (Arg.Unit(function _ -> Printf.fprintf stderr "%s\n" Version.str; exit 0))
+ ["Print the current version and exit"]
+ ;
+ (* verbose *)
+ mkopt opt
+ ["-v"; "--verbose"]
+ (Arg.Unit(function _ -> Verbose.on () ))
+ ["Set the verbose level to 1"]
+ ;
+ mkopt opt
+ ["-vl"]
+ ~arg:" <int>"
+ (Arg.Int(function i -> Verbose.set i))
+ ["Set the verbose level"]
+ ;
+
+ (* to show Hidden opt *)
+ mkopt opt
+ ["-more"]
+ (* (Arg.Unit(fun _ -> opt._see_all_options <- true)) *)
+ (Arg.Unit (full_help opt))
+ ["Show hidden options (for dev purposes)"];
+ (* HIDDEN *)
+
+ (* test lexical *)
+ mkopt opt ~hide:true
+ ["-tlex"; "--test-lexer"]
+ (Arg.Set Global.tlex)
+ ["Test the lexical analysis"]
+ ;
+ (* test syntaxique
+ mkopt opt ~hide:true
+ ["-tparse"]
+ (Arg.Unit(function _ -> opt._gen_mode <- GenLuc ; opt._test_parse <- true ; ()))
+ ["Test the syntactic analysis"]
+ ;
+ *)
+ mkopt opt ~hide:true
+ ["-unit"]
+ (Arg.Set Global.run_unit_test)
+ ["Run some (internal) unit tests"]
+ ;
+ mkopt opt ~hide:true
+ ["--nonreg-test"]
+ (Arg.Set Global.nonreg_test)
+ ["(internal)"]
+ ;
+ (* misc degub flag *)
+ mkopt opt ~hide:true
+ ["-dbg"; "--debug"]
+ (Arg.Symbol (debug_options_list,
+ (function s -> let x = Verbose.get_flag s in Verbose.set_flag x)))
+ [ "<dbg_flag>";
+ "Possible dbg_flag are: " ^(String.concat ", " debug_options_list) ]
+)
+
+
+let first_line b = (
+ try (
+ let f = String.index b '\n' in
+ String.sub b 0 f
+ ) with Not_found -> b
+)
+
+
+let current = ref 0;;
+
+(* La ``méthode'' principale *)
+let parse argv = (
+ let opt = make_opt() in
+ let save_current = !current in
+ try (
+ mkoptab opt;
+ Arg.parse_argv ~current:current argv opt._opts (add_other opt) usage_msg;
+ (List.iter
+ (fun f ->
+ if (String.sub f 0 1 = "-") then
+ unexpected f opt
+ else if not (Sys.file_exists f) then
+ file_notfound f opt
+ else ()
+ )
+ opt._others
+ );
+ Global.infiles := (List.rev opt._others);
+ current := save_current;
+ opt
+ ) with
+ (* only 1rst line is interesting ! *)
+ | Bad msg -> Printf.fprintf stderr "%s\n" (first_line msg); usage stderr opt; exit 2;
+ | Help msg -> help opt ();
+)
+
diff --git a/src/mainArgs.mli b/src/mainArgs.mli
new file mode 100644
index 00000000..b00eae1d
--- /dev/null
+++ b/src/mainArgs.mli
@@ -0,0 +1,12 @@
+
+(* koketeri, vu qu'on continu à ranger concetement
+ les options dans des var. globales ! (cf Global
+*)
+type t
+
+(* La ``méthode'' principale *)
+val parse : string array -> t
+
+val usage : out_channel -> t -> unit
+val full_usage : out_channel -> t -> unit
+
diff --git a/src/name.ml b/src/name.ml
index b64d0c18..b3d21733 100644
--- a/src/name.ml
+++ b/src/name.ml
@@ -121,9 +121,10 @@ let (update_fresh_var_prefix : unit -> unit) =
else (
let new_prefix = ("_" ^ (string_of_int index)) in
fresh_var_prefix := new_prefix ;
- if (Verbose.get_level()>1) then (
- print_string ("I use " ^ new_prefix ^ " as prefix for fresh var names.\n");
- flush stdout
+ Verbose.exe ~level:1 (
+ fun () ->
+ prerr_string ("I use " ^ new_prefix ^ " as prefix for fresh var names.\n");
+ flush stderr
)
)
diff --git a/src/verbose.ml b/src/verbose.ml
index ed10721b..0f2c6ea9 100644
--- a/src/verbose.ml
+++ b/src/verbose.ml
@@ -2,6 +2,8 @@
module : Verbose
date :
------------------------------------------------------------------------
+-- New: 2010/11, debug flag system
+
description :
Affichage verbeux avec appel "printf-like" :
@@ -21,23 +23,48 @@ N.B. VERSION GORE : le kprintf n'est appel
----------------------------------------------------------------------*)
+type flag = bool ref
+
+let _no_flag = ref false
+
+let _flag_tab : (string, flag) Hashtbl.t = Hashtbl.create 10
+(* warning: last in first ! *)
+let _flag_list : string list ref = ref []
+
+let get_flag s = (
+ try (
+ Hashtbl.find _flag_tab s
+ ) with Not_found -> (
+ let res = ref false in
+ Hashtbl.add _flag_tab s res;
+ _flag_list := s::!_flag_list;
+ res
+ )
+)
+let set_flag f = (f := true)
+let flag_list () = !_flag_list
(* type msg = string Lazy.t *)
let _level = ref 0
-let set_level (l:int) = ( _level := l )
-let get_level () = !_level
+let on () = ( _level := 1 )
+let off () = ( _level := 0 )
+let set (l:int) = ( _level := l )
+
+let level () = !_level
(**** VERSION PAS TROP GORE *****)
-let printf ?(level=1) s = Printf.kprintf
- (fun t -> if (!_level >= level) then (print_string t; flush stdout) else ()) s
+let printf ?(level=1) ?(flag=_no_flag) s =
+ Printf.kprintf (fun t -> if (!flag || (!_level >= level)) then (prerr_string t; flush stderr) else ()) s
+
+let print_string ?(level=1) ?(flag=_no_flag) s =
+ if (!flag || (!_level >= level)) then (prerr_string s; flush stderr)
+
-let print_string ?(level=1) s =
- if (!_level >= level) then (print_string s; flush stdout)
+let exe ?(level=1) ?(flag=_no_flag) f =
+ if (!flag || (!_level >= level)) then f () else ()
-let exe ?(level=1) p =
- if (!_level >= level) then p ()
(**** VERSION GORE *****)
(*
diff --git a/src/verbose.mli b/src/verbose.mli
index e08817db..7484b16a 100644
--- a/src/verbose.mli
+++ b/src/verbose.mli
@@ -1,5 +1,3 @@
-(** Time-stamp: <modified the 28/01/2008 (at 14:13) by Erwan Jahier> *)
-
(*----------------------------------------------------------------------
module : Verbose
date :
@@ -12,10 +10,22 @@ Verbose.put "format" args...
----------------------------------------------------------------------*)
+val on : unit -> unit
+val off : unit -> unit
+val set : int -> unit
+
+type flag
+val get_flag : string -> flag
+val set_flag : flag -> unit
+val flag_list : unit -> string list
+
+(* val level : unit -> int *)
-val set_level : int -> unit
-val get_level : unit -> int
+(* print/execute if EITHER:
+ - level (dflt=1) is >= than the set level
+ - flag is set
+*)
-val printf : ?level:int -> ('a, unit, string, unit) format4 -> 'a
-val exe : ?level:int -> (unit -> unit) -> unit
-val print_string : ?level:int -> string -> unit
+val printf : ?level:int -> ?flag:flag -> ('a, unit, string, unit) format4 -> 'a
+val print_string : ?level:int -> ?flag:flag -> string -> unit
+val exe : ?level:int -> ?flag:flag -> (unit -> unit) -> unit
--
GitLab