|
|
@ -27,15 +27,33 @@ let make_trace_element lt_level lt_loc lt_description lt_node_tags =
|
|
|
|
(** Trace of locations *)
|
|
|
|
(** Trace of locations *)
|
|
|
|
type loc_trace = loc_trace_elem list
|
|
|
|
type loc_trace = loc_trace_elem list
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type node_id_key = {
|
|
|
|
|
|
|
|
node_id : int;
|
|
|
|
|
|
|
|
node_key : int
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
type err_key = {
|
|
|
|
|
|
|
|
err_kind : Exceptions.err_kind;
|
|
|
|
|
|
|
|
in_footprint : bool;
|
|
|
|
|
|
|
|
err_name : Localise.t;
|
|
|
|
|
|
|
|
err_desc : Localise.error_desc;
|
|
|
|
|
|
|
|
severity : string
|
|
|
|
|
|
|
|
}[@@deriving compare]
|
|
|
|
|
|
|
|
|
|
|
|
(** Data associated to a specific error *)
|
|
|
|
(** Data associated to a specific error *)
|
|
|
|
type err_data =
|
|
|
|
type err_data = {
|
|
|
|
(int * int) * int * Location.t * L.ml_loc option * loc_trace *
|
|
|
|
node_id_key : node_id_key;
|
|
|
|
Exceptions.err_class * Exceptions.visibility * string option (* linters def file *)
|
|
|
|
session : int;
|
|
|
|
|
|
|
|
loc : Location.t;
|
|
|
|
|
|
|
|
loc_in_ml_source : L.ml_loc option;
|
|
|
|
|
|
|
|
loc_trace : loc_trace;
|
|
|
|
|
|
|
|
err_class : Exceptions.err_class;
|
|
|
|
|
|
|
|
visibility : Exceptions.visibility;
|
|
|
|
|
|
|
|
linters_def_file : string option
|
|
|
|
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
let compare_err_data
|
|
|
|
let compare_err_data err_data1 err_data2 =
|
|
|
|
(_, _, loc1, _, _, _, _, _)
|
|
|
|
Location.compare err_data1.loc err_data2.loc
|
|
|
|
(_, _, loc2, _, _, _, _, _) =
|
|
|
|
|
|
|
|
Location.compare loc1 loc2
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
module ErrDataSet = (* set err_data with no repeated loc *)
|
|
|
|
module ErrDataSet = (* set err_data with no repeated loc *)
|
|
|
|
Caml.Set.Make(struct
|
|
|
|
Caml.Set.Make(struct
|
|
|
@ -46,21 +64,18 @@ module ErrDataSet = (* set err_data with no repeated loc *)
|
|
|
|
(** Hash table to implement error logs *)
|
|
|
|
(** Hash table to implement error logs *)
|
|
|
|
module ErrLogHash = struct
|
|
|
|
module ErrLogHash = struct
|
|
|
|
module Key = struct
|
|
|
|
module Key = struct
|
|
|
|
|
|
|
|
type t = err_key[@@deriving compare]
|
|
|
|
type t = Exceptions.err_kind * bool * Localise.t * Localise.error_desc * string
|
|
|
|
|
|
|
|
[@@deriving compare]
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(* NOTE: changing the hash function can change the order in which issues are reported. *)
|
|
|
|
(* NOTE: changing the hash function can change the order in which issues are reported. *)
|
|
|
|
let hash (ekind, in_footprint, err_name, desc, _) =
|
|
|
|
let hash key =
|
|
|
|
Hashtbl.hash (ekind, in_footprint, err_name, Localise.error_desc_hash desc)
|
|
|
|
Hashtbl.hash
|
|
|
|
|
|
|
|
(key.err_kind, key.in_footprint, key.err_name, Localise.error_desc_hash key.err_desc)
|
|
|
|
|
|
|
|
|
|
|
|
let equal
|
|
|
|
let equal key1 key2 =
|
|
|
|
(ekind1, in_footprint1, err_name1, desc1, _)
|
|
|
|
|
|
|
|
(ekind2, in_footprint2, err_name2, desc2, _) =
|
|
|
|
|
|
|
|
[%compare.equal : Exceptions.err_kind * bool * Localise.t]
|
|
|
|
[%compare.equal : Exceptions.err_kind * bool * Localise.t]
|
|
|
|
(ekind1, in_footprint1, err_name1)
|
|
|
|
(key1.err_kind, key1.in_footprint, key1.err_name)
|
|
|
|
(ekind2, in_footprint2, err_name2) &&
|
|
|
|
(key2.err_kind, key2.in_footprint, key2.err_name) &&
|
|
|
|
Localise.error_desc_equal desc1 desc2
|
|
|
|
Localise.error_desc_equal key1.err_desc key2.err_desc
|
|
|
|
|
|
|
|
|
|
|
|
end
|
|
|
|
end
|
|
|
|
include Hashtbl.Make (Key)
|
|
|
|
include Hashtbl.Make (Key)
|
|
|
@ -79,77 +94,69 @@ let compare x y =
|
|
|
|
let empty () = ErrLogHash.create 13
|
|
|
|
let empty () = ErrLogHash.create 13
|
|
|
|
|
|
|
|
|
|
|
|
(** type of the function to be passed to iter *)
|
|
|
|
(** type of the function to be passed to iter *)
|
|
|
|
type iter_fun =
|
|
|
|
type iter_fun = err_key -> err_data -> unit
|
|
|
|
(int * int) ->
|
|
|
|
|
|
|
|
Location.t ->
|
|
|
|
|
|
|
|
L.ml_loc option ->
|
|
|
|
|
|
|
|
Exceptions.err_kind ->
|
|
|
|
|
|
|
|
bool ->
|
|
|
|
|
|
|
|
Localise.t -> Localise.error_desc -> string ->
|
|
|
|
|
|
|
|
loc_trace ->
|
|
|
|
|
|
|
|
Exceptions.err_class ->
|
|
|
|
|
|
|
|
Exceptions.visibility ->
|
|
|
|
|
|
|
|
string option ->
|
|
|
|
|
|
|
|
unit
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(** Apply f to nodes and error names *)
|
|
|
|
(** Apply f to nodes and error names *)
|
|
|
|
let iter (f: iter_fun) (err_log: t) =
|
|
|
|
let iter (f: iter_fun) (err_log: t) =
|
|
|
|
ErrLogHash.iter (fun (ekind, in_footprint, err_name, desc, severity) set ->
|
|
|
|
ErrLogHash.iter (fun err_key set ->
|
|
|
|
ErrDataSet.iter
|
|
|
|
ErrDataSet.iter (fun err_data -> f err_key err_data) set)
|
|
|
|
(fun (node_id_key, _, loc, ml_loc_opt, ltr, eclass, visibility, linters_def_opt) ->
|
|
|
|
err_log
|
|
|
|
f
|
|
|
|
|
|
|
|
node_id_key loc ml_loc_opt ekind in_footprint err_name
|
|
|
|
let iter_filter (f: iter_fun) (err_log: t) =
|
|
|
|
desc severity ltr eclass visibility linters_def_opt)
|
|
|
|
ErrLogHash.iter (fun err_key set ->
|
|
|
|
set)
|
|
|
|
ErrDataSet.iter (fun err_data -> f err_key err_data) set)
|
|
|
|
err_log
|
|
|
|
err_log
|
|
|
|
|
|
|
|
|
|
|
|
(** Return the number of elements in the error log which satisfy [filter] *)
|
|
|
|
(** Return the number of elements in the error log which satisfy [filter] *)
|
|
|
|
let size filter (err_log: t) =
|
|
|
|
let size filter (err_log: t) =
|
|
|
|
let count = ref 0 in
|
|
|
|
let count = ref 0 in
|
|
|
|
ErrLogHash.iter (fun (ekind, in_footprint, _, _, _) eds ->
|
|
|
|
ErrLogHash.iter (fun key err_datas ->
|
|
|
|
if filter ekind in_footprint then count := !count + (ErrDataSet.cardinal eds)) err_log;
|
|
|
|
if filter key.err_kind key.in_footprint
|
|
|
|
|
|
|
|
then count := !count + (ErrDataSet.cardinal err_datas)) err_log;
|
|
|
|
!count
|
|
|
|
!count
|
|
|
|
|
|
|
|
|
|
|
|
(** Print errors from error log *)
|
|
|
|
(** Print errors from error log *)
|
|
|
|
let pp_errors fmt (errlog : t) =
|
|
|
|
let pp_errors fmt (errlog : t) =
|
|
|
|
let f (ekind, _, ename, _, _) _ =
|
|
|
|
let f key _ =
|
|
|
|
if Exceptions.equal_err_kind ekind Exceptions.Kerror then
|
|
|
|
if Exceptions.equal_err_kind key.err_kind Exceptions.Kerror then
|
|
|
|
F.fprintf fmt "%a@ " Localise.pp ename in
|
|
|
|
F.fprintf fmt "%a@ " Localise.pp key.err_name in
|
|
|
|
ErrLogHash.iter f errlog
|
|
|
|
ErrLogHash.iter f errlog
|
|
|
|
|
|
|
|
|
|
|
|
(** Print warnings from error log *)
|
|
|
|
(** Print warnings from error log *)
|
|
|
|
let pp_warnings fmt (errlog : t) =
|
|
|
|
let pp_warnings fmt (errlog : t) =
|
|
|
|
let f (ekind, _, ename, desc, _) _ =
|
|
|
|
let f key _ =
|
|
|
|
if Exceptions.equal_err_kind ekind Exceptions.Kwarning then
|
|
|
|
if Exceptions.equal_err_kind key.err_kind Exceptions.Kwarning then
|
|
|
|
F.fprintf fmt "%a %a@ " Localise.pp ename Localise.pp_error_desc desc in
|
|
|
|
F.fprintf fmt "%a %a@ " Localise.pp key.err_name Localise.pp_error_desc key.err_desc in
|
|
|
|
ErrLogHash.iter f errlog
|
|
|
|
ErrLogHash.iter f errlog
|
|
|
|
|
|
|
|
|
|
|
|
(** Print an error log in html format *)
|
|
|
|
(** Print an error log in html format *)
|
|
|
|
let pp_html source path_to_root fmt (errlog: t) =
|
|
|
|
let pp_html source path_to_root fmt (errlog: t) =
|
|
|
|
let pp_eds fmt eds =
|
|
|
|
let pp_eds fmt err_datas =
|
|
|
|
let pp_nodeid_session_loc
|
|
|
|
let pp_nodeid_session_loc
|
|
|
|
fmt ((nodeid, _), session, loc, _, _, _, _, _) =
|
|
|
|
fmt err_data =
|
|
|
|
Io_infer.Html.pp_session_link source path_to_root fmt (nodeid, session, loc.Location.line) in
|
|
|
|
Io_infer.Html.pp_session_link
|
|
|
|
ErrDataSet.iter (pp_nodeid_session_loc fmt) eds in
|
|
|
|
source path_to_root fmt
|
|
|
|
let f do_fp ek (ekind, infp, err_name, desc, _) eds =
|
|
|
|
(err_data.node_id_key.node_id, err_data.session, err_data.loc.Location.line) in
|
|
|
|
if Exceptions.equal_err_kind ekind ek && Bool.equal do_fp infp
|
|
|
|
ErrDataSet.iter (pp_nodeid_session_loc fmt) err_datas in
|
|
|
|
|
|
|
|
let pp_err_log do_fp ek key err_datas =
|
|
|
|
|
|
|
|
if Exceptions.equal_err_kind key.err_kind ek && Bool.equal do_fp key.in_footprint
|
|
|
|
then
|
|
|
|
then
|
|
|
|
F.fprintf fmt "<br>%a %a %a"
|
|
|
|
F.fprintf fmt "<br>%a %a %a"
|
|
|
|
Localise.pp err_name
|
|
|
|
Localise.pp key.err_name
|
|
|
|
Localise.pp_error_desc desc
|
|
|
|
Localise.pp_error_desc key.err_desc
|
|
|
|
pp_eds eds in
|
|
|
|
pp_eds err_datas in
|
|
|
|
F.fprintf fmt "%aERRORS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
|
|
|
|
F.fprintf fmt "%aERRORS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
|
|
|
|
ErrLogHash.iter (f true Exceptions.Kerror) errlog;
|
|
|
|
ErrLogHash.iter (pp_err_log true Exceptions.Kerror) errlog;
|
|
|
|
F.fprintf fmt "%aERRORS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
|
|
|
|
F.fprintf fmt "%aERRORS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
|
|
|
|
ErrLogHash.iter (f false Exceptions.Kerror) errlog;
|
|
|
|
ErrLogHash.iter (pp_err_log false Exceptions.Kerror) errlog;
|
|
|
|
F.fprintf fmt "%aWARNINGS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
|
|
|
|
F.fprintf fmt "%aWARNINGS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
|
|
|
|
ErrLogHash.iter (f true Exceptions.Kwarning) errlog;
|
|
|
|
ErrLogHash.iter (pp_err_log true Exceptions.Kwarning) errlog;
|
|
|
|
F.fprintf fmt "%aWARNINGS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
|
|
|
|
F.fprintf fmt "%aWARNINGS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
|
|
|
|
ErrLogHash.iter (f false Exceptions.Kwarning) errlog;
|
|
|
|
ErrLogHash.iter (pp_err_log false Exceptions.Kwarning) errlog;
|
|
|
|
F.fprintf fmt "%aINFOS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
|
|
|
|
F.fprintf fmt "%aINFOS DURING FOOTPRINT@\n" Io_infer.Html.pp_hline ();
|
|
|
|
ErrLogHash.iter (f true Exceptions.Kinfo) errlog;
|
|
|
|
ErrLogHash.iter (pp_err_log true Exceptions.Kinfo) errlog;
|
|
|
|
F.fprintf fmt "%aINFOS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
|
|
|
|
F.fprintf fmt "%aINFOS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline ();
|
|
|
|
ErrLogHash.iter (f false Exceptions.Kinfo) errlog
|
|
|
|
ErrLogHash.iter (pp_err_log false Exceptions.Kinfo) errlog
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(* I use string in case we want to display a different name to the user*)
|
|
|
|
(* I use string in case we want to display a different name to the user*)
|
|
|
@ -160,41 +167,39 @@ let severity_to_str severity = match severity with
|
|
|
|
|
|
|
|
|
|
|
|
(** Add an error description to the error log unless there is
|
|
|
|
(** Add an error description to the error log unless there is
|
|
|
|
one already at the same node + session; return true if added *)
|
|
|
|
one already at the same node + session; return true if added *)
|
|
|
|
let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataSet.t) : bool =
|
|
|
|
let add_issue tbl err_key (err_datas: ErrDataSet.t) : bool =
|
|
|
|
try
|
|
|
|
try
|
|
|
|
let current_eds = ErrLogHash.find tbl (ekind, in_footprint, err_name, desc, severity) in
|
|
|
|
let current_eds = ErrLogHash.find tbl err_key in
|
|
|
|
if ErrDataSet.subset eds current_eds then false
|
|
|
|
if ErrDataSet.subset err_datas current_eds then false
|
|
|
|
else
|
|
|
|
else
|
|
|
|
begin
|
|
|
|
begin
|
|
|
|
ErrLogHash.replace tbl
|
|
|
|
ErrLogHash.replace tbl err_key (ErrDataSet.union err_datas current_eds);
|
|
|
|
(ekind, in_footprint, err_name, desc, severity)
|
|
|
|
|
|
|
|
(ErrDataSet.union eds current_eds);
|
|
|
|
|
|
|
|
true
|
|
|
|
true
|
|
|
|
end
|
|
|
|
end
|
|
|
|
with Not_found ->
|
|
|
|
with Not_found ->
|
|
|
|
begin
|
|
|
|
begin
|
|
|
|
ErrLogHash.add tbl (ekind, in_footprint, err_name, desc, severity) eds;
|
|
|
|
ErrLogHash.add tbl err_key err_datas;
|
|
|
|
true
|
|
|
|
true
|
|
|
|
end
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
|
|
(** Update an old error log with a new one *)
|
|
|
|
(** Update an old error log with a new one *)
|
|
|
|
let update errlog_old errlog_new =
|
|
|
|
let update errlog_old errlog_new =
|
|
|
|
ErrLogHash.iter
|
|
|
|
ErrLogHash.iter
|
|
|
|
(fun (ekind, infp, s, desc, severity) l ->
|
|
|
|
(fun err_key l ->
|
|
|
|
ignore (add_issue errlog_old (ekind, infp, s, desc, severity) l)) errlog_new
|
|
|
|
ignore (add_issue errlog_old err_key l)) errlog_new
|
|
|
|
|
|
|
|
|
|
|
|
let log_issue _ekind err_log loc node_id_key session ltr ?linters_def_file exn =
|
|
|
|
let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_file exn =
|
|
|
|
let err_name, desc, ml_loc_opt, visibility, severity, force_kind, eclass =
|
|
|
|
let err_name, err_desc, ml_loc_opt, visibility, severity, force_kind, eclass =
|
|
|
|
Exceptions.recognize_exception exn in
|
|
|
|
Exceptions.recognize_exception exn in
|
|
|
|
let ekind = match force_kind with
|
|
|
|
let err_kind = match force_kind with
|
|
|
|
| Some ekind -> ekind
|
|
|
|
| Some err_kind -> err_kind
|
|
|
|
| _ -> _ekind in
|
|
|
|
| _ -> err_kind in
|
|
|
|
let hide_java_loc_zero = (* hide java errors at location zero unless in -developer_mode *)
|
|
|
|
let hide_java_loc_zero = (* hide java errors at location zero unless in -developer_mode *)
|
|
|
|
not Config.developer_mode &&
|
|
|
|
not Config.developer_mode &&
|
|
|
|
Config.curr_language_is Config.Java &&
|
|
|
|
Config.curr_language_is Config.Java &&
|
|
|
|
Int.equal loc.Location.line 0 in
|
|
|
|
Int.equal loc.Location.line 0 in
|
|
|
|
let hide_memory_error =
|
|
|
|
let hide_memory_error =
|
|
|
|
match Localise.error_desc_get_bucket desc with
|
|
|
|
match Localise.error_desc_get_bucket err_desc with
|
|
|
|
| Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin ->
|
|
|
|
| Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin ->
|
|
|
|
not Mleak_buckets.should_raise_leak_unknown_origin
|
|
|
|
not Mleak_buckets.should_raise_leak_unknown_origin
|
|
|
|
| _ -> false in
|
|
|
|
| _ -> false in
|
|
|
@ -204,26 +209,41 @@ let log_issue _ekind err_log loc node_id_key session ltr ?linters_def_file exn =
|
|
|
|
Exceptions.equal_visibility visibility Exceptions.Exn_developer) in
|
|
|
|
Exceptions.equal_visibility visibility Exceptions.Exn_developer) in
|
|
|
|
if log_it && not hide_java_loc_zero && not hide_memory_error then begin
|
|
|
|
if log_it && not hide_java_loc_zero && not hide_memory_error then begin
|
|
|
|
let added =
|
|
|
|
let added =
|
|
|
|
add_issue err_log
|
|
|
|
let node_id_key = {node_id; node_key} in
|
|
|
|
(ekind, !Config.footprint, err_name, desc, severity_to_str severity)
|
|
|
|
let err_data = {
|
|
|
|
(ErrDataSet.singleton
|
|
|
|
node_id_key;
|
|
|
|
(node_id_key, session, loc, ml_loc_opt, ltr, eclass, visibility,
|
|
|
|
session;
|
|
|
|
linters_def_file)) in
|
|
|
|
loc;
|
|
|
|
|
|
|
|
loc_in_ml_source = ml_loc_opt;
|
|
|
|
|
|
|
|
loc_trace = ltr;
|
|
|
|
|
|
|
|
err_class = eclass;
|
|
|
|
|
|
|
|
visibility;
|
|
|
|
|
|
|
|
linters_def_file;
|
|
|
|
|
|
|
|
} in
|
|
|
|
|
|
|
|
let err_key = {
|
|
|
|
|
|
|
|
err_kind;
|
|
|
|
|
|
|
|
in_footprint = !Config.footprint;
|
|
|
|
|
|
|
|
err_name;
|
|
|
|
|
|
|
|
err_desc;
|
|
|
|
|
|
|
|
severity = severity_to_str severity
|
|
|
|
|
|
|
|
} in
|
|
|
|
|
|
|
|
add_issue err_log err_key (ErrDataSet.singleton err_data) in
|
|
|
|
let should_print_now =
|
|
|
|
let should_print_now =
|
|
|
|
match exn with
|
|
|
|
match exn with
|
|
|
|
| Exceptions.Internal_error _ -> true
|
|
|
|
| Exceptions.Internal_error _ -> true
|
|
|
|
| _ -> added in
|
|
|
|
| _ -> added in
|
|
|
|
let print_now () =
|
|
|
|
let print_now () =
|
|
|
|
let ex_name, desc, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in
|
|
|
|
let ex_name, desc, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in
|
|
|
|
L.err "@\n%a@\n@?" (Exceptions.pp_err node_id_key loc ekind ex_name desc ml_loc_opt) ();
|
|
|
|
L.err "@\n%a@\n@?"
|
|
|
|
if _ekind <> Exceptions.Kerror then begin
|
|
|
|
(Exceptions.pp_err ~node_key loc err_kind ex_name desc ml_loc_opt) ();
|
|
|
|
|
|
|
|
if err_kind <> Exceptions.Kerror then begin
|
|
|
|
let warn_str =
|
|
|
|
let warn_str =
|
|
|
|
let pp fmt =
|
|
|
|
let pp fmt =
|
|
|
|
Format.fprintf fmt "%s %a"
|
|
|
|
Format.fprintf fmt "%s %a"
|
|
|
|
(Localise.to_issue_id err_name)
|
|
|
|
(Localise.to_issue_id err_name)
|
|
|
|
Localise.pp_error_desc desc in
|
|
|
|
Localise.pp_error_desc desc in
|
|
|
|
F.asprintf "%t" pp in
|
|
|
|
F.asprintf "%t" pp in
|
|
|
|
let d = match ekind with
|
|
|
|
let d = match err_kind with
|
|
|
|
| Exceptions.Kerror -> L.d_error
|
|
|
|
| Exceptions.Kerror -> L.d_error
|
|
|
|
| Exceptions.Kwarning -> L.d_warning
|
|
|
|
| Exceptions.Kwarning -> L.d_warning
|
|
|
|
| Exceptions.Kinfo | Exceptions.Kadvice -> L.d_info in
|
|
|
|
| Exceptions.Kinfo | Exceptions.Kadvice -> L.d_info in
|
|
|
@ -251,9 +271,9 @@ module Err_table = struct
|
|
|
|
let err_string = Localise.to_issue_id err_name in
|
|
|
|
let err_string = Localise.to_issue_id err_name in
|
|
|
|
let count = try String.Map.find_exn !err_name_map err_string with Not_found -> 0 in
|
|
|
|
let count = try String.Map.find_exn !err_name_map err_string with Not_found -> 0 in
|
|
|
|
err_name_map := String.Map.add ~key:err_string ~data:(count + n) !err_name_map in
|
|
|
|
err_name_map := String.Map.add ~key:err_string ~data:(count + n) !err_name_map in
|
|
|
|
let count (ekind', in_footprint, err_name, _, _) eds =
|
|
|
|
let count key err_datas =
|
|
|
|
if Exceptions.equal_err_kind ekind ekind' && in_footprint
|
|
|
|
if Exceptions.equal_err_kind ekind key.err_kind && key.in_footprint
|
|
|
|
then count_err err_name (ErrDataSet.cardinal eds) in
|
|
|
|
then count_err key.err_name (ErrDataSet.cardinal err_datas) in
|
|
|
|
ErrLogHash.iter count err_table;
|
|
|
|
ErrLogHash.iter count err_table;
|
|
|
|
let pp ~key:err_string ~data:count = F.fprintf fmt " %s:%d" err_string count in
|
|
|
|
let pp ~key:err_string ~data:count = F.fprintf fmt " %s:%d" err_string count in
|
|
|
|
String.Map.iteri ~f:pp !err_name_map
|
|
|
|
String.Map.iteri ~f:pp !err_name_map
|
|
|
@ -271,8 +291,8 @@ module Err_table = struct
|
|
|
|
let map_warn_re = ref LocMap.empty in
|
|
|
|
let map_warn_re = ref LocMap.empty in
|
|
|
|
let map_info = ref LocMap.empty in
|
|
|
|
let map_info = ref LocMap.empty in
|
|
|
|
let map_advice = ref LocMap.empty in
|
|
|
|
let map_advice = ref LocMap.empty in
|
|
|
|
let add_err nslm (ekind , in_fp, err_name, desc, _) =
|
|
|
|
let add_err nslm key =
|
|
|
|
let map = match in_fp, ekind with
|
|
|
|
let map = match key.in_footprint, key.err_kind with
|
|
|
|
| true, Exceptions.Kerror -> map_err_fp
|
|
|
|
| true, Exceptions.Kerror -> map_err_fp
|
|
|
|
| false, Exceptions.Kerror -> map_err_re
|
|
|
|
| false, Exceptions.Kerror -> map_err_re
|
|
|
|
| true, Exceptions.Kwarning -> map_warn_fp
|
|
|
|
| true, Exceptions.Kwarning -> map_warn_fp
|
|
|
@ -281,16 +301,18 @@ module Err_table = struct
|
|
|
|
| _, Exceptions.Kadvice -> map_advice in
|
|
|
|
| _, Exceptions.Kadvice -> map_advice in
|
|
|
|
try
|
|
|
|
try
|
|
|
|
let err_list = LocMap.find nslm !map in
|
|
|
|
let err_list = LocMap.find nslm !map in
|
|
|
|
map := LocMap.add nslm ((err_name, desc) :: err_list) !map
|
|
|
|
map := LocMap.add nslm ((key.err_name, key.err_desc) :: err_list) !map
|
|
|
|
with Not_found ->
|
|
|
|
with Not_found ->
|
|
|
|
map := LocMap.add nslm [(err_name, desc)] !map in
|
|
|
|
map := LocMap.add nslm [(key.err_name, key.err_desc)] !map in
|
|
|
|
let f err_name eds =
|
|
|
|
let f err_name eds =
|
|
|
|
ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
|
|
|
|
ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
|
|
|
|
ErrLogHash.iter f err_table;
|
|
|
|
ErrLogHash.iter f err_table;
|
|
|
|
|
|
|
|
|
|
|
|
let pp ekind (nodeidkey, _, loc, ml_loc_opt, _, _, _, _) fmt err_names =
|
|
|
|
let pp ekind err_data fmt err_names =
|
|
|
|
List.iter ~f:(fun (err_name, desc) ->
|
|
|
|
List.iter ~f:(fun (err_name, desc) ->
|
|
|
|
Exceptions.pp_err nodeidkey loc ekind err_name desc ml_loc_opt fmt ()) err_names in
|
|
|
|
Exceptions.pp_err
|
|
|
|
|
|
|
|
~node_key:err_data.node_id_key.node_key err_data.loc ekind err_name desc
|
|
|
|
|
|
|
|
err_data.loc_in_ml_source fmt ()) err_names in
|
|
|
|
F.fprintf fmt "@.Detailed errors during footprint phase:@.";
|
|
|
|
F.fprintf fmt "@.Detailed errors during footprint phase:@.";
|
|
|
|
LocMap.iter (fun nslm err_names ->
|
|
|
|
LocMap.iter (fun nslm err_names ->
|
|
|
|
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp;
|
|
|
|
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp;
|
|
|
|