@ -14,7 +14,6 @@ open! Utils
module F = Format
module F = Format
(* =============== START of module MyErr =============== *)
(* * type of printable elements *)
(* * type of printable elements *)
type print_type =
type print_type =
| PTatom
| PTatom
@ -64,35 +63,57 @@ let delayed_actions = ref []
(* * hook for the current printer of delayed print actions *)
(* * hook for the current printer of delayed print actions *)
let printer_hook = ref ( Obj . magic () )
let printer_hook = ref ( Obj . magic () )
(* * Current formatter for the out stream *)
let out_formatter , err_formatter =
let current_out_formatter = ref F . std_formatter
(* * Create a directory if it does not exist already. *)
(* This is the same as DB.create_dir, except for logging to stderr *)
(* * Current formatter for the err stream *)
let create_dir dir =
let current_err_formatter = ref F . err_formatter
try
if ( Unix . stat dir ) . Unix . st_kind != Unix . S_DIR then
(* * Get the current err formatter *)
failwithf " @.ERROR: file %s exists and is not a directory@. " dir
let get_err_formatter () = ! current_err_formatter
with Unix . Unix_error _ ->
try Unix . mkdir dir 0o700
(* * Set the current out formatter *)
with Unix . Unix_error _ ->
let set_out_formatter fmt =
let created_concurrently = (* check if another process created it meanwhile *)
current_out_formatter := fmt
( Unix . stat dir ) . Unix . st_kind = Unix . S_DIR in
if not created_concurrently then
(* * Set the current err formatter *)
failwithf " @.ERROR: cannot create directory %s@. " dir
let set_err_formatter fmt =
in
current_err_formatter := fmt
let open_output_file fname =
try
(* * Flush the current streams *)
let cout = open_out fname in
let flush_streams () =
let fmt = F . formatter_of_out_channel cout in
( fmt , cout )
with Sys_error _ ->
failwithf " @.ERROR: cannot open output file %s@. " fname
in
if Config . developer_mode then
if Config . developer_mode then
begin
let log_dir_name = " log " in
F . fprintf ! current_out_formatter " @? " ;
let analyzer_out_name = " analyzer_out " in
F . fprintf ! current_err_formatter " @? "
let analyzer_err_name = " analyzer_err " in
end
let log_dir = Filename . concat Config . results_dir log_dir_name in
create_dir log_dir ;
let analyzer_out_file =
if Config . out_file_cmdline = " " then Filename . concat log_dir analyzer_out_name
else Config . out_file_cmdline in
let analyzer_err_file =
if Config . err_file_cmdline = " " then Filename . concat log_dir analyzer_err_name
else Config . err_file_cmdline in
let out_fmt , out_chan = open_output_file analyzer_out_file in
let err_fmt , err_chan = open_output_file analyzer_err_file in
Pervasives . at_exit ( fun () ->
F . pp_print_flush out_fmt () ;
F . pp_print_flush err_fmt () ;
close_out out_chan ;
close_out err_chan
) ;
( out_fmt , err_fmt )
else
( F . std_formatter , F . err_formatter )
(* * extend the current print log *)
(* * extend the current print log *)
let add_print_action pact =
let add_print_action pact =
if Config . write_html then delayed_actions := pact :: ! delayed_actions
if Config . write_html then delayed_actions := pact :: ! delayed_actions
else if not Config . test then ! printer_hook ! current_out_formatter pact
else if not Config . test then ! printer_hook out_formatter pact
(* * reset the delayed print actions *)
(* * reset the delayed print actions *)
let reset_delayed_prints () =
let reset_delayed_prints () =
@ -117,11 +138,11 @@ let do_print_in_developer_mode fmt fmt_string =
(* * print to the current out stream ( note: only prints in developer mode ) *)
(* * print to the current out stream ( note: only prints in developer mode ) *)
let out fmt_string =
let out fmt_string =
do_print_in_developer_mode ! current_ out_formatter fmt_string
do_print_in_developer_mode out_formatter fmt_string
(* * print to the current err stream ( note: only prints in developer mode ) *)
(* * print to the current err stream ( note: only prints in developer mode ) *)
let err fmt_string =
let err fmt_string =
do_print_in_developer_mode ! current_ err_formatter fmt_string
do_print_in_developer_mode err_formatter fmt_string
(* * print immediately to standard error *)
(* * print immediately to standard error *)
let stderr fmt_string =
let stderr fmt_string =