Commit a6fb3775 authored by Andrei Paskevich's avatar Andrei Paskevich

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
......@@ -83,9 +83,9 @@ open Format
type callback = tool_id -> prob_id ->
task -> int -> proof_attempt_status -> unit
let debug_call = Debug.register_flag "call"
let debug_call = Debug.register_info_flag "call"
~desc:"Show when call to provers are done"
let debug = Debug.register_flag "bench_core"
let debug = Debug.register_info_flag "bench_core"
~desc:"About the scheduling"
......
......@@ -28,7 +28,7 @@ module BenchUtil = Bench.BenchUtil
let load_driver = Env.Wenv.memoize 2 (fun env ->
memo_string 10 (Driver.load_driver env))
let debug = Debug.register_flag "benchdb"
let debug = Debug.register_info_flag "benchdb"
~desc:"About the communication from the database"
type path =
......
......@@ -29,7 +29,7 @@ open Trans
module B = Bench
module C = Call_provers
let debug = Debug.register_flag "main"
let debug = Debug.register_info_flag "main"
~desc:"About initialization of the bench"
let usage_msg = sprintf
......
......@@ -168,7 +168,7 @@ let forget_all printer =
(** Sanitizers *)
let unsanitizable = Debug.register_flag "unsanitizable"
let unsanitizable = Debug.register_info_flag "unsanitizable"
~desc:"About@ the@ sanitazing@ during@ the@ pretty-printing."
let char_to_alpha c = match c with
......
......@@ -28,9 +28,9 @@ open Decl
open Theory
open Task
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 iprinter,aprinter,tprinter,pprinter =
......
......@@ -27,7 +27,7 @@ open Decl
open Theory
open Task
let debug = Debug.register_flag "transform"
let debug = Debug.register_info_flag "transform"
~desc:"About@ which@ transformations@ are@ applied@ and@ with@ which@ \
arguments, ie metas."
......
......@@ -55,7 +55,7 @@ open Whyconf
module Wc = Whyconf
open Rc
let debug = Debug.register_flag "autodetect"
let debug = Debug.register_info_flag "autodetect"
~desc:"About@ the@ autodetection@ of@ external@ provers."
(* auto-detection of provers *)
......
......@@ -122,7 +122,7 @@ let rec grep out l = match l with
with Not_found -> grep out l end
let debug = Debug.register_flag "call_prover"
let debug = Debug.register_info_flag "call_prover"
~desc:"About@ external@ prover@ calls@ and@ results."
type post_prover_call = unit -> prover_result
......
......@@ -24,7 +24,7 @@ open Util
open Rc
open Whyconf
let debug = Debug.register_flag "ide_info"
let debug = Debug.register_info_flag "ide_info"
~desc:"About why3ide."
let () = Debug.set_flag debug
......
......@@ -20,7 +20,7 @@
open Ident
let flag = Debug.register_flag "glob"
let flag = Debug.register_info_flag "glob"
~desc:"TODO, used in parsing?"
let () = Debug.unset_flag flag (* make sure it is unset by default *)
......
......@@ -77,9 +77,9 @@ let () = Exn_printer.register (fun fmt e -> match e with
fprintf fmt "Unbound symbol '%a'" (print_list dot pp_print_string) sl
| _ -> raise e)
let debug_parse_only = Debug.register_stop_flag "parse_only"
let debug_parse_only = Debug.register_flag "parse_only"
~desc:"Stop@ after@ the@ parsing."
let debug_type_only = Debug.register_stop_flag "type_only"
let debug_type_only = Debug.register_flag "type_only"
~desc:"Stop@ after@ the@ typing."
(** Environments *)
......
......@@ -29,7 +29,7 @@ open Typing
open Ptree
open Pgm_module
let debug_extraction = Debug.register_stop_flag "extraction"
let debug_extraction = Debug.register_flag "extraction"
~desc:"for internal use"
exception ClashModule of string
......
......@@ -27,9 +27,9 @@ open Pretty
open Pgm_types.T
open Pgm_ttree
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."
(* pretty-printing (for debugging) *)
......
......@@ -34,7 +34,7 @@ open Pgm_types
open Pgm_types.T
open Pgm_module
let debug = Debug.register_flag "whyml_typing"
let debug = Debug.register_info_flag "whyml_typing"
~desc:"Print@ details@ of@ program@ typechecking."
let is_debug () = Debug.test_flag debug
......
......@@ -33,7 +33,7 @@ open Pgm_types
open Pgm_types.T
open Pgm_module
let debug = Debug.register_flag "whyml_wp"
let debug = Debug.register_info_flag "whyml_wp"
~desc:"Print@ details@ of@ verification@ condition@ generation."
(* mutable fields *)
......
......@@ -28,7 +28,7 @@ module PHprover = Whyconf.Hprover
module C = Whyconf
module Tc = Termcode
let debug = Debug.register_flag "session"
let debug = Debug.register_info_flag "session"
~desc:"About the why3 session creation, reading and writing."
(** {2 Type definitions} *)
......
......@@ -22,7 +22,7 @@ open Format
open Session
open Debug
let debug = register_flag "scheduler"
let debug = register_info_flag "scheduler"
~desc:"About@ the@ session@ scheduler@ which@ schedules@ the@ application@ \
of@ transformtions@ or@ the@ call@ of@ provers."
......
......@@ -31,7 +31,7 @@ let print_shape = Format.pp_print_string
let string_of_shape x = x
let shape_of_string x = x
let debug = Debug.register_flag "session_pairing"
let debug = Debug.register_info_flag "session_pairing"
~desc:"About@ the@ way@ old@ goals@ recorded@ in@ sessions@ are@ paired@ \
with@ new@ goals@ obtained@ after@ modifications@ of@ the@ source@ \
file."
......
......@@ -54,7 +54,7 @@
let parse_error s = raise (Parse_error s)
open Debug
let debug = register_flag "xml"
let debug = register_info_flag "xml"
~desc:"About the xml parsing."
}
......
......@@ -81,10 +81,10 @@ module Mvsl = Stdlib.Map.Make(VsList)
module Svsl = Mvsl.Set
(**************************** PRINTING ***************************************)
let debug = Debug.register_flag "induction"
let debug = Debug.register_info_flag "induction"
~desc:"About@ the@ transformation@ of@ the@ goal@ using@ induction."
let debug_verbose = Debug.register_flag "induction-verbose"
let debug_verbose = Debug.register_info_flag "induction-verbose"
~desc:"Same@ as@ induction, but@ print@ also@ the@ variables, the@ \
heuristics@ and@ the lexicographic@ order@ used."
......
......@@ -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