Commit a6fb3775 authored by Andrei Paskevich's avatar Andrei Paskevich
Browse files

rename Debug.register_flag into register_info_flag

and Debug.register_stop_flag into register_flag. While information
flags (selectable by --debug-all) are more common, it is safer to
treat a generic debug flag as behaviour-changing by default.
parent 3a8e66bf
......@@ -25,7 +25,7 @@ open Term
open Decl
open Theory
let debug = Debug.register_flag "encoding"
let debug = Debug.register_info_flag "encoding"
~desc:"About the encoding of polymorphism."
(* meta to tag the protected types *)
......
......@@ -27,28 +27,27 @@ type flag = bool ref
let flag_table = Hashtbl.create 17
let fst3 (flag,_,_) = flag
let snd3 (_,stop,_) = stop
let snd3 (_,info,_) = info
let thd3 (_,_,desc) = desc
let gen_register_flag (desc : Pp.formatted) s stop =
let gen_register_flag (desc : Pp.formatted) s info =
try
fst3 (Hashtbl.find flag_table s)
with Not_found ->
let flag = ref false in
Hashtbl.replace flag_table s (flag,stop,desc);
Hashtbl.replace flag_table s (flag,info,desc);
flag
let register_flag ~desc s = gen_register_flag desc s false
let register_info_flag ~desc s = gen_register_flag desc s true
let register_flag ~desc s = gen_register_flag desc s false
let register_stop_flag ~desc s = gen_register_flag desc s true
let list_flags () =
Hashtbl.fold (fun s (v,_,desc) acc -> (s,v,!v,desc)::acc) flag_table []
let lookup_flag s =
try fst3 (Hashtbl.find flag_table s) with Not_found -> raise (UnknownFlag s)
let list_flags () = Hashtbl.fold (fun s (v,_,desc) acc -> (s,v,!v,desc)::acc)
flag_table []
let is_stop_flag s =
let is_info_flag s =
try snd3 (Hashtbl.find flag_table s) with Not_found -> raise (UnknownFlag s)
let flag_desc s =
......@@ -65,12 +64,11 @@ let () = Exn_printer.register (fun fmt e -> match e with
| UnknownFlag s -> Format.fprintf fmt "unknown debug flag `%s'@." s
| _ -> raise e)
let stack_trace = register_flag "stack_trace"
~desc:"Don't@ catch@ the@ exception@ in@ order@ to@ get@ the stack trace."
let stack_trace = register_info_flag "stack_trace"
~desc:"Avoid@ catching@ exceptions@ in@ order@ to@ get@ the@ stack@ trace."
let timestamp = register_flag "timestamp"
~desc:"Add@ a time stamp@ in seconds@ before@ all@ the debug@ \
messages \"<...>\"."
let timestamp = register_info_flag "timestamp"
~desc:"Print@ a@ timestamp@ before@ debug@ messages."
let time_start = Unix.gettimeofday ()
......@@ -100,15 +98,15 @@ module Opt = struct
let list () =
if !opt_list_flags then begin
let list =
Hashtbl.fold (fun s (_,stop,desc) acc -> (s,stop,desc)::acc)
Hashtbl.fold (fun s (_,info,desc) acc -> (s,info,desc)::acc)
flag_table [] in
let print fmt (p,stop,desc) =
let print fmt (p,info,desc) =
Format.fprintf fmt "@[%s%s@\n @[%a@]@]"
p (if stop then "*" else "")
p (if info then "*" else "")
Pp.formatted desc
in
Format.printf "@[<hov 2>Known debug flags \
(`*' marks the flags that change Why3 behavior):@\n%a@]@."
(`*' marks the flags selected by --debug-all):@\n%a@]@."
(Pp.print_list Pp.newline print)
(List.sort Pervasives.compare list);
end;
......@@ -132,40 +130,14 @@ module Opt = struct
let desc_debug_all =
let desc_debug =
Pp.sprintf
" Set all debug flags (except flags which change the behavior)" in
" Set all debug flags that do not change Why3 behaviour" 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)
(fun (s,f,_,_) -> if not (is_info_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;
*)
......@@ -21,22 +21,21 @@
type flag
(** Flags used for debugging only part of Why3 *)
val register_flag : desc:Pp.formatted -> string -> flag
(** Register a new flag. It is allowed to register twice the same flag *)
val register_stop_flag : desc:Pp.formatted -> string -> flag
(** Register a new stop flag. It is allowed to register twice the same flag.
A stop flag should be used when the flag changes the behavior of Why3.
Such flags are not set by --debug-all. *)
val register_info_flag : desc:Pp.formatted -> string -> flag
(** Register a new info flag. It is allowed to register twice the same flag.
Info flags are set by --debug-all and must not change the behaviour. *)
val lookup_flag : string -> flag
val list_flags : unit -> (string * flag * bool * Pp.formatted) list
(** List the known flags *)
val is_stop_flag : string -> bool
(** test if the flag is a stop flag *)
val lookup_flag : string -> flag
(** get the flag *)
val is_info_flag : string -> bool
(** test if the flag is an info flag *)
val flag_desc : string -> Pp.formatted
(** get the description of the flag *)
......@@ -46,8 +45,8 @@ val set_flag : flag -> unit
val unset_flag : flag -> unit
val toggle_flag : flag -> unit
val test_flag : flag -> bool
(** Return the state of the flag *)
val test_flag : flag -> bool
val nottest_flag : flag -> bool
val set_debug_formatter : Format.formatter -> unit
......@@ -56,7 +55,6 @@ val set_debug_formatter : Format.formatter -> unit
val get_debug_formatter : unit -> Format.formatter
(** Get the formatter used when printing debug material *)
val dprintf : flag -> ('a, Format.formatter, unit) format -> 'a
(** Print only if the flag is set *)
......@@ -71,11 +69,11 @@ module Opt : sig
(** Option for printing the list of debug flags *)
val option_list : unit -> bool
(** Print the list of debug flag if requested (in this case return [true]).
(** Print the list of flags if requested (in this case return [true]).
You should run this function after the plugins have been loaded. *)
val desc_debug_all : spec
(** Option for setting all the debug flags except the stopping one *)
(** Option for setting all info flags *)
val desc_debug : spec
(** Option for specifying a debug flag to set *)
......@@ -85,7 +83,5 @@ module Opt : sig
val set_flags_selected : unit -> unit
(** Set the flags selected by debug_all, debug or a shortcut.
You should run this function after the plugins have been started.
*)
You should run this function after the plugins have been loaded. *)
end
......@@ -22,7 +22,7 @@ open Config
type plugin = string
let debug = Debug.register_flag "load_plugin"
let debug = Debug.register_info_flag "load_plugin"
~desc:"About plugins loading."
exception Plugin_Not_Found of plugin * string list
......
......@@ -23,7 +23,7 @@ open Util
open Mlw_module
open Mlw_typing
let debug = Debug.register_flag "print_modules"
let debug = Debug.register_info_flag "print_modules"
~desc:"Print@ program@ modules@ after@ typechecking."
let read_channel env path file c =
......
......@@ -32,11 +32,11 @@ open Mlw_ty.T
open Mlw_expr
open Mlw_decl
let debug_print_labels = Debug.register_flag "print_labels"
let debug_print_labels = Debug.register_info_flag "print_labels"
~desc:"Print@ labels@ of@ identifiers@ and@ expressions."
let debug_print_locs = Debug.register_flag "print_locs"
let debug_print_locs = Debug.register_info_flag "print_locs"
~desc:"Print@ locations@ of@ identifiers@ and@ expressions."
let debug_print_reg_types = Debug.register_flag "print_reg_types"
let debug_print_reg_types = Debug.register_info_flag "print_reg_types"
~desc:"Print@ types@ of@ regions@ (mutable@ fields)."
let iprinter =
......
......@@ -29,13 +29,13 @@ open Mlw_ty
open Mlw_ty.T
open Mlw_expr
let debug = Debug.register_flag "whyml_wp"
let debug = Debug.register_info_flag "whyml_wp"
~desc:"Print@ details@ of@ verification@ conditions@ generation."
let no_track = Debug.register_stop_flag "wp_no_track"
let no_track = Debug.register_flag "wp_no_track"
~desc:"Do@ not@ remove@ redundant@ type@ invariant@ conditions@ from@ VCs."
let no_eval = Debug.register_stop_flag "wp_no_eval"
let no_eval = Debug.register_flag "wp_no_eval"
~desc:"Do@ not@ simplify@ pattern@ matching@ on@ record@ datatypes@ in@ VCs."
(** Marks *)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment