Commit 22e8a735 authored by François Bobot's avatar François Bobot

Centralize the options for debug flags and use them in every why3 programs

parent f372e766
...@@ -113,7 +113,7 @@ LIBGENERATED = src/util/rc.ml src/parser/lexer.ml \ ...@@ -113,7 +113,7 @@ LIBGENERATED = src/util/rc.ml src/parser/lexer.ml \
src/driver/driver_parser.mli src/driver/driver_parser.ml \ src/driver/driver_parser.mli src/driver/driver_parser.ml \
src/driver/driver_lexer.ml src/coq_config.ml src/driver/driver_lexer.ml src/coq_config.ml
LIB_UTIL = stdlib exn_printer debug pp loc print_tree print_number \ LIB_UTIL = stdlib exn_printer pp debug loc print_tree print_number \
cmdline hashweak hashcons util sysutil rc plugin cmdline hashweak hashcons util sysutil rc plugin
LIB_CORE = ident ty term pattern decl theory task pretty env trans printer LIB_CORE = ident ty term pattern decl theory task pretty env trans printer
......
...@@ -44,7 +44,6 @@ let opt_input = ref None ...@@ -44,7 +44,6 @@ let opt_input = ref None
let opt_theory = ref None let opt_theory = ref None
let opt_trans = ref [] let opt_trans = ref []
let opt_metas = ref [] let opt_metas = ref []
let opt_debug = ref []
let add_opt_file x = let add_opt_file x =
let tlist = Queue.create () in let tlist = Queue.create () in
...@@ -85,8 +84,6 @@ let add_opt_goal x = match !opt_theory with ...@@ -85,8 +84,6 @@ let add_opt_goal x = match !opt_theory with
let add_opt_trans x = opt_trans := x::!opt_trans let add_opt_trans x = opt_trans := x::!opt_trans
let add_opt_debug x = opt_debug := x::!opt_debug
let add_opt_meta meta = let add_opt_meta meta =
let meta_name, meta_arg = let meta_name, meta_arg =
let index = String.index meta '=' in let index = String.index meta '=' in
...@@ -112,9 +109,7 @@ let opt_list_printers = ref false ...@@ -112,9 +109,7 @@ let opt_list_printers = ref false
let opt_list_provers = ref false let opt_list_provers = ref false
let opt_list_formats = ref false let opt_list_formats = ref false
let opt_list_metas = ref false let opt_list_metas = ref false
let opt_list_flags = ref false
let opt_debug_all = ref false
let opt_version = ref false let opt_version = ref false
let opt_quiet = ref false let opt_quiet = ref false
...@@ -188,12 +183,9 @@ let option_list = Arg.align [ ...@@ -188,12 +183,9 @@ let option_list = Arg.align [
" List known input formats"; " List known input formats";
"--list-metas", Arg.Set opt_list_metas, "--list-metas", Arg.Set opt_list_metas,
" List known metas"; " List known metas";
"--list-debug-flags", Arg.Set opt_list_flags, Debug.Opt.desc_debug_list;
" List known debug flags"; Debug.Opt.desc_debug_all;
"--debug-all", Arg.Set opt_debug_all, Debug.Opt.desc_debug;
" Set all debug flags (except parse_only and type_only)";
"--debug", Arg.String add_opt_debug,
"<flag> Set a debug flag";
"--quiet", Arg.Set opt_quiet, "--quiet", Arg.Set opt_quiet,
" Print only what asked"; " Print only what asked";
"--version", Arg.Set opt_version, "--version", Arg.Set opt_version,
...@@ -208,15 +200,6 @@ let () = ...@@ -208,15 +200,6 @@ let () =
try try
Arg.parse option_list add_opt_file usage_msg; Arg.parse option_list add_opt_file usage_msg;
(** Debug flag *)
if !opt_debug_all then begin
List.iter (fun (_,f,_) -> Debug.set_flag f) (Debug.list_flags ());
Debug.unset_flag Typing.debug_parse_only;
Debug.unset_flag Typing.debug_type_only
end;
List.iter (fun s -> Debug.set_flag (Debug.lookup_flag s)) !opt_debug;
(** Configuration *) (** Configuration *)
let config = try read_config !opt_config with Not_found -> let config = try read_config !opt_config with Not_found ->
option_iter (eprintf "Config file '%s' not found.@.") !opt_config; option_iter (eprintf "Config file '%s' not found.@.") !opt_config;
...@@ -226,6 +209,9 @@ let () = ...@@ -226,6 +209,9 @@ let () =
let main = get_main config in let main = get_main config in
Whyconf.load_plugins main; Whyconf.load_plugins main;
Bench.BenchUtil.maximum_running_proofs := Whyconf.running_provers_max main; Bench.BenchUtil.maximum_running_proofs := Whyconf.running_provers_max main;
Debug.Opt.set_flags_selected ();
(** listings*) (** listings*)
let opt_list = ref false in let opt_list = ref false in
...@@ -278,13 +264,7 @@ let () = ...@@ -278,13 +264,7 @@ let () =
printf "@[<hov 2>Known metas:@\n%a@]@\n@." printf "@[<hov 2>Known metas:@\n%a@]@\n@."
(Pp.print_list Pp.newline print) (List.sort cmp (Theory.list_metas ())) (Pp.print_list Pp.newline print) (List.sort cmp (Theory.list_metas ()))
end; end;
if !opt_list_flags then begin opt_list := Debug.Opt.option_list () || !opt_list;
opt_list := true;
let print fmt (p,_,_) = fprintf fmt "%s" p in
printf "@[<hov 2>Known debug flags:@\n%a@]@."
(Pp.print_list Pp.newline print)
(List.sort Pervasives.compare (Debug.list_flags ()))
end;
if !opt_list then exit 0; if !opt_list then exit 0;
(* Someting else using rc file intead of driver will be added later *) (* Someting else using rc file intead of driver will be added later *)
......
...@@ -39,9 +39,6 @@ let autoprovers = ref false ...@@ -39,9 +39,6 @@ let autoprovers = ref false
let autoplugins = ref false let autoplugins = ref false
let opt_version = ref false let opt_version = ref false
let opt_list_flags = ref false
let opt_debug_all = ref false
let save = ref true let save = ref true
let set_oref r = (fun s -> r := Some s) let set_oref r = (fun s -> r := Some s)
...@@ -49,9 +46,6 @@ let set_oref r = (fun s -> r := Some s) ...@@ -49,9 +46,6 @@ let set_oref r = (fun s -> r := Some s)
let plugins = Queue.create () let plugins = Queue.create ()
let add_plugin x = Queue.add x plugins let add_plugin x = Queue.add x plugins
let opt_debug = ref []
let add_opt_debug x = opt_debug := x::!opt_debug
let option_list = Arg.align [ let option_list = Arg.align [
(* "--libdir", Arg.String (set_oref libdir), *) (* "--libdir", Arg.String (set_oref libdir), *)
(* "<dir> set the lib directory ($WHY3LIB)"; *) (* "<dir> set the lib directory ($WHY3LIB)"; *)
...@@ -71,12 +65,9 @@ let option_list = Arg.align [ ...@@ -71,12 +65,9 @@ let option_list = Arg.align [
" Install a plugin to the actual libdir"; " Install a plugin to the actual libdir";
"--dont-save", Arg.Clear save, "--dont-save", Arg.Clear save,
" Do not modify the config file"; " Do not modify the config file";
"--list-debug-flags", Arg.Set opt_list_flags, Debug.Opt.desc_debug_list;
" List known debug flags"; Debug.Opt.desc_debug_all;
"--debug-all", Arg.Set opt_debug_all, Debug.Opt.desc_debug;
" Set all debug flags (except parse_only and type_only)";
"--debug", Arg.String add_opt_debug,
"<flag> Set a debug flag";
"--version", Arg.Set opt_version, "--version", Arg.Set opt_version,
" Print version information" " Print version information"
] ]
...@@ -131,21 +122,9 @@ let main () = ...@@ -131,21 +122,9 @@ let main () =
end; end;
(** Debug flag *) (** Debug flag *)
if !opt_debug_all then begin Debug.Opt.set_flags_selected ();
List.iter (fun (_,f,_) -> Debug.set_flag f) (Debug.list_flags ());
Debug.unset_flag Typing.debug_parse_only;
Debug.unset_flag Typing.debug_type_only
end;
List.iter (fun s -> Debug.set_flag (Debug.lookup_flag s)) !opt_debug; opt_list := Debug.Opt.option_list () || !opt_list;
if !opt_list_flags then begin
opt_list := true;
let print fmt (p,_,_) = fprintf fmt "%s" p in
printf "@[<hov 2>Known debug flags:@\n%a@]@."
(Pp.print_list Pp.newline print)
(List.sort Pervasives.compare (Debug.list_flags ()))
end;
if !opt_list then exit 0; if !opt_list then exit 0;
(** Main *) (** Main *)
......
...@@ -83,7 +83,10 @@ replace by the input file and '%o' which will be replaced by the output file."; ...@@ -83,7 +83,10 @@ replace by the input file and '%o' which will be replaced by the output file.";
"--coqdoc", "--coqdoc",
Arg.Unit (fun ()-> Arg.Unit (fun ()->
opt_pp := (".v",("coqdoc --no-index --html -o %o %i",".html"))::!opt_pp), opt_pp := (".v",("coqdoc --no-index --html -o %o %i",".html"))::!opt_pp),
" same as '--add_pp .v \"coqdoc --no-index --html -o %o %i\" .html'" " same as '--add_pp .v \"coqdoc --no-index --html -o %o %i\" .html'";
Debug.Opt.desc_debug_list;
Debug.Opt.desc_debug_all;
Debug.Opt.desc_debug;
] ]
...@@ -109,6 +112,17 @@ let () = ...@@ -109,6 +112,17 @@ let () =
(* List.iter (fun (in_,(cmd,out)) -> *) (* List.iter (fun (in_,(cmd,out)) -> *)
(* printf "in : %s, cmd : %s, out : %s@." in_ cmd out) !opt_pp *) (* printf "in : %s, cmd : %s, out : %s@." in_ cmd out) !opt_pp *)
let allow_obsolete = !allow_obsolete
let includes = List.rev !includes
open Session_ro
let env = read_config ~includes !opt_config
let () =
Debug.Opt.set_flags_selected ();
if Debug.Opt.option_list () then exit 0
let output_dir = let output_dir =
match !output_dir with match !output_dir with
| "" -> printf | "" -> printf
...@@ -122,16 +136,8 @@ let output_dir = ...@@ -122,16 +136,8 @@ let output_dir =
let edited_dst = Filename.concat output_dir "edited" let edited_dst = Filename.concat output_dir "edited"
let allow_obsolete = !allow_obsolete
let includes = List.rev !includes
open Session_ro
let env = read_config ~includes !opt_config
open Util open Util
type context = type context =
(string -> (string ->
(formatter -> Session_ro.session -> unit) -> Session_ro.session (formatter -> Session_ro.session -> unit) -> Session_ro.session
......
...@@ -62,6 +62,13 @@ let spec = Arg.align [ ...@@ -62,6 +62,13 @@ let spec = Arg.align [
("-longtable", ("-longtable",
Arg.Set opt_longtable, Arg.Set opt_longtable,
" produce latex statistics using longtable package") ; " produce latex statistics using longtable package") ;
Debug.Opt.desc_debug_list;
Debug.Opt.desc_shortcut "parse_only" "--parse-only" " Stop after parsing";
Debug.Opt.desc_shortcut
"type_only" "--type-only" " Stop after type checking";
Debug.Opt.desc_debug_all;
Debug.Opt.desc_debug;
] ]
let version_msg = Format.sprintf "Why3 replayer, version %s (build date: %s)" let version_msg = Format.sprintf "Why3 replayer, version %s (build date: %s)"
...@@ -91,6 +98,7 @@ let () = ...@@ -91,6 +98,7 @@ let () =
exit 1 exit 1
end end
let fname = match !file with let fname = match !file with
| None -> | None ->
Arg.usage spec usage_str; Arg.usage spec usage_str;
...@@ -107,6 +115,10 @@ let env = Env.create_env loadpath ...@@ -107,6 +115,10 @@ let env = Env.create_env loadpath
let () = Whyconf.load_plugins (Whyconf.get_main config) let () = Whyconf.load_plugins (Whyconf.get_main config)
let () =
Debug.Opt.set_flags_selected ();
if Debug.Opt.option_list () then exit 0
let usleep t = ignore (Unix.select [] [] [] t) let usleep t = ignore (Unix.select [] [] [] t)
......
...@@ -39,6 +39,9 @@ let spec = Arg.align [ ...@@ -39,6 +39,9 @@ let spec = Arg.align [
("-v", ("-v",
Arg.Set opt_version, Arg.Set opt_version,
" print version information") ; " print version information") ;
Debug.Opt.desc_debug_list;
Debug.Opt.desc_debug_all;
Debug.Opt.desc_debug;
] ]
let version_msg = Format.sprintf "Why3 statistics, version 0.1" let version_msg = Format.sprintf "Why3 statistics, version 0.1"
...@@ -61,6 +64,9 @@ let allow_obsolete = !allow_obsolete ...@@ -61,6 +64,9 @@ let allow_obsolete = !allow_obsolete
let env = read_config ~includes:!includes !opt_config let env = read_config ~includes:!includes !opt_config
let () =
Debug.Opt.set_flags_selected ();
if Debug.Opt.option_list () then exit 0
type proof_stats = type proof_stats =
{ mutable no_proof : Sstr.t; { mutable no_proof : Sstr.t;
......
...@@ -39,7 +39,6 @@ let opt_input = ref None ...@@ -39,7 +39,6 @@ let opt_input = ref None
let opt_theory = ref None let opt_theory = ref None
let opt_trans = ref [] let opt_trans = ref []
let opt_metas = ref [] let opt_metas = ref []
let opt_debug = ref []
let add_opt_file x = let add_opt_file x =
let tlist = Queue.create () in let tlist = Queue.create () in
...@@ -80,8 +79,6 @@ let add_opt_goal x = match !opt_theory with ...@@ -80,8 +79,6 @@ let add_opt_goal x = match !opt_theory with
let add_opt_trans x = opt_trans := x::!opt_trans let add_opt_trans x = opt_trans := x::!opt_trans
let add_opt_debug x = opt_debug := x::!opt_debug
let add_opt_meta meta = let add_opt_meta meta =
let meta_name, meta_arg = let meta_name, meta_arg =
let index = String.index meta '=' in let index = String.index meta '=' in
...@@ -112,7 +109,6 @@ let opt_list_printers = ref false ...@@ -112,7 +109,6 @@ let opt_list_printers = ref false
let opt_list_provers = ref false let opt_list_provers = ref false
let opt_list_formats = ref false let opt_list_formats = ref false
let opt_list_metas = ref false let opt_list_metas = ref false
let opt_list_flags = ref false
let opt_token_count = ref false let opt_token_count = ref false
let opt_parse_only = ref false let opt_parse_only = ref false
...@@ -192,18 +188,14 @@ let option_list = Arg.align [ ...@@ -192,18 +188,14 @@ let option_list = Arg.align [
" List known input formats"; " List known input formats";
"--list-metas", Arg.Set opt_list_metas, "--list-metas", Arg.Set opt_list_metas,
" List known metas"; " List known metas";
"--list-debug-flags", Arg.Set opt_list_flags, Debug.Opt.desc_debug_list;
" List known debug flags";
"--token-count", Arg.Set opt_token_count, "--token-count", Arg.Set opt_token_count,
" Only lexing, and give numbers of tokens in spec vs in program"; " Only lexing, and give numbers of tokens in spec vs in program";
"--parse-only", Arg.Set opt_parse_only, Debug.Opt.desc_shortcut "parse_only" "--parse-only" " Stop after parsing";
" Stop after parsing (same as --debug parse_only)"; Debug.Opt.desc_shortcut
"--type-only", Arg.Set opt_type_only, "type_only" "--type-only" " Stop after type checking";
" Stop after type checking (same as --debug type_only)"; Debug.Opt.desc_debug_all;
"--debug-all", Arg.Set opt_debug_all, Debug.Opt.desc_debug;
" Set all debug flags (except parse_only and type_only)";
"--debug", Arg.String add_opt_debug,
"<flag> Set a debug flag";
"--print-libdir", Arg.Set opt_print_libdir, "--print-libdir", Arg.Set opt_print_libdir,
" Print location of binary components (plugins, etc)"; " Print location of binary components (plugins, etc)";
"--print-datadir", Arg.Set opt_print_datadir, "--print-datadir", Arg.Set opt_print_datadir,
...@@ -227,23 +219,13 @@ let () = try ...@@ -227,23 +219,13 @@ let () = try
exit 0 exit 0
end; end;
(** Debug flag *)
if !opt_debug_all then begin
List.iter (fun (_,f,_) -> Debug.set_flag f) (Debug.list_flags ());
Debug.unset_flag Typing.debug_parse_only;
Debug.unset_flag Typing.debug_type_only
end;
List.iter (fun s -> Debug.set_flag (Debug.lookup_flag s)) !opt_debug;
if !opt_parse_only then Debug.set_flag Typing.debug_parse_only;
if !opt_type_only then Debug.set_flag Typing.debug_type_only;
(** Configuration *) (** Configuration *)
let config = read_config !opt_config in let config = read_config !opt_config in
let main = get_main config in let main = get_main config in
Whyconf.load_plugins main; Whyconf.load_plugins main;
Debug.Opt.set_flags_selected ();
(** listings*) (** listings*)
let opt_list = ref false in let opt_list = ref false in
...@@ -292,13 +274,7 @@ let () = try ...@@ -292,13 +274,7 @@ let () = try
printf "@[<hov 2>Known metas:@\n%a@]@\n@." printf "@[<hov 2>Known metas:@\n%a@]@\n@."
(Pp.print_list Pp.newline print) (List.sort cmp (Theory.list_metas ())) (Pp.print_list Pp.newline print) (List.sort cmp (Theory.list_metas ()))
end; end;
if !opt_list_flags then begin opt_list := Debug.Opt.option_list () || !opt_list;
opt_list := true;
let print fmt (p,_,_) = fprintf fmt "%s" p in
printf "@[<hov 2>Known debug flags:@\n%a@]@."
(Pp.print_list Pp.newline print)
(List.sort Pervasives.compare (Debug.list_flags ()))
end;
if !opt_list then exit 0; if !opt_list then exit 0;
if Queue.is_empty opt_queue then begin if Queue.is_empty opt_queue then begin
......
...@@ -101,8 +101,8 @@ let () = Exn_printer.register (fun fmt e -> match e with ...@@ -101,8 +101,8 @@ let () = Exn_printer.register (fun fmt e -> match e with
fprintf fmt "Unbound symbol '%a'" (print_list dot pp_print_string) sl fprintf fmt "Unbound symbol '%a'" (print_list dot pp_print_string) sl
| _ -> raise e) | _ -> raise e)
let debug_parse_only = Debug.register_flag "parse_only" let debug_parse_only = Debug.register_stop_flag "parse_only"
let debug_type_only = Debug.register_flag "type_only" let debug_type_only = Debug.register_stop_flag "type_only"
(** Environments *) (** Environments *)
......
...@@ -25,18 +25,26 @@ type flag = bool ref ...@@ -25,18 +25,26 @@ type flag = bool ref
let flag_table = Hashtbl.create 17 let flag_table = Hashtbl.create 17
let register_flag s = let gen_register_flag s stop =
try try
Hashtbl.find flag_table s fst (Hashtbl.find flag_table s)
with Not_found -> with Not_found ->
let flag = ref false in let flag = ref false in
Hashtbl.replace flag_table s flag; Hashtbl.replace flag_table s (flag,stop);
flag flag
let register_flag s = gen_register_flag s false
let register_stop_flag s = gen_register_flag s true
let lookup_flag s = let lookup_flag s =
try Hashtbl.find flag_table s with Not_found -> raise (UnknownFlag s) try fst (Hashtbl.find flag_table s) with Not_found -> raise (UnknownFlag s)
let list_flags () = Hashtbl.fold (fun s (v,_) acc -> (s,v,!v)::acc)
flag_table []
let list_flags () = Hashtbl.fold (fun s v acc -> (s,v,!v)::acc) flag_table [] let is_stop_flag s =
try snd (Hashtbl.find flag_table s) with Not_found -> raise (UnknownFlag s)
let test_flag s = !s let test_flag s = !s
let nottest_flag s = not !s let nottest_flag s = not !s
...@@ -64,3 +72,85 @@ let dprintf flag s = ...@@ -64,3 +72,85 @@ let dprintf flag s =
Format.fprintf !formatter s Format.fprintf !formatter s
end end
else Format.ifprintf !formatter s else Format.ifprintf !formatter s
(*** Options ****)
module Opt = struct
type spec = (Arg.key * Arg.spec * Arg.doc)
let desc_debug_list, option_list =
let opt_list_flags = ref false in
let desc =
"--list-debug-flags", Arg.Set opt_list_flags,
" List known debug flags" in
let list () =
if !opt_list_flags then begin
let list =
Hashtbl.fold (fun s (_,stop) acc -> (s,stop)::acc)
flag_table [] in
let print fmt (p,stop) =
if stop then Format.fprintf fmt "%s *" p
else Format.pp_print_string fmt p in
Format.printf "@[<hov 2>Known debug flags \
(* mark flags which change the behavior) :@\n%a@]@."
(Pp.print_list Pp.newline print)
(List.sort Pervasives.compare list);
end;
!opt_list_flags in
desc,list
let opt_list_flags = Queue.create ()
let add_flag s = Queue.add s opt_list_flags
let desc_shortcut flag option desc =
let set_flag () = add_flag flag in
let desc = Pp.sprintf "%s (same as --debug %s)" desc flag in
(option, Arg.Unit set_flag, desc)
let desc_debug =
("--debug", Arg.String add_flag, "<flag> Set a debug flag")
let opt_debug_all = ref false
let desc_debug_all =
let desc_debug =
Pp.sprintf
" Set all debug flags (except flags which change the behavior)" in
("--debug-all", Arg.Set opt_debug_all, desc_debug)
let set_flags_selected () =
if !opt_debug_all then
List.iter
(fun (s,f,_) -> if not (is_stop_flag s) then set_flag f)
(list_flags ());
Queue.iter (fun flag -> let flag = lookup_flag flag in set_flag flag)
opt_list_flags
end
(*
"--parse-only", Arg.Set opt_parse_only,
" Stop after parsing (same as --debug parse_only)";
"--type-only", Arg.Set opt_type_only,
" Stop after type checking (same as --debug type_only)";
"--debug-all", Arg.Set opt_debug_all,
" Set all debug flags (except parse_only and type_only)";
"--debug", Arg.String add_opt_debug,
"<flag> Set a debug flag";
(** Debug flag *)
if !opt_debug_all then begin
List.iter (fun (_,f,_) -> Debug.set_flag f) (Debug.list_flags ());
Debug.unset_flag Typing.debug_parse_only;
Debug.unset_flag Typing.debug_type_only
end;
List.iter (fun s -> Debug.set_flag (Debug.lookup_flag s)) !opt_debug;
if !opt_parse_only then Debug.set_flag Typing.debug_parse_only;
if !opt_type_only then Debug.set_flag Typing.debug_type_only;
*)
...@@ -24,10 +24,19 @@ val register_flag : string -> flag ...@@ -24,10 +24,19 @@ val register_flag : string -> flag
(** Register a new flag. If someone try to register two times the same (** Register a new flag. If someone try to register two times the same
flag the same one is used *) flag the same one is used *)
val register_stop_flag : string -> flag
(** Register a new stop flag. If someone try to register two times the same
flag the same one is used.
A stop flag should be used when a flag change the behavior of the program.
It is not setted by debug-all *)
val lookup_flag : string -> flag val lookup_flag : string -> flag
val list_flags : unit -> (string * flag * bool) list val list_flags : unit -> (string * flag * bool) list
(** List the known flags *) (** List the known flags *)
val is_stop_flag : string -> bool
(** test if the flag is a stop flag *)
(** Modify the state of a flag *) (** Modify the state of a flag *)
val set_flag : flag -> unit val set_flag : flag -> unit
val unset_flag : flag -> unit val unset_flag : flag -> unit
...@@ -49,3 +58,31 @@ val dprintf : flag -> ('a, Format.formatter, unit) format -> 'a ...@@ -49,3 +58,31 @@ val dprintf : flag -> ('a, Format.formatter, unit) format -> 'a
val stack_trace : flag val stack_trace : flag
(** stack_trace flag *) (** stack_trace flag *)