Silence deprecation warnings

Summary:
Use In_channel and Out_channel operations instead of those in Pervasives.  Don't
use physical equality on values that aren't heap-allocated since it doesn't help
the compiler generate faster code and the semantics is unspecified.  Also use
phys_equal for physical equality.

Reviewed By: sblackshear

Differential Revision: D4232459

fbshipit-source-id: 36fcfa8
master
Josh Berdine 8 years ago committed by Facebook Github Bot
parent 2e66dcfac4
commit 7834c95bc8

@ -386,7 +386,7 @@ let pp_graph_dotty get_specs (g: t) fmt => {
| exn when SymOp.exn_not_failure exn => (-1) | exn when SymOp.exn_not_failure exn => (-1)
}; };
let get_color (n, _) => let get_color (n, _) =>
if (num_specs n !== 0) { if (num_specs n != 0) {
"green" "green"
} else { } else {
"red" "red"
@ -434,5 +434,5 @@ let save_call_graph_dotty source get_specs (g: t) => {
let outc = open_out (DB.filename_to_string fname_dot); let outc = open_out (DB.filename_to_string fname_dot);
let fmt = F.formatter_of_out_channel outc; let fmt = F.formatter_of_out_channel outc;
pp_graph_dotty get_specs g fmt; pp_graph_dotty get_specs g fmt;
close_out outc Out_channel.close outc
}; };

@ -145,7 +145,7 @@ let pp_vpath pe fmt vpath => {
fun fun
| Some de => pp fmt de | Some de => pp fmt de
| None => (); | None => ();
if (pe.Pp.kind === Pp.HTML) { if (pe.Pp.kind == Pp.HTML) {
F.fprintf F.fprintf
fmt fmt
" %a{vpath: %a}%a" " %a{vpath: %a}%a"

@ -109,14 +109,14 @@ let size filter (err_log: t) =
(** 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 (ekind, _, ename, _, _) _ =
if ekind == Exceptions.Kerror then if ekind = Exceptions.Kerror then
F.fprintf fmt "%a@ " Localise.pp ename in F.fprintf fmt "%a@ " Localise.pp ename 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 (ekind, _, ename, desc, _) _ =
if ekind == Exceptions.Kwarning then if ekind = Exceptions.Kwarning then
F.fprintf fmt "%a %a@ " Localise.pp ename Localise.pp_error_desc desc in F.fprintf fmt "%a %a@ " Localise.pp ename Localise.pp_error_desc desc in
ErrLogHash.iter f errlog ErrLogHash.iter f errlog
@ -128,7 +128,7 @@ let pp_html source path_to_root fmt (errlog: t) =
Io_infer.Html.pp_session_link source path_to_root fmt (nodeid, session, loc.Location.line) in Io_infer.Html.pp_session_link source path_to_root fmt (nodeid, session, loc.Location.line) in
ErrDataSet.iter (pp_nodeid_session_loc fmt) eds in ErrDataSet.iter (pp_nodeid_session_loc fmt) eds in
let f do_fp ek (ekind, infp, err_name, desc, _) eds = let f do_fp ek (ekind, infp, err_name, desc, _) eds =
if ekind == ek && do_fp == infp if ekind = ek && do_fp = infp
then then
F.fprintf fmt "<br>%a %a %a" F.fprintf fmt "<br>%a %a %a"
Localise.pp err_name Localise.pp err_name
@ -195,8 +195,8 @@ let log_issue _ekind err_log loc node_id_key session ltr exn =
not Mleak_buckets.should_raise_leak_unknown_origin not Mleak_buckets.should_raise_leak_unknown_origin
| _ -> false in | _ -> false in
let log_it = let log_it =
visibility == Exceptions.Exn_user || visibility = Exceptions.Exn_user ||
(Config.developer_mode && visibility == Exceptions.Exn_developer) in (Config.developer_mode && 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 add_issue err_log

@ -355,4 +355,4 @@ let pp_err (_, node_key) loc ekind ex_name desc ml_loc_opt fmt () =
(** Return true if the exception is not serious and should be handled in timeout mode *) (** Return true if the exception is not serious and should be handled in timeout mode *)
let handle_exception exn = let handle_exception exn =
let _, _, _, visibility, _, _, _ = recognize_exception exn in let _, _, _, visibility, _, _, _ = recognize_exception exn in
visibility == Exn_user || visibility == Exn_developer visibility = Exn_user || visibility = Exn_developer

@ -78,7 +78,7 @@ let path_ident_stamp = (-3);
type t = {kind: kind, name: Name.t, stamp: int} [@@deriving compare]; type t = {kind: kind, name: Name.t, stamp: int} [@@deriving compare];
/* most unlikely first */ /* most unlikely first */
let equal i1 i2 => i1.stamp === i2.stamp && i1.kind === i2.kind && equal_name i1.name i2.name; let equal i1 i2 => i1.stamp == i2.stamp && i1.kind == i2.kind && equal_name i1.name i2.name;
/** {2 Set for identifiers} */ /** {2 Set for identifiers} */
@ -254,9 +254,9 @@ let name_return = Mangled.from_string "return";
/** Return the standard name for the given kind */ /** Return the standard name for the given kind */
let standard_name kind => let standard_name kind =>
if (kind === KNormal || kind === KNone) { if (kind == KNormal || kind == KNone) {
Name.Normal Name.Normal
} else if (kind === KFootprint) { } else if (kind == KFootprint) {
Name.Footprint Name.Footprint
} else { } else {
Name.Primed Name.Primed
@ -297,20 +297,20 @@ let create_footprint name stamp => create_with_stamp KFootprint name stamp;
/** Get a name of an identifier */ /** Get a name of an identifier */
let get_name id => id.name; let get_name id => id.name;
let is_primed (id: t) => id.kind === KPrimed; let is_primed (id: t) => id.kind == KPrimed;
let is_normal (id: t) => id.kind === KNormal || id.kind === KNone; let is_normal (id: t) => id.kind == KNormal || id.kind == KNone;
let is_footprint (id: t) => id.kind === KFootprint; let is_footprint (id: t) => id.kind == KFootprint;
let is_none (id: t) => id.kind == KNone; let is_none (id: t) => id.kind == KNone;
let is_path (id: t) => id.kind === KNormal && id.stamp == path_ident_stamp; let is_path (id: t) => id.kind == KNormal && id.stamp == path_ident_stamp;
let make_unprimed id => let make_unprimed id =>
if (id.kind != KPrimed) { if (id.kind != KPrimed) {
assert false assert false
} else if (id.kind === KNone) { } else if (id.kind == KNone) {
{...id, kind: KNone} {...id, kind: KNone}
} else { } else {
{...id, kind: KNormal} {...id, kind: KNormal}
@ -333,14 +333,14 @@ let create_path pathstring =>
/** Convert an identifier to a string. */ /** Convert an identifier to a string. */
let to_string id => let to_string id =>
if (id.kind === KNone) { if (id.kind == KNone) {
"_" "_"
} else { } else {
let base_name = name_to_string id.name; let base_name = name_to_string id.name;
let prefix = let prefix =
if (id.kind === KFootprint) { if (id.kind == KFootprint) {
"@" "@"
} else if (id.kind === KNormal) { } else if (id.kind == KNormal) {
"" ""
} else { } else {
"_" "_"

@ -229,7 +229,7 @@ let _line_tag tags tag loc =
let line_str = string_of_int loc.Location.line in let line_str = string_of_int loc.Location.line in
Tags.add tags tag line_str; Tags.add tags tag line_str;
let s = "line " ^ line_str in let s = "line " ^ line_str in
if (loc.Location.col != -1) then if (loc.Location.col <> -1) then
let col_str = string_of_int loc.Location.col in let col_str = string_of_int loc.Location.col in
s ^ ", column " ^ col_str s ^ ", column " ^ col_str
else s else s

@ -37,7 +37,7 @@ let pp f (loc: t) => F.fprintf f "[line %d]" loc.line;
let to_string loc => { let to_string loc => {
let s = string_of_int loc.line; let s = string_of_int loc.line;
if (loc.col !== (-1)) { if (loc.col != (-1)) {
s ^ ":" ^ string_of_int loc.col s ^ ":" ^ string_of_int loc.col
} else { } else {
s s

@ -325,7 +325,7 @@ let compute_distance_to_exit_node pdesc => {
next_nodes := node.preds @ !next_nodes next_nodes := node.preds @ !next_nodes
}; };
IList.iter do_node nodes; IList.iter do_node nodes;
if (!next_nodes !== []) { if (!next_nodes != []) {
mark_distance (dist + 1) !next_nodes mark_distance (dist + 1) !next_nodes
} }
}; };

@ -204,7 +204,7 @@ type hpred = hpred0 inst;
/** Comparsion between heap predicates. Reverse natural order, and order first by anchor exp. */ /** Comparsion between heap predicates. Reverse natural order, and order first by anchor exp. */
let compare_hpred inst::inst=false hpred1 hpred2 => let compare_hpred inst::inst=false hpred1 hpred2 =>
if (hpred1 === hpred2) { if (phys_equal hpred1 hpred2) {
0 0
} else { } else {
switch (hpred1, hpred2) { switch (hpred1, hpred2) {
@ -311,18 +311,18 @@ let module HpredSet = Caml.Set.Make {
/** Begin change color if using diff printing, return updated printenv and change status */ /** Begin change color if using diff printing, return updated printenv and change status */
let color_pre_wrapper pe f x => let color_pre_wrapper pe f x =>
if (Config.print_using_diff && pe.Pp.kind !== Pp.TEXT) { if (Config.print_using_diff && pe.Pp.kind != Pp.TEXT) {
let color = pe.Pp.cmap_norm (Obj.repr x); let color = pe.Pp.cmap_norm (Obj.repr x);
if (color !== pe.Pp.color) { if (color != pe.Pp.color) {
( (
if (pe.Pp.kind === Pp.HTML) { if (pe.Pp.kind == Pp.HTML) {
Io_infer.Html.pp_start_color Io_infer.Html.pp_start_color
} else { } else {
Latex.pp_color Latex.pp_color
} }
) )
f color; f color;
if (color === Pp.Red) { if (color == Pp.Red) {
( (
Pp.{ Pp.{
/** All subexpressiona red */ /** All subexpressiona red */
@ -346,7 +346,7 @@ let color_pre_wrapper pe f x =>
/** Close color annotation if changed */ /** Close color annotation if changed */
let color_post_wrapper changed pe f => let color_post_wrapper changed pe f =>
if changed { if changed {
if (pe.Pp.kind === Pp.HTML) { if (pe.Pp.kind == Pp.HTML) {
Io_infer.Html.pp_end_color f () Io_infer.Html.pp_end_color f ()
} else { } else {
Latex.pp_color f pe.Pp.color Latex.pp_color f pe.Pp.color
@ -719,8 +719,8 @@ let module Predicates: {
which are then visited as well. which are then visited as well.
Can be applied only once, as it destroys the todo list */ Can be applied only once, as it destroys the todo list */
let iter (env: env) f f_dll => let iter (env: env) f f_dll =>
while (env.todo !== [] || env.todo_dll !== []) { while (env.todo != [] || env.todo_dll != []) {
if (env.todo !== []) { if (env.todo != []) {
let hpara = IList.hd env.todo; let hpara = IList.hd env.todo;
let () = env.todo = IList.tl env.todo; let () = env.todo = IList.tl env.todo;
let (n, emitted) = HparaHash.find env.hash hpara; let (n, emitted) = HparaHash.find env.hash hpara;
@ -728,7 +728,7 @@ let module Predicates: {
f n hpara f n hpara
} }
} else if ( } else if (
env.todo_dll !== [] env.todo_dll != []
) { ) {
let hpara_dll = IList.hd env.todo_dll; let hpara_dll = IList.hd env.todo_dll;
let () = env.todo_dll = IList.tl env.todo_dll; let () = env.todo_dll = IList.tl env.todo_dll;
@ -916,7 +916,7 @@ let update_inst inst_old inst_new => {
/** describe an instrumentation with a string */ /** describe an instrumentation with a string */
let pp_inst pe f inst => { let pp_inst pe f inst => {
let str = inst_to_string inst; let str = inst_to_string inst;
if (pe.Pp.kind === Pp.HTML) { if (pe.Pp.kind == Pp.HTML) {
F.fprintf f " %a%s%a" Io_infer.Html.pp_start_color Pp.Orange str Io_infer.Html.pp_end_color () F.fprintf f " %a%s%a" Io_infer.Html.pp_start_color Pp.Orange str Io_infer.Html.pp_end_color ()
} else { } else {
F.fprintf f "%s%s%s" (Binop.str pe Lt) str (Binop.str pe Gt) F.fprintf f "%s%s%s" (Binop.str pe Lt) str (Binop.str pe Gt)
@ -1833,7 +1833,7 @@ let rec exp_sub_ids (f: Ident.t => Exp.t) exp =>
| Lvar _ => exp | Lvar _ => exp
| Exn e => | Exn e =>
let e' = exp_sub_ids f e; let e' = exp_sub_ids f e;
if (e' === e) { if (phys_equal e' e) {
exp exp
} else { } else {
Exp.Exn e' Exp.Exn e'
@ -1844,7 +1844,7 @@ let rec exp_sub_ids (f: Ident.t => Exp.t) exp =>
( (
fun ((e, pvar, typ) as captured) => { fun ((e, pvar, typ) as captured) => {
let e' = exp_sub_ids f e; let e' = exp_sub_ids f e;
if (e' === e) { if (phys_equal e' e) {
captured captured
} else { } else {
(e', pvar, typ) (e', pvar, typ)
@ -1852,7 +1852,7 @@ let rec exp_sub_ids (f: Ident.t => Exp.t) exp =>
} }
) )
c.captured_vars; c.captured_vars;
if (captured_vars === c.captured_vars) { if (phys_equal captured_vars c.captured_vars) {
exp exp
} else { } else {
Exp.Closure {...c, captured_vars} Exp.Closure {...c, captured_vars}
@ -1860,14 +1860,14 @@ let rec exp_sub_ids (f: Ident.t => Exp.t) exp =>
| Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _ | Cptr_to_fld _) => exp | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _ | Cptr_to_fld _) => exp
| Cast t e => | Cast t e =>
let e' = exp_sub_ids f e; let e' = exp_sub_ids f e;
if (e' === e) { if (phys_equal e' e) {
exp exp
} else { } else {
Exp.Cast t e' Exp.Cast t e'
} }
| UnOp op e typ_opt => | UnOp op e typ_opt =>
let e' = exp_sub_ids f e; let e' = exp_sub_ids f e;
if (e' === e) { if (phys_equal e' e) {
exp exp
} else { } else {
Exp.UnOp op e' typ_opt Exp.UnOp op e' typ_opt
@ -1875,14 +1875,14 @@ let rec exp_sub_ids (f: Ident.t => Exp.t) exp =>
| BinOp op e1 e2 => | BinOp op e1 e2 =>
let e1' = exp_sub_ids f e1; let e1' = exp_sub_ids f e1;
let e2' = exp_sub_ids f e2; let e2' = exp_sub_ids f e2;
if (e1' === e1 && e2' === e2) { if (phys_equal e1' e1 && phys_equal e2' e2) {
exp exp
} else { } else {
Exp.BinOp op e1' e2' Exp.BinOp op e1' e2'
} }
| Lfield e fld typ => | Lfield e fld typ =>
let e' = exp_sub_ids f e; let e' = exp_sub_ids f e;
if (e' === e) { if (phys_equal e' e) {
exp exp
} else { } else {
Exp.Lfield e' fld typ Exp.Lfield e' fld typ
@ -1890,7 +1890,7 @@ let rec exp_sub_ids (f: Ident.t => Exp.t) exp =>
| Lindex e1 e2 => | Lindex e1 e2 =>
let e1' = exp_sub_ids f e1; let e1' = exp_sub_ids f e1;
let e2' = exp_sub_ids f e2; let e2' = exp_sub_ids f e2;
if (e1' === e1 && e2' === e2) { if (phys_equal e1' e1 && phys_equal e2' e2) {
exp exp
} else { } else {
Exp.Lindex e1' e2' Exp.Lindex e1' e2'
@ -1899,7 +1899,7 @@ let rec exp_sub_ids (f: Ident.t => Exp.t) exp =>
switch l_opt { switch l_opt {
| Some l => | Some l =>
let l' = exp_sub_ids f l; let l' = exp_sub_ids f l;
if (l' === l) { if (phys_equal l' l) {
exp exp
} else { } else {
Exp.Sizeof t (Some l') s Exp.Sizeof t (Some l') s
@ -1938,7 +1938,7 @@ let instr_sub_ids sub_id_binders::sub_id_binders (f: Ident.t => Exp.t) instr =>
id id
}; };
let rhs_exp' = exp_sub_ids f rhs_exp; let rhs_exp' = exp_sub_ids f rhs_exp;
if (id' === id && rhs_exp' === rhs_exp) { if (phys_equal id' id && phys_equal rhs_exp' rhs_exp) {
instr instr
} else { } else {
Load id' rhs_exp' typ loc Load id' rhs_exp' typ loc
@ -1946,7 +1946,7 @@ let instr_sub_ids sub_id_binders::sub_id_binders (f: Ident.t => Exp.t) instr =>
| Store lhs_exp typ rhs_exp loc => | Store lhs_exp typ rhs_exp loc =>
let lhs_exp' = exp_sub_ids f lhs_exp; let lhs_exp' = exp_sub_ids f lhs_exp;
let rhs_exp' = exp_sub_ids f rhs_exp; let rhs_exp' = exp_sub_ids f rhs_exp;
if (lhs_exp' === lhs_exp && rhs_exp' === rhs_exp) { if (phys_equal lhs_exp' lhs_exp && phys_equal rhs_exp' rhs_exp) {
instr instr
} else { } else {
Store lhs_exp' typ rhs_exp' loc Store lhs_exp' typ rhs_exp' loc
@ -1969,7 +1969,7 @@ let instr_sub_ids sub_id_binders::sub_id_binders (f: Ident.t => Exp.t) instr =>
( (
fun ((actual, typ) as actual_pair) => { fun ((actual, typ) as actual_pair) => {
let actual' = exp_sub_ids f actual; let actual' = exp_sub_ids f actual;
if (actual' === actual) { if (phys_equal actual' actual) {
actual_pair actual_pair
} else { } else {
(actual', typ) (actual', typ)
@ -1977,21 +1977,21 @@ let instr_sub_ids sub_id_binders::sub_id_binders (f: Ident.t => Exp.t) instr =>
} }
) )
actuals; actuals;
if (ret_id' === ret_id && fun_exp' === fun_exp && actuals' === actuals) { if (phys_equal ret_id' ret_id && phys_equal fun_exp' fun_exp && phys_equal actuals' actuals) {
instr instr
} else { } else {
Call ret_id' fun_exp' actuals' call_flags loc Call ret_id' fun_exp' actuals' call_flags loc
} }
| Prune exp loc true_branch if_kind => | Prune exp loc true_branch if_kind =>
let exp' = exp_sub_ids f exp; let exp' = exp_sub_ids f exp;
if (exp' === exp) { if (phys_equal exp' exp) {
instr instr
} else { } else {
Prune exp' loc true_branch if_kind Prune exp' loc true_branch if_kind
} }
| Remove_temps ids loc => | Remove_temps ids loc =>
let ids' = IList.map_changed sub_id ids; let ids' = IList.map_changed sub_id ids;
if (ids' === ids) { if (phys_equal ids' ids) {
instr instr
} else { } else {
Remove_temps ids' loc Remove_temps ids' loc

@ -137,7 +137,7 @@ let store_to_file (filename: DB.filename) (tenv: t) => {
let out_channel = open_out debug_filename; let out_channel = open_out debug_filename;
let fmt = Format.formatter_of_out_channel out_channel; let fmt = Format.formatter_of_out_channel out_channel;
Format.fprintf fmt "%a" pp tenv; Format.fprintf fmt "%a" pp tenv;
close_out out_channel Out_channel.close out_channel
} }
}; };

@ -33,7 +33,7 @@ OCAMLBUILD_OPTIONS = \
-cflags -principal \ -cflags -principal \
-cflags -strict-formats \ -cflags -strict-formats \
-cflags -strict-sequence \ -cflags -strict-sequence \
-cflags -w,$(OCAML_FATAL_WARNINGS)-3-4-9-32-40-41-42-45-48 \ -cflags -w,$(OCAML_FATAL_WARNINGS)-4-9-32-40-41-42-45-48 \
-tag-line "<*{clang/clang_ast_*,backend/jsonbug_*,checkers/stacktree_*}>: warn(-27-32-35-39)" \ -tag-line "<*{clang/clang_ast_*,backend/jsonbug_*,checkers/stacktree_*}>: warn(-27-32-35-39)" \
-tag-line "<*/{,*/}*.{ml,re}{,i}>: package(ppx_compare)" \ -tag-line "<*/{,*/}*.{ml,re}{,i}>: package(ppx_compare)" \
-tag thread \ -tag thread \

@ -48,7 +48,7 @@ let add_or_replace_check_changed tenv check_attribute_change prop atom0 =
atom in atom in
let pi = prop.Prop.pi in let pi = prop.Prop.pi in
let pi' = IList.map_changed atom_map pi in let pi' = IList.map_changed atom_map pi in
if pi == pi' if phys_equal pi pi'
then Prop.prop_atom_and tenv prop natom then Prop.prop_atom_and tenv prop natom
else Prop.normalize tenv (Prop.set prop ~pi:pi') else Prop.normalize tenv (Prop.set prop ~pi:pi')
| _ -> | _ ->
@ -127,7 +127,7 @@ let has_dangling_uninit tenv prop exp =
let filter_atoms tenv ~f prop = let filter_atoms tenv ~f prop =
let pi0 = prop.Prop.pi in let pi0 = prop.Prop.pi in
let pi1 = IList.filter_changed f pi0 in let pi1 = IList.filter_changed f pi0 in
if pi1 == pi0 then if phys_equal pi1 pi0 then
prop prop
else else
Prop.normalize tenv (Prop.set prop ~pi:pi1) Prop.normalize tenv (Prop.set prop ~pi:pi1)
@ -166,7 +166,7 @@ let map_resource tenv prop f =
| atom -> atom in | atom -> atom in
let pi0 = prop.Prop.pi in let pi0 = prop.Prop.pi in
let pi1 = IList.map_changed atom_map pi0 in let pi1 = IList.map_changed atom_map pi0 in
if pi1 == pi0 then if phys_equal pi1 pi0 then
prop prop
else else
Prop.normalize tenv (Prop.set prop ~pi:pi1) Prop.normalize tenv (Prop.set prop ~pi:pi1)

@ -1403,7 +1403,7 @@ let pp_summary_and_issues formats_by_report_kind => {
let iterate_summaries = AnalysisResults.get_summary_iterator (); let iterate_summaries = AnalysisResults.get_summary_iterator ();
let top_proc = TopProcedures.create (); let top_proc = TopProcedures.create ();
let top_proc_set = TopProcedures.top_set top_proc; let top_proc_set = TopProcedures.top_set top_proc;
if (!compute_top_procedures && (Config.procs_csv !== None || Config.procs_xml !== None)) { if (!compute_top_procedures && (Config.procs_csv != None || Config.procs_xml != None)) {
iterate_summaries (TopProcedures.process_summary top_proc) iterate_summaries (TopProcedures.process_summary top_proc)
}; };
iterate_summaries (process_summary filters formats_by_report_kind linereader stats top_proc_set); iterate_summaries (process_summary filters formats_by_report_kind linereader stats top_proc_set);

@ -148,7 +148,7 @@ let register_report_at_exit file =
Unix.mkdir_p (Filename.dirname file); Unix.mkdir_p (Filename.dirname file);
let stats_oc = open_out file in let stats_oc = open_out file in
Yojson.Basic.pretty_to_channel stats_oc json_stats ; Yojson.Basic.pretty_to_channel stats_oc json_stats ;
close_out stats_oc Out_channel.close stats_oc
with exc -> with exc ->
Format.eprintf "Info: failed to write stats to %s@\n%s@\n%s@\n%s@." Format.eprintf "Info: failed to write stats to %s@\n%s@\n%s@\n%s@."
file (Exn.to_string exc) (Yojson.Basic.pretty_to_string json_stats) file (Exn.to_string exc) (Yojson.Basic.pretty_to_string json_stats)

@ -218,7 +218,7 @@ end = struct
(** Replace the current hpred *) (** Replace the current hpred *)
let replace_hpred ((sigma, hpred, _) : t) hpred' = let replace_hpred ((sigma, hpred, _) : t) hpred' =
IList.map (fun hpred'' -> if hpred''== hpred then hpred' else hpred'') sigma IList.map (fun hpred'' -> if phys_equal hpred'' hpred then hpred' else hpred'') sigma
(** Replace the strexp at the given offset in the given hpred *) (** Replace the strexp at the given offset in the given hpred *)
let hpred_replace_strexp tenv footprint_part hpred syn_offs update = let hpred_replace_strexp tenv footprint_part hpred syn_offs update =
@ -441,7 +441,7 @@ let keep_only_indices tenv
| Sil.Earray (len, esel, inst) -> | Sil.Earray (len, esel, inst) ->
let esel', esel_leftover' = let esel', esel_leftover' =
IList.partition (fun (e, _) -> IList.exists (Exp.equal e) indices) esel in IList.partition (fun (e, _) -> IList.exists (Exp.equal e) indices) esel in
if esel_leftover' == [] then (sigma, false) if esel_leftover' = [] then (sigma, false)
else begin else begin
let se' = Sil.Earray (len, esel', inst) in let se' = Sil.Earray (len, esel', inst) in
let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in
@ -479,7 +479,7 @@ let strexp_do_abstract tenv
if Config.trace_absarray then (L.d_str "keep "; d_keys keep_keys; L.d_ln ()); if Config.trace_absarray then (L.d_str "keep "; d_keys keep_keys; L.d_ln ());
keep p path keep_keys in keep p path keep_keys in
let p3, changed3 = let p3, changed3 =
if blur_keys == [] then (p2, false) if blur_keys = [] then (p2, false)
else begin else begin
if Config.trace_absarray then (L.d_str "blur "; d_keys blur_keys; L.d_ln ()); if Config.trace_absarray then (L.d_str "blur "; d_keys blur_keys; L.d_ln ());
blur p2 path blur_keys blur p2 path blur_keys
@ -493,7 +493,7 @@ let strexp_do_abstract tenv
let keep_ksel, remove_ksel = IList.partition should_keep ksel in let keep_ksel, remove_ksel = IList.partition should_keep ksel in
let keep_keys, _, _ = let keep_keys, _, _ =
IList.map fst keep_ksel, IList.map fst remove_ksel, IList.map fst ksel in IList.map fst keep_ksel, IList.map fst remove_ksel, IList.map fst ksel in
let keep_keys' = if keep_keys == [] then default_keys else keep_keys in let keep_keys' = if keep_keys = [] then default_keys else keep_keys in
abstract keep_keys' keep_keys' in abstract keep_keys' keep_keys' in
let do_array_footprint esel = let do_array_footprint esel =
(* array case footprint: keep only the last index, and blur it *) (* array case footprint: keep only the last index, and blur it *)
@ -512,7 +512,7 @@ let strexp_do_abstract tenv
let filter_abstract d_keys should_keep abstract ksel default_keys = let filter_abstract d_keys should_keep abstract ksel default_keys =
let keep_ksel = IList.filter should_keep ksel in let keep_ksel = IList.filter should_keep ksel in
let keep_keys = IList.map fst keep_ksel in let keep_keys = IList.map fst keep_ksel in
let keep_keys' = if keep_keys == [] then default_keys else keep_keys in let keep_keys' = if keep_keys = [] then default_keys else keep_keys in
if Config.trace_absarray then (L.d_str "keep "; d_keys keep_keys'; L.d_ln ()); if Config.trace_absarray then (L.d_str "keep "; d_keys keep_keys'; L.d_ln ());
abstract keep_keys' [] in abstract keep_keys' [] in
let do_array_reexecution esel = let do_array_reexecution esel =

@ -71,4 +71,4 @@ let create_cluster_makefile (clusters: Cluster.t list) (fname: string) =
pp_prolog fmt clusters; pp_prolog fmt clusters;
IList.iteri do_cluster clusters; IList.iteri do_cluster clusters;
pp_epilog fmt () ; pp_epilog fmt () ;
close_out outc Out_channel.close outc

@ -73,7 +73,7 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir =
Utils.directory_fold Utils.directory_fold
(fun summaries path -> (fun summaries path ->
(* check if the file is a JSON file under the crashcontext dir *) (* check if the file is a JSON file under the crashcontext dir *)
if (Sys.is_directory path) != `Yes && Filename.check_suffix path "json" && if (Sys.is_directory path) <> `Yes && Filename.check_suffix path "json" &&
String.is_suffix ~suffix:"crashcontext" (Filename.dirname path) String.is_suffix ~suffix:"crashcontext" (Filename.dirname path)
then path :: summaries then path :: summaries
else summaries) else summaries)

@ -1383,7 +1383,7 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma)
'todo' describes the start point. *) 'todo' describes the start point. *)
let cut_sigma side todo (target: Prop.sigma) (other: Prop.sigma) = let cut_sigma side todo (target: Prop.sigma) (other: Prop.sigma) =
let list_is_empty l = if l != [] then (L.d_strln "failure reason 61"; raise IList.Fail) in let list_is_empty l = if l <> [] then (L.d_strln "failure reason 61"; raise IList.Fail) in
let x = Todo.take () in let x = Todo.take () in
Todo.push todo; Todo.push todo;
let res = let res =

@ -237,7 +237,7 @@ let color_to_str (c : Pp.color) =
let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list) = let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list) =
let exp_color hpred (exp : Exp.t) = let exp_color hpred (exp : Exp.t) =
if pe.Pp.cmap_norm (Obj.repr hpred) == Pp.Red then Pp.Red if pe.Pp.cmap_norm (Obj.repr hpred) = Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp) in else pe.Pp.cmap_norm (Obj.repr exp) in
let get_rhs_predicate (hpred, lambda) = let get_rhs_predicate (hpred, lambda) =
let n = !dotty_state_count in let n = !dotty_state_count in
@ -322,7 +322,7 @@ let rec dotty_mk_node pe sigma =
| [] -> [] | [] -> []
| (hpred, lambda) :: sigma' -> | (hpred, lambda) :: sigma' ->
let exp_color (exp : Exp.t) = let exp_color (exp : Exp.t) =
if pe.Pp.cmap_norm (Obj.repr hpred) == Pp.Red then Pp.Red if pe.Pp.cmap_norm (Obj.repr hpred) = Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp) in else pe.Pp.cmap_norm (Obj.repr exp) in
do_hpred_lambda exp_color (hpred, lambda) @ dotty_mk_node pe sigma' do_hpred_lambda exp_color (hpred, lambda) @ dotty_mk_node pe sigma'
@ -517,7 +517,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
try get_coordinate_id (IList.hd (IList.filter (is_source_node_of_exp e) nodes_e)) try get_coordinate_id (IList.hd (IList.filter (is_source_node_of_exp e) nodes_e))
with exn when SymOp.exn_not_failure exn -> assert false in with exn when SymOp.exn_not_failure exn -> assert false in
(* we need to exclude the address node from the sorce of fields. no fields should start from there*) (* we need to exclude the address node from the sorce of fields. no fields should start from there*)
let nl'= IList.filter (fun id -> address_struct_id != id) nl in let nl'= IList.filter (fun id -> address_struct_id <> id) nl in
let links_from_fields = IList.flatten (IList.map ff nl') in let links_from_fields = IList.flatten (IList.map ff nl') in
let lnk_from_address_struct = if !print_full_prop then let lnk_from_address_struct = if !print_full_prop then
let trg_label = strip_special_chars (Exp.to_string e) in let trg_label = strip_special_chars (Exp.to_string e) in
@ -632,7 +632,7 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
let remove_links_from ln = IList.filter (fun n' -> not (IList.mem Pervasives.(=) n' ln)) !tmp_links in let remove_links_from ln = IList.filter (fun n' -> not (IList.mem Pervasives.(=) n' ln)) !tmp_links in
let remove_node n ns = let remove_node n ns =
IList.filter (fun n' -> match n' with IList.filter (fun n' -> match n' with
| Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n) | Dotpointsto _ -> (get_coordinate_id n') <> (get_coordinate_id n)
| _ -> true | _ -> true
) ns in ) ns in
let rec boxes_pointed_by n lns = let rec boxes_pointed_by n lns =
@ -910,7 +910,7 @@ let dotty_prop_to_dotty_file fname prop cycle =
let out_dot = open_out fname in let out_dot = open_out fname in
let fmt_dot = Format.formatter_of_out_channel out_dot in let fmt_dot = Format.formatter_of_out_channel out_dot in
pp_dotty_prop fmt_dot (prop, cycle); pp_dotty_prop fmt_dot (prop, cycle);
close_out out_dot Out_channel.close out_dot
with exn when SymOp.exn_not_failure exn -> with exn when SymOp.exn_not_failure exn ->
() ()
@ -927,7 +927,7 @@ let pp_proplist_parsed2dotty_file filename plist =
let outc = open_out filename in let outc = open_out filename in
let fmt = F.formatter_of_out_channel outc in let fmt = F.formatter_of_out_channel outc in
F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist; F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist;
close_out outc Out_channel.close outc
with exn when SymOp.exn_not_failure exn -> with exn when SymOp.exn_not_failure exn ->
() ()
@ -1027,7 +1027,7 @@ let write_icfg_dotty_to_file source cfg fname =
F.fprintf fmt "/* @@%s */@\ndigraph iCFG {@\n" "generated"; F.fprintf fmt "/* @@%s */@\ndigraph iCFG {@\n" "generated";
print_icfg source fmt cfg; print_icfg source fmt cfg;
F.fprintf fmt "}\n"; F.fprintf fmt "}\n";
close_out chan Out_channel.close chan
let print_icfg_dotty source cfg = let print_icfg_dotty source cfg =
let fname = let fname =
@ -1063,7 +1063,7 @@ let pp_speclist_to_file (filename : DB.filename) spec_list =
let outc = open_out (DB.filename_to_string (DB.filename_add_suffix filename ".dot")) in let outc = open_out (DB.filename_to_string (DB.filename_add_suffix filename ".dot")) in
let fmt = F.formatter_of_out_channel outc in let fmt = F.formatter_of_out_channel outc in
let () = F.fprintf fmt "#### Dotty version: ####@\n%a@\n@\n" (pp_speclist_dotty) spec_list in let () = F.fprintf fmt "#### Dotty version: ####@\n%a@\n@\n" (pp_speclist_dotty) spec_list in
close_out outc; Out_channel.close outc;
Config.pp_simple := pp_simple_saved Config.pp_simple := pp_simple_saved
let pp_speclist_dotty_file (filename : DB.filename) spec_list = let pp_speclist_dotty_file (filename : DB.filename) spec_list =
@ -1277,7 +1277,7 @@ let prop_to_set_of_visual_heaps prop =
let result = ref [] in let result = ref [] in
working_list := [(!global_node_counter, prop.Prop.sigma)]; working_list := [(!global_node_counter, prop.Prop.sigma)];
incr global_node_counter; incr global_node_counter;
while (!working_list!=[]) do while (!working_list <> []) do
set_dangling_nodes:=[]; set_dangling_nodes:=[];
let (n, h) = IList.hd !working_list in let (n, h) = IList.hd !working_list in
working_list:= IList.tl !working_list; working_list:= IList.tl !working_list;

@ -142,7 +142,7 @@ let find_normal_variable_funcall
Some (fun_exp, IList.map fst args, loc, call_flags) Some (fun_exp, IList.map fst args, loc, call_flags)
| _ -> None in | _ -> None in
let res = find_in_node_or_preds node find_declaration in let res = find_in_node_or_preds node find_declaration in
if verbose && res == None if verbose && res = None
then then
(L.d_str (L.d_str
("find_normal_variable_funcall could not find " ^ ("find_normal_variable_funcall could not find " ^
@ -251,7 +251,7 @@ let rec _find_normal_variable_load tenv (seen : Exp.Set.t) node id : DExp.t opti
Some (DExp.Dpvar pvar) Some (DExp.Dpvar pvar)
| _ -> None in | _ -> None in
let res = find_in_node_or_preds node find_declaration in let res = find_in_node_or_preds node find_declaration in
if verbose && res == None if verbose && res = None
then then
(L.d_str (L.d_str
("find_normal_variable_load could not find " ^ ("find_normal_variable_load could not find " ^
@ -560,7 +560,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
| Some _ -> (* we know it has been allocated *) | Some _ -> (* we know it has been allocated *)
Exceptions.Exn_user, bucket Exceptions.Exn_user, bucket
| None -> | None ->
if leak_from_list_abstraction hpred prop && value_str != None if leak_from_list_abstraction hpred prop && value_str <> None
then then
(* we don't know it's been allocated, (* we don't know it's been allocated,
but it's coming from list abstraction and we have a name *) but it's coming from list abstraction and we have a name *)

@ -142,7 +142,7 @@ let get_source exe_env pname =
(get_file_data exe_env pname) (get_file_data exe_env pname)
let file_data_to_tenv file_data = let file_data_to_tenv file_data =
if file_data.tenv == None if file_data.tenv = None
then file_data.tenv <- Tenv.load_from_file file_data.tenv_file; then file_data.tenv <- Tenv.load_from_file file_data.tenv_file;
file_data.tenv file_data.tenv

@ -282,7 +282,7 @@ let analyze = function
(* In Java and Javac modes, analysis is invoked from capture. *) (* In Java and Javac modes, analysis is invoked from capture. *)
() ()
| Analyze | Ant | Buck | ClangCompilationDatabase | Gradle | Genrule | Make | Mvn | Ndk | Xcode -> | Analyze | Ant | Buck | ClangCompilationDatabase | Gradle | Genrule | Make | Mvn | Ndk | Xcode ->
if (Sys.file_exists Config.(results_dir // captured_dir_name)) != `Yes then ( if (Sys.file_exists Config.(results_dir // captured_dir_name)) <> `Yes then (
L.stderr "There was nothing to analyze, exiting" ; L.stderr "There was nothing to analyze, exiting" ;
Config.print_usage_exit () Config.print_usage_exit ()
); );
@ -309,7 +309,7 @@ let () =
if Config.developer_mode then Printexc.record_backtrace true ; if Config.developer_mode then Printexc.record_backtrace true ;
let build_cmd = IList.rev Config.rest in let build_cmd = IList.rev Config.rest in
let build_mode = match build_cmd with path :: _ -> build_mode_of_string path | [] -> Analyze in let build_mode = match build_cmd with path :: _ -> build_mode_of_string path | [] -> Analyze in
if build_mode != Analyze && not Config.buck && not Config.reactive_mode then if build_mode <> Analyze && not Config.buck && not Config.reactive_mode then
remove_results_dir () ; remove_results_dir () ;
create_results_dir () ; create_results_dir () ;
(* re-set log files, as default files were in results_dir removed above *) (* re-set log files, as default files were in results_dir removed above *)

@ -87,7 +87,7 @@ module FileContainsStringMatcher = struct
try try
let file_in = open_in (SourceFile.to_abs_path source_file) in let file_in = open_in (SourceFile.to_abs_path source_file) in
let pattern_found = file_contains regexp file_in in let pattern_found = file_contains regexp file_in in
close_in file_in; In_channel.close file_in;
source_map := SourceFile.Map.add source_file pattern_found !source_map; source_map := SourceFile.Map.add source_file pattern_found !source_map;
pattern_found pattern_found
with Sys_error _ -> false with Sys_error _ -> false

@ -530,7 +530,7 @@ let forward_tabulate tenv pdesc wl source =
let log_string proc_name = let log_string proc_name =
let summary = Specs.get_summary_unsafe "forward_tabulate" proc_name in let summary = Specs.get_summary_unsafe "forward_tabulate" proc_name in
let phase_string = let phase_string =
if Specs.get_phase summary == Specs.FOOTPRINT then "FP" else "RE" in if Specs.get_phase summary = Specs.FOOTPRINT then "FP" else "RE" in
let timestamp = Specs.get_timestamp summary in let timestamp = Specs.get_timestamp summary in
F.sprintf "[%s:%d] %s" phase_string timestamp (Procname.to_string proc_name) in F.sprintf "[%s:%d] %s" phase_string timestamp (Procname.to_string proc_name) in
L.d_strln ("**** " ^ (log_string pname) ^ " " ^ L.d_strln ("**** " ^ (log_string pname) ^ " " ^
@ -1236,7 +1236,7 @@ let update_specs tenv proc_name phase (new_specs : Specs.NormSpec.t list)
(Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map) (Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map)
SpecMap.empty old_specs) in SpecMap.empty old_specs) in
let re_exe_filter old_spec = (* filter out pres which failed re-exe *) let re_exe_filter old_spec = (* filter out pres which failed re-exe *)
if phase == Specs.RE_EXECUTION && if phase = Specs.RE_EXECUTION &&
not (IList.exists not (IList.exists
(fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) (fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre)
new_specs) new_specs)
@ -1326,9 +1326,9 @@ let analyze_proc source exe_env proc_desc : Specs.summary =
let prev_summary = Specs.get_summary_unsafe "analyze_proc" proc_name in let prev_summary = Specs.get_summary_unsafe "analyze_proc" proc_name in
let updated_summary = let updated_summary =
update_summary tenv prev_summary specs phase proc_name elapsed res in update_summary tenv prev_summary specs phase proc_name elapsed res in
if !Config.curr_language == Config.Clang && Config.report_custom_error then if !Config.curr_language = Config.Clang && Config.report_custom_error then
report_custom_errors tenv updated_summary; report_custom_errors tenv updated_summary;
if !Config.curr_language == Config.Java && Config.report_runtime_exceptions then if !Config.curr_language = Config.Java && Config.report_runtime_exceptions then
report_runtime_exceptions tenv proc_desc updated_summary; report_runtime_exceptions tenv proc_desc updated_summary;
updated_summary updated_summary
@ -1396,7 +1396,7 @@ let perform_transition exe_env tenv proc_name source =
[] in [] in
transition_footprint_re_exe tenv proc_name joined_pres in transition_footprint_re_exe tenv proc_name joined_pres in
match Specs.get_summary proc_name with match Specs.get_summary proc_name with
| Some summary when Specs.get_phase summary == Specs.FOOTPRINT -> | Some summary when Specs.get_phase summary = Specs.FOOTPRINT ->
transition () transition ()
| _ -> () | _ -> ()
@ -1531,7 +1531,7 @@ let print_stats_cfg proc_shadowed source cfg =
let err_table = Errlog.create_err_table () in let err_table = Errlog.create_err_table () in
let filter pdesc = let filter pdesc =
let pname = Procdesc.get_proc_name pdesc in let pname = Procdesc.get_proc_name pdesc in
Specs.summary_exists pname && Specs.get_specs pname != [] in Specs.summary_exists pname && Specs.get_specs pname <> [] in
let nodes_visited, nodes_total = visited_and_total_nodes ~filter cfg in let nodes_visited, nodes_total = visited_and_total_nodes ~filter cfg in
let num_proc = ref 0 in let num_proc = ref 0 in
let num_nospec_noerror_proc = ref 0 in let num_nospec_noerror_proc = ref 0 in
@ -1599,7 +1599,7 @@ let print_stats_cfg proc_shadowed source cfg =
let outc = open_out (DB.filename_to_string stats_file) in let outc = open_out (DB.filename_to_string stats_file) in
let fmt = F.formatter_of_out_channel outc in let fmt = F.formatter_of_out_channel outc in
print_file_stats fmt (); print_file_stats fmt ();
close_out outc Out_channel.close outc
with Sys_error _ -> () in with Sys_error _ -> () in
IList.iter compute_stats_proc (Cfg.get_defined_procs cfg); IList.iter compute_stats_proc (Cfg.get_defined_procs cfg);
L.out "%a" print_file_stats (); L.out "%a" print_file_stats ();

@ -424,7 +424,7 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 =
(sub_eids, eids_fresh) in (sub_eids, eids_fresh) in
let sub = Sil.sub_of_list (sub_ids @ sub_eids) in let sub = Sil.sub_of_list (sub_ids @ sub_eids) in
match sigma2 with match sigma2 with
| [] -> if sigma1 == [] then true else false | [] -> if sigma1 = [] then true else false
| hpred2 :: sigma2 -> | hpred2 :: sigma2 ->
let (hpat2, hpats2) = let (hpat2, hpats2) =
let (hpred2_ren, sigma2_ren) = (Sil.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2) in let (hpred2_ren, sigma2_ren) = (Sil.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2) in
@ -496,7 +496,7 @@ let rec generate_todos_from_strexp mode todos sexp1 sexp2 =
| Sil.Eexp _, _ -> | Sil.Eexp _, _ ->
None None
| Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) -> (* assume sorted w.r.t. fields *) | Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) -> (* assume sorted w.r.t. fields *)
if (IList.length fel1 <> IList.length fel2) && mode == Exact if (IList.length fel1 <> IList.length fel2) && mode = Exact
then None then None
else generate_todos_from_fel mode todos fel1 fel2 else generate_todos_from_fel mode todos fel1 fel2
| Sil.Estruct _, _ -> | Sil.Estruct _, _ ->
@ -513,9 +513,9 @@ and generate_todos_from_fel mode todos fel1 fel2 =
| [], [] -> | [], [] ->
Some todos Some todos
| [], _ -> | [], _ ->
if mode == RFieldForget then Some todos else None if mode = RFieldForget then Some todos else None
| _, [] -> | _, [] ->
if mode == LFieldForget then Some todos else None if mode = LFieldForget then Some todos else None
| (fld1, strexp1) :: fel1', (fld2, strexp2) :: fel2' -> | (fld1, strexp1) :: fel1', (fld2, strexp2) :: fel2' ->
let n = Ident.compare_fieldname fld1 fld2 in let n = Ident.compare_fieldname fld1 fld2 in
if (n = 0) then if (n = 0) then
@ -524,9 +524,9 @@ and generate_todos_from_fel mode todos fel1 fel2 =
| None -> None | None -> None
| Some todos' -> generate_todos_from_fel mode todos' fel1' fel2' | Some todos' -> generate_todos_from_fel mode todos' fel1' fel2'
end end
else if (n < 0 && mode == LFieldForget) then else if (n < 0 && mode = LFieldForget) then
generate_todos_from_fel mode todos fel1' fel2 generate_todos_from_fel mode todos fel1' fel2
else if (n > 0 && mode == RFieldForget) then else if (n > 0 && mode = RFieldForget) then
generate_todos_from_fel mode todos fel1 fel2' generate_todos_from_fel mode todos fel1 fel2'
else else
None None

@ -108,7 +108,7 @@ let rec slink ~stats ~skiplevels src dst =
if Sys.is_directory src = `Yes if Sys.is_directory src = `Yes
then then
begin begin
if (Sys.file_exists dst) != `Yes if (Sys.file_exists dst) <> `Yes
then Unix.mkdir dst ~perm:0o700; then Unix.mkdir dst ~perm:0o700;
let items = Sys.readdir src in let items = Sys.readdir src in
Array.iter Array.iter

@ -150,7 +150,7 @@ end = struct
module Invariant = struct module Invariant = struct
(** check whether a stats is the dummy stats *) (** check whether a stats is the dummy stats *)
let stats_is_dummy stats = let stats_is_dummy stats =
stats.max_length == - 1 stats.max_length = - 1
(** return the stats of the path, assumes that the stats are computed *) (** return the stats of the path, assumes that the stats are computed *)
let get_stats = function let get_stats = function
@ -422,7 +422,7 @@ end = struct
let rec contains p1 p2 = match p2 with let rec contains p1 p2 = match p2 with
| Pjoin (p2', p2'', _) -> | Pjoin (p2', p2'', _) ->
contains p1 p2' || contains p1 p2'' contains p1 p2' || contains p1 p2''
| _ -> p1 == p2 | _ -> phys_equal p1 p2
let create_loc_trace path pos_opt : Errlog.loc_trace = let create_loc_trace path pos_opt : Errlog.loc_trace =
let trace = ref [] in let trace = ref [] in

@ -133,7 +133,7 @@ module NullifyTransferFunctions = struct
match IList.rev instrs with match IList.rev instrs with
| instr :: _ -> instr | instr :: _ -> instr
| [] -> Sil.skip_instr in | [] -> Sil.skip_instr in
if node == !cache_node if phys_equal node !cache_node
then !cache_instr then !cache_instr
else else
begin begin
@ -144,7 +144,7 @@ module NullifyTransferFunctions = struct
end end
let is_last_instr_in_node instr node = let is_last_instr_in_node instr node =
last_instr_in_node node == instr phys_equal (last_instr_in_node node) instr
let exec_instr ((active_defs, to_nullify) as astate) extras node instr = let exec_instr ((active_defs, to_nullify) as astate) extras node instr =
let astate' = match instr with let astate' = match instr with
@ -188,7 +188,7 @@ let remove_dead_frontend_stores pdesc liveness_inv_map =
let node_remove_dead_stores node = let node_remove_dead_stores node =
let instr_nodes = BackwardCfg.instr_ids node in let instr_nodes = BackwardCfg.instr_ids node in
let instr_nodes' = IList.filter_changed is_used_store instr_nodes in let instr_nodes' = IList.filter_changed is_used_store instr_nodes in
if instr_nodes' != instr_nodes if not (phys_equal instr_nodes' instr_nodes)
then then
Procdesc.Node.replace_instrs node (IList.rev_map fst instr_nodes') in Procdesc.Node.replace_instrs node (IList.rev_map fst instr_nodes') in
Procdesc.iter_nodes node_remove_dead_stores pdesc Procdesc.iter_nodes node_remove_dead_stores pdesc
@ -285,7 +285,7 @@ let do_copy_propagation pdesc tenv =
match CopyProp.extract_pre id copy_prop_inv_map with match CopyProp.extract_pre id copy_prop_inv_map with
| Some pre when not (CopyPropagation.Domain.is_empty pre) -> | Some pre when not (CopyPropagation.Domain.is_empty pre) ->
let instr' = Sil.instr_sub_ids ~sub_id_binders:false (id_sub pre) instr in let instr' = Sil.instr_sub_ids ~sub_id_binders:false (id_sub pre) instr in
instr' :: instrs, changed || instr' != instr instr' :: instrs, changed || not (phys_equal instr' instr)
| _ -> | _ ->
instr :: instrs, changed instr :: instrs, changed
end end

@ -41,7 +41,7 @@ struct
done; done;
assert false (* execution never reaches here *) assert false (* execution never reaches here *)
with End_of_file -> with End_of_file ->
(close_in cin; (In_channel.close cin;
Array.of_list (IList.rev !lines)) Array.of_list (IList.rev !lines))
let file_data (hash: t) fname = let file_data (hash: t) fname =
@ -399,7 +399,7 @@ let node_start_session node loc proc_name session source =
(** Finish a session, and perform delayed print actions if required *) (** Finish a session, and perform delayed print actions if required *)
let node_finish_session node source = let node_finish_session node source =
if Config.test == false then force_delayed_prints () if Config.test = false then force_delayed_prints ()
else L.reset_delayed_prints (); else L.reset_delayed_prints ();
if Config.write_html then begin if Config.write_html then begin
F.fprintf !curr_html_formatter "</LISTING>%a" F.fprintf !curr_html_formatter "</LISTING>%a"

@ -124,9 +124,9 @@ let equal_prop p1 p2 =
let pp_footprint _pe f fp = let pp_footprint _pe f fp =
let pe = { _pe with Pp.cmap_norm = _pe.Pp.cmap_foot } in let pe = { _pe with Pp.cmap_norm = _pe.Pp.cmap_foot } in
let pp_pi f () = let pp_pi f () =
if fp.pi_fp != [] then if fp.pi_fp <> [] then
F.fprintf f "%a ;@\n" (Pp.semicolon_seq_oneline pe (Sil.pp_atom pe)) fp.pi_fp in F.fprintf f "%a ;@\n" (Pp.semicolon_seq_oneline pe (Sil.pp_atom pe)) fp.pi_fp in
if fp.pi_fp != [] || fp.sigma_fp != [] then if fp.pi_fp <> [] || fp.sigma_fp <> [] then
F.fprintf f "@\n[footprint@\n @[%a%a@] ]" F.fprintf f "@\n[footprint@\n @[%a%a@] ]"
pp_pi () (Pp.semicolon_seq pe (Sil.pp_hpred pe)) fp.sigma_fp pp_pi () (Pp.semicolon_seq pe (Sil.pp_hpred pe)) fp.sigma_fp
@ -203,23 +203,23 @@ let pp_sigma_simple pe env fmt sigma =
let sigma_stack, sigma_nonstack = sigma_get_stack_nonstack false sigma in let sigma_stack, sigma_nonstack = sigma_get_stack_nonstack false sigma in
let pp_stack fmt _sg = let pp_stack fmt _sg =
let sg = IList.sort Sil.compare_hpred _sg in let sg = IList.sort Sil.compare_hpred _sg in
if sg != [] then Format.fprintf fmt "%a" (Pp.semicolon_seq pe (pp_hpred_stackvar pe)) sg in if sg <> [] then Format.fprintf fmt "%a" (Pp.semicolon_seq pe (pp_hpred_stackvar pe)) sg in
let pp_nl fmt doit = if doit then let pp_nl fmt doit = if doit then
(match pe.Pp.kind with (match pe.Pp.kind with
| TEXT | HTML -> Format.fprintf fmt " ;@\n" | TEXT | HTML -> Format.fprintf fmt " ;@\n"
| LATEX -> Format.fprintf fmt " ; \\\\@\n") in | LATEX -> Format.fprintf fmt " ; \\\\@\n") in
let pp_nonstack fmt = Pp.semicolon_seq pe (Sil.pp_hpred_env pe (Some env)) fmt in let pp_nonstack fmt = Pp.semicolon_seq pe (Sil.pp_hpred_env pe (Some env)) fmt in
if sigma_stack != [] || sigma_nonstack != [] then if sigma_stack <> [] || sigma_nonstack <> [] then
Format.fprintf fmt "%a%a%a" Format.fprintf fmt "%a%a%a"
pp_stack sigma_stack pp_nl pp_stack sigma_stack pp_nl
(sigma_stack != [] && sigma_nonstack != []) pp_nonstack sigma_nonstack (sigma_stack <> [] && sigma_nonstack <> []) pp_nonstack sigma_nonstack
(** Dump a sigma. *) (** Dump a sigma. *)
let d_sigma (sigma: sigma) = L.add_print_action (PTsigma, Obj.repr sigma) let d_sigma (sigma: sigma) = L.add_print_action (PTsigma, Obj.repr sigma)
(** Dump a pi and a sigma *) (** Dump a pi and a sigma *)
let d_pi_sigma pi sigma = let d_pi_sigma pi sigma =
let d_separator () = if pi != [] && sigma != [] then L.d_strln " *" in let d_separator () = if pi <> [] && sigma <> [] then L.d_strln " *" in
d_pi pi; d_separator (); d_sigma sigma d_pi pi; d_separator (); d_sigma sigma
let pi_of_subst sub = let pi_of_subst sub =
@ -231,7 +231,7 @@ let get_pure (p: 'a t) : pi =
(** Print existential quantification *) (** Print existential quantification *)
let pp_evars pe f evars = let pp_evars pe f evars =
if evars != [] if evars <> []
then match pe.Pp.kind with then match pe.Pp.kind with
| TEXT | HTML -> | TEXT | HTML ->
F.fprintf f "exists [%a]. " (Pp.comma_seq (Ident.pp pe)) evars F.fprintf f "exists [%a]. " (Pp.comma_seq (Ident.pp pe)) evars
@ -288,9 +288,9 @@ let prop_update_obj_sub pe prop =
let pp_footprint_simple _pe env f fp = let pp_footprint_simple _pe env f fp =
let pe = { _pe with Pp.cmap_norm = _pe.Pp.cmap_foot } in let pe = { _pe with Pp.cmap_norm = _pe.Pp.cmap_foot } in
let pp_pure f pi = let pp_pure f pi =
if pi != [] then if pi <> [] then
F.fprintf f "%a *@\n" (pp_pi pe) pi in F.fprintf f "%a *@\n" (pp_pi pe) pi in
if fp.pi_fp != [] || fp.sigma_fp != [] then if fp.pi_fp <> [] || fp.sigma_fp <> [] then
F.fprintf f "@\n[footprint@\n @[%a%a@] ]" F.fprintf f "@\n[footprint@\n @[%a%a@] ]"
pp_pure fp.pi_fp pp_pure fp.pi_fp
(pp_sigma_simple pe env) fp.sigma_fp (pp_sigma_simple pe env) fp.sigma_fp
@ -305,14 +305,14 @@ let prop_pred_env prop =
(** Pretty print a proposition. *) (** Pretty print a proposition. *)
let pp_prop pe0 f prop = let pp_prop pe0 f prop =
let pe = prop_update_obj_sub pe0 prop in let pe = prop_update_obj_sub pe0 prop in
let latex = pe.Pp.kind == Pp.LATEX in let latex = pe.Pp.kind = Pp.LATEX in
let do_print f () = let do_print f () =
let subl = Sil.sub_to_list prop.sub in let subl = Sil.sub_to_list prop.sub in
(* since prop diff is based on physical equality, we need to extract the sub verbatim *) (* since prop diff is based on physical equality, we need to extract the sub verbatim *)
let pi = prop.pi in let pi = prop.pi in
let pp_pure f () = let pp_pure f () =
if subl != [] then F.fprintf f "%a ;@\n" (pp_subl pe) subl; if subl <> [] then F.fprintf f "%a ;@\n" (pp_subl pe) subl;
if pi != [] then F.fprintf f "%a ;@\n" (pp_pi pe) pi in if pi <> [] then F.fprintf f "%a ;@\n" (pp_pi pe) pi in
if !Config.pp_simple || latex then if !Config.pp_simple || latex then
begin begin
let env = prop_pred_env prop in let env = prop_pred_env prop in
@ -2117,7 +2117,7 @@ let prop_ren_sub tenv (ren_sub: Sil.subst) (prop: normal t) : normal t =
let exist_quantify tenv fav (prop : normal t) : normal t = let exist_quantify tenv fav (prop : normal t) : normal t =
let ids = Sil.fav_to_list fav in let ids = Sil.fav_to_list fav in
if IList.exists Ident.is_primed ids then assert false; (* sanity check *) if IList.exists Ident.is_primed ids then assert false; (* sanity check *)
if ids == [] then prop else if ids = [] then prop else
let gen_fresh_id_sub id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in let gen_fresh_id_sub id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in
let ren_sub = Sil.sub_of_list (IList.map gen_fresh_id_sub ids) in let ren_sub = Sil.sub_of_list (IList.map gen_fresh_id_sub ids) in
let prop' = let prop' =

@ -193,7 +193,7 @@ let compute_diff default_color oldgraph newgraph : diff =
() in () in
IList.iter build_changed newedges; IList.iter build_changed newedges;
let colormap (o: Obj.t) = let colormap (o: Obj.t) =
if IList.exists (fun x -> x == o) !changed then Pp.Red if IList.exists (fun x -> phys_equal x o) !changed then Pp.Red
else default_color in else default_color in
!changed, colormap in !changed, colormap in
let changed_norm, colormap_norm = compute_changed false in let changed_norm, colormap_norm = compute_changed false in

@ -484,7 +484,7 @@ end = struct
IList.map (function IList.map (function
| _, Exp.Const (Const.Cint n) -> n | _, Exp.Const (Const.Cint n) -> n
| _ -> assert false) e_upper_list in | _ -> assert false) e_upper_list in
if upper_list == [] then None if upper_list = [] then None
else Some (compute_min_from_nonempty_int_list upper_list) else Some (compute_min_from_nonempty_int_list upper_list)
(** Find a IntLit.t n such that [t |- n < e] if possible. *) (** Find a IntLit.t n such that [t |- n < e] if possible. *)
@ -501,7 +501,7 @@ end = struct
IList.map (function IList.map (function
| Exp.Const (Const.Cint n), _ -> n | Exp.Const (Const.Cint n), _ -> n
| _ -> assert false) e_lower_list in | _ -> assert false) e_lower_list in
if lower_list == [] then None if lower_list = [] then None
else Some (compute_max_from_nonempty_int_list lower_list) else Some (compute_max_from_nonempty_int_list lower_list)
(** Return [true] if a simple inconsistency is detected *) (** Return [true] if a simple inconsistency is detected *)
@ -651,7 +651,7 @@ let check_disequal tenv prop e1 e2 =
let sigma_irrelevant' = hpred :: sigma_irrelevant let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest in f sigma_irrelevant' e sigma_rest
| Some _ -> | Some _ ->
if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then if (k = Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant') in Some (true, sigma_irrelevant')
else if (Exp.equal e2 Exp.zero) then else if (Exp.equal e2 Exp.zero) then
@ -661,7 +661,7 @@ let check_disequal tenv prop e1 e2 =
let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest') in f [] e2 sigma_rest')
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest -> | Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest ->
if is_root tenv prop iF e != None || is_root tenv prop iB e != None then if is_root tenv prop iF e <> None || is_root tenv prop iB e <> None then
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant') in Some (true, sigma_irrelevant')
else else
@ -737,7 +737,7 @@ let get_smt_key a p =
let outc_tmp = open_out tmp_filename in let outc_tmp = open_out tmp_filename in
let fmt_tmp = F.formatter_of_out_channel outc_tmp in let fmt_tmp = F.formatter_of_out_channel outc_tmp in
let () = F.fprintf fmt_tmp "%a%a" (Sil.pp_atom Pp.text) a (Prop.pp_prop Pp.text) p in let () = F.fprintf fmt_tmp "%a%a" (Sil.pp_atom Pp.text) a (Prop.pp_prop Pp.text) p in
close_out outc_tmp; Out_channel.close outc_tmp;
Digest.to_hex (Digest.file tmp_filename) Digest.to_hex (Digest.file tmp_filename)
(** Check whether [prop |- a]. False means dont know. *) (** Check whether [prop |- a]. False means dont know. *)
@ -758,7 +758,7 @@ let check_atom tenv prop a0 =
L.d_str "WHERE:"; L.d_ln(); Prop.d_prop prop_no_fp; L.d_ln (); L.d_ln (); L.d_str "WHERE:"; L.d_ln(); Prop.d_prop prop_no_fp; L.d_ln (); L.d_ln ();
F.fprintf fmt "ID: %s @\nCHECK_ATOM_BOUND: %a@\nWHERE:@\n%a" F.fprintf fmt "ID: %s @\nCHECK_ATOM_BOUND: %a@\nWHERE:@\n%a"
key (Sil.pp_atom Pp.text) a (Prop.pp_prop Pp.text) prop_no_fp; key (Sil.pp_atom Pp.text) a (Prop.pp_prop Pp.text) prop_no_fp;
close_out outc; Out_channel.close outc;
end; end;
match a with match a with
| Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i)) | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i))
@ -780,14 +780,14 @@ let check_allocatedness tenv prop e =
let spatial_part = prop.Prop.sigma in let spatial_part = prop.Prop.sigma in
let f = function let f = function
| Sil.Hpointsto (base, _, _) -> | Sil.Hpointsto (base, _, _) ->
is_root tenv prop base n_e != None is_root tenv prop base n_e <> None
| Sil.Hlseg (k, _, e1, e2, _) -> | Sil.Hlseg (k, _, e1, e2, _) ->
if k == Sil.Lseg_NE || check_disequal tenv prop e1 e2 then if k = Sil.Lseg_NE || check_disequal tenv prop e1 e2 then
is_root tenv prop e1 n_e != None is_root tenv prop e1 n_e <> None
else false else false
| Sil.Hdllseg (k, _, iF, oB, oF, iB, _) -> | Sil.Hdllseg (k, _, iF, oB, oF, iB, _) ->
if k == Sil.Lseg_NE || check_disequal tenv prop iF oF || check_disequal tenv prop iB oB then if k = Sil.Lseg_NE || check_disequal tenv prop iF oF || check_disequal tenv prop iB oB then
is_root tenv prop iF n_e != None || is_root tenv prop iB n_e != None is_root tenv prop iF n_e <> None || is_root tenv prop iB n_e <> None
else false else false
in IList.exists f spatial_part in IList.exists f spatial_part
@ -1047,25 +1047,25 @@ end = struct
let _d_missing sub = let _d_missing sub =
L.d_strln "SUB: "; L.d_strln "SUB: ";
L.d_increase_indent 1; Prop.d_sub sub; L.d_decrease_indent 1; L.d_increase_indent 1; Prop.d_sub sub; L.d_decrease_indent 1;
if !missing_pi != [] && !missing_sigma != [] if !missing_pi <> [] && !missing_sigma <> []
then (L.d_ln (); Prop.d_pi !missing_pi; L.d_str "*"; L.d_ln (); Prop.d_sigma !missing_sigma) then (L.d_ln (); Prop.d_pi !missing_pi; L.d_str "*"; L.d_ln (); Prop.d_sigma !missing_sigma)
else if !missing_pi != [] else if !missing_pi <> []
then (L.d_ln (); Prop.d_pi !missing_pi) then (L.d_ln (); Prop.d_pi !missing_pi)
else if !missing_sigma != [] else if !missing_sigma <> []
then (L.d_ln (); Prop.d_sigma !missing_sigma); then (L.d_ln (); Prop.d_sigma !missing_sigma);
if !missing_fld != [] then if !missing_fld <> [] then
begin begin
L.d_ln (); L.d_ln ();
L.d_strln "MISSING FLD: "; L.d_increase_indent 1; Prop.d_sigma !missing_fld; L.d_decrease_indent 1 L.d_strln "MISSING FLD: "; L.d_increase_indent 1; Prop.d_sigma !missing_fld; L.d_decrease_indent 1
end; end;
if !missing_typ != [] then if !missing_typ <> [] then
begin begin
L.d_ln (); L.d_ln ();
L.d_strln "MISSING TYPING: "; L.d_increase_indent 1; d_typings !missing_typ; L.d_decrease_indent 1 L.d_strln "MISSING TYPING: "; L.d_increase_indent 1; d_typings !missing_typ; L.d_decrease_indent 1
end end
let d_missing sub = (* optional print of missing: if print something, prepend with newline *) let d_missing sub = (* optional print of missing: if print something, prepend with newline *)
if !missing_pi != [] || !missing_sigma!=[] || !missing_fld != [] || !missing_typ != [] || Sil.sub_to_list sub != [] then if !missing_pi <> [] || !missing_sigma <> [] || !missing_fld <> [] || !missing_typ <> [] || Sil.sub_to_list sub <> [] then
begin begin
L.d_ln (); L.d_ln ();
L.d_str "["; L.d_str "[";
@ -1074,7 +1074,7 @@ end = struct
end end
let d_frame_fld () = (* optional print of frame fld: if print something, prepend with newline *) let d_frame_fld () = (* optional print of frame fld: if print something, prepend with newline *)
if !frame_fld != [] then if !frame_fld <> [] then
begin begin
L.d_ln (); L.d_ln ();
L.d_strln "[FRAME FLD:"; L.d_strln "[FRAME FLD:";
@ -1082,7 +1082,7 @@ end = struct
end end
let d_frame_typ () = (* optional print of frame typ: if print something, prepend with newline *) let d_frame_typ () = (* optional print of frame typ: if print something, prepend with newline *)
if !frame_typ != [] then if !frame_typ <> [] then
begin begin
L.d_ln (); L.d_ln ();
L.d_strln "[FRAME TYPING:"; L.d_strln "[FRAME TYPING:";
@ -1202,7 +1202,7 @@ let exp_imply tenv calc_missing subs e1_in e2_in : subst2 =
raise (IMPL_EXC ("pointer+index cannot evaluate to a constant", subs, (EXC_FALSE_EXPS (e1, e2)))) raise (IMPL_EXC ("pointer+index cannot evaluate to a constant", subs, (EXC_FALSE_EXPS (e1, e2))))
| Exp.Const (Const.Cint n1), Exp.BinOp (Binop.PlusA, f1, Exp.Const (Const.Cint n2)) -> | Exp.Const (Const.Cint n1), Exp.BinOp (Binop.PlusA, f1, Exp.Const (Const.Cint n2)) ->
do_imply subs (Exp.int (n1 -- n2)) f1 do_imply subs (Exp.int (n1 -- n2)) f1
| Exp.BinOp(op1, e1, f1), Exp.BinOp(op2, e2, f2) when op1 == op2 -> | Exp.BinOp(op1, e1, f1), Exp.BinOp(op2, e2, f2) when op1 = op2 ->
do_imply (do_imply subs e1 e2) f1 f2 do_imply (do_imply subs e1 e2) f1 f2
| Exp.BinOp (Binop.PlusA, Exp.Var v1, e1), e2 -> | Exp.BinOp (Binop.PlusA, Exp.Var v1, e1), e2 ->
do_imply subs (Exp.Var v1) (Exp.BinOp (Binop.MinusA, e2, e1)) do_imply subs (Exp.Var v1) (Exp.BinOp (Binop.MinusA, e2, e1))
@ -1218,7 +1218,7 @@ let exp_imply tenv calc_missing subs e1_in e2_in : subst2 =
raise (IMPL_EXC ("expressions not equal", subs, (EXC_FALSE_EXPS (e1, e2)))) raise (IMPL_EXC ("expressions not equal", subs, (EXC_FALSE_EXPS (e1, e2))))
| e1, Exp.Const _ -> | e1, Exp.Const _ ->
raise (IMPL_EXC ("lhs not constant", subs, (EXC_FALSE_EXPS (e1, e2)))) raise (IMPL_EXC ("lhs not constant", subs, (EXC_FALSE_EXPS (e1, e2))))
| Exp.Lfield(e1, fd1, _), Exp.Lfield(e2, fd2, _) when fd1 == fd2 -> | Exp.Lfield(e1, fd1, _), Exp.Lfield(e2, fd2, _) when Ident.equal_fieldname fd1 fd2 ->
do_imply subs e1 e2 do_imply subs e1 e2
| Exp.Lindex(e1, f1), Exp.Lindex(e2, f2) -> | Exp.Lindex(e1, f1), Exp.Lindex(e2, f2) ->
do_imply (do_imply subs e1 e2) f1 f2 do_imply (do_imply subs e1 e2) f1 f2
@ -1284,8 +1284,8 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 :
(exp_imply tenv calc_missing subs e1 e2, None, None) (exp_imply tenv calc_missing subs e1 e2, None, None)
| Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) -> | Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) ->
let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 in let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 in
let fld_frame_opt = if fld_frame != [] then Some (Sil.Estruct (fld_frame, inst1)) else None in let fld_frame_opt = if fld_frame <> [] then Some (Sil.Estruct (fld_frame, inst1)) else None in
let fld_missing_opt = if fld_missing != [] then Some (Sil.Estruct (fld_missing, inst1)) else None in let fld_missing_opt = if fld_missing <> [] then Some (Sil.Estruct (fld_missing, inst1)) else None in
subs', fld_frame_opt, fld_missing_opt subs', fld_frame_opt, fld_missing_opt
| Sil.Estruct _, Sil.Eexp (e2, _) -> | Sil.Estruct _, Sil.Eexp (e2, _) ->
begin begin
@ -1304,11 +1304,11 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 :
let subs' = array_len_imply tenv calc_missing subs len1 len2 indices2 in let subs' = array_len_imply tenv calc_missing subs len1 len2 indices2 in
let subs'', index_frame, index_missing = let subs'', index_frame, index_missing =
array_imply tenv source calc_index_frame calc_missing subs' esel1 esel2 typ2 in array_imply tenv source calc_index_frame calc_missing subs' esel1 esel2 typ2 in
let index_frame_opt = if index_frame != [] let index_frame_opt = if index_frame <> []
then Some (Sil.Earray (len1, index_frame, inst1)) then Some (Sil.Earray (len1, index_frame, inst1))
else None in else None in
let index_missing_opt = let index_missing_opt =
if index_missing != [] && if index_missing <> [] &&
(Config.allow_missing_index_in_proc_call || !Config.footprint) (Config.allow_missing_index_in_proc_call || !Config.footprint)
then Some (Sil.Earray (len1, index_missing, inst1)) then Some (Sil.Earray (len1, index_missing, inst1))
else None in else None in
@ -1846,7 +1846,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
raise (Exceptions.Abduction_case_not_implemented __POS__)) raise (Exceptions.Abduction_case_not_implemented __POS__))
| _ -> () | _ -> ()
in in
if Exp.equal e2 f2 && k == Sil.Lseg_PE then (subs, prop1) if Exp.equal e2 f2 && k = Sil.Lseg_PE then (subs, prop1)
else else
(match Prop.prop_iter_create prop1 with (match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
@ -2149,7 +2149,7 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2
L.d_increase_indent 1; Prop.d_pi pi1; L.d_decrease_indent 1; L.d_ln (); L.d_increase_indent 1; Prop.d_pi pi1; L.d_decrease_indent 1; L.d_ln ();
L.d_strln "pi2:"; L.d_strln "pi2:";
L.d_increase_indent 1; Prop.d_pi pi2; L.d_decrease_indent 1; L.d_ln (); L.d_increase_indent 1; Prop.d_pi pi2; L.d_decrease_indent 1; L.d_ln ();
if pi2_bcheck != [] if pi2_bcheck <> []
then (L.d_str "pi2 bounds checks: "; Prop.d_pi pi2_bcheck; L.d_ln ()); then (L.d_str "pi2 bounds checks: "; Prop.d_pi pi2_bcheck; L.d_ln ());
L.d_strln "returns"; L.d_strln "returns";
L.d_strln "sub1: "; L.d_strln "sub1: ";
@ -2169,7 +2169,7 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2
L.d_increase_indent 1; d_impl (sub1, sub2) (prop1, prop2); L.d_decrease_indent 1; L.d_ln (); L.d_increase_indent 1; d_impl (sub1, sub2) (prop1, prop2); L.d_decrease_indent 1; L.d_ln ();
L.d_strln"returning TRUE"; L.d_strln"returning TRUE";
let frame = frame_prop.Prop.sigma in let frame = frame_prop.Prop.sigma in
if check_frame_empty && frame != [] then raise (IMPL_EXC("frame not empty", subs, EXC_FALSE)); if check_frame_empty && frame <> [] then raise (IMPL_EXC("frame not empty", subs, EXC_FALSE));
Some ((sub1, sub2), frame) Some ((sub1, sub2), frame)
with with
| IMPL_EXC (s, subs, body) -> | IMPL_EXC (s, subs, body) ->

@ -294,7 +294,7 @@ and array_case_analysis_index pname tenv orig_prop
index off inst_arr inst index off inst_arr inst
= =
let check_sound t' = let check_sound t' =
if not (Typ.equal typ_cont t' || array_cont == []) if not (Typ.equal typ_cont t' || array_cont = [])
then raise (Exceptions.Bad_footprint __POS__) in then raise (Exceptions.Bad_footprint __POS__) in
let index_in_array = let index_in_array =
IList.exists (fun (i, _) -> Prover.check_equal tenv Prop.prop_emp index i) array_cont in IList.exists (fun (i, _) -> Prover.check_equal tenv Prop.prop_emp index i) array_cont in

@ -36,7 +36,7 @@ module Jprop = struct
(** Return true if the two join_prop's are equal *) (** Return true if the two join_prop's are equal *)
let equal jp1 jp2 = let equal jp1 jp2 =
compare jp1 jp2 == 0 compare jp1 jp2 = 0
let to_prop = function let to_prop = function
| Prop (_, p) -> p | Prop (_, p) -> p
@ -408,10 +408,10 @@ let describe_timestamp summary =
("Timestamp", Printf.sprintf "%d" summary.timestamp) ("Timestamp", Printf.sprintf "%d" summary.timestamp)
let describe_status summary = let describe_status summary =
("Status", if summary.status == ACTIVE then "ACTIVE" else "INACTIVE") ("Status", if summary.status = ACTIVE then "ACTIVE" else "INACTIVE")
let describe_phase summary = let describe_phase summary =
("Phase", if summary.phase == FOOTPRINT then "FOOTPRINT" else "RE_EXECUTION") ("Phase", if summary.phase = FOOTPRINT then "FOOTPRINT" else "RE_EXECUTION")
(** Return the signature of a procedure declaration as a string *) (** Return the signature of a procedure declaration as a string *)
let get_signature summary = let get_signature summary =

@ -151,7 +151,7 @@ let instrs_normalize instrs =
| _ -> ids in | _ -> ids in
IList.fold_left do_instr [] instrs in IList.fold_left do_instr [] instrs in
let subst = let subst =
let count = ref min_int in let count = ref Int.min_value in
let gensym id = let gensym id =
incr count; incr count;
Ident.set_stamp id !count in Ident.set_stamp id !count in

@ -381,7 +381,7 @@ let call_should_be_skipped callee_summary =
(* skip abstract methods *) (* skip abstract methods *)
|| callee_summary.Specs.attributes.ProcAttributes.is_abstract || callee_summary.Specs.attributes.ProcAttributes.is_abstract
(* treat calls with no specs as skip functions in angelic mode *) (* treat calls with no specs as skip functions in angelic mode *)
|| (Config.angelic_execution && Specs.get_specs_from_payload callee_summary == []) || (Config.angelic_execution && Specs.get_specs_from_payload callee_summary = [])
(** In case of constant string dereference, return the result immediately *) (** In case of constant string dereference, return the result immediately *)
let check_constant_string_dereference lexp = let check_constant_string_dereference lexp =

@ -123,7 +123,7 @@ let spec_find_rename trace_call (proc_name : Procname.t)
let f spec = let f spec =
incr count; (!count, spec_rename_vars proc_name spec) in incr count; (!count, spec_rename_vars proc_name spec) in
let specs, formals = Specs.get_specs_formals proc_name in let specs, formals = Specs.get_specs_formals proc_name in
if specs == [] then if specs = [] then
begin begin
trace_call Specs.CallStats.CR_not_found; trace_call Specs.CallStats.CR_not_found;
raise (Exceptions.Precondition_not_found raise (Exceptions.Precondition_not_found
@ -303,7 +303,7 @@ let check_dereferences tenv callee_pname actual_pre sub spec_pre formal_params =
| Some (_, pos) -> Some pos | Some (_, pos) -> Some pos
| None -> None | None -> None
else None in else None in
if deref_no_null_check_pos != None if deref_no_null_check_pos <> None
then then
(* only report a dereference null error if we know (* only report a dereference null error if we know
there was a dereference without null check *) there was a dereference without null check *)
@ -854,7 +854,7 @@ let mk_actual_precondition tenv prop actual_params formal_params =
let rec comb fpars apars = match fpars, apars with let rec comb fpars apars = match fpars, apars with
| f:: fpars', a:: apars' -> (f, a) :: comb fpars' apars' | f:: fpars', a:: apars' -> (f, a) :: comb fpars' apars'
| [], _ -> | [], _ ->
if apars != [] then if apars <> [] then
begin begin
let str = let str =
"more actual pars than formal pars in fun call (" ^ "more actual pars than formal pars in fun call (" ^
@ -1078,12 +1078,12 @@ let exe_spec
(* missing fields minus hidden fields *) (* missing fields minus hidden fields *)
let missing_fld_nohidden = let missing_fld_nohidden =
IList.filter (fun hp -> not (hpred_missing_hidden hp)) missing_fld in IList.filter (fun hp -> not (hpred_missing_hidden hp)) missing_fld in
if !Config.footprint = false && split.missing_sigma != [] then if !Config.footprint = false && split.missing_sigma <> [] then
begin begin
L.d_strln "Implication error: missing_sigma not empty in re-execution"; L.d_strln "Implication error: missing_sigma not empty in re-execution";
Invalid_res Missing_sigma_not_empty Invalid_res Missing_sigma_not_empty
end end
else if !Config.footprint = false && missing_fld_nohidden != [] then else if !Config.footprint = false && missing_fld_nohidden <> [] then
begin begin
L.d_strln "Implication error: missing_fld not empty in re-execution"; L.d_strln "Implication error: missing_fld not empty in re-execution";
Invalid_res Missing_fld_not_empty Invalid_res Missing_fld_not_empty
@ -1117,7 +1117,7 @@ let prop_pure_to_footprint tenv (p: 'a Prop.t) : Prop.normal Prop.t =
Sil.fav_for_all a_fav Ident.is_footprint in Sil.fav_for_all a_fav Ident.is_footprint in
let pure = Prop.get_pure p in let pure = Prop.get_pure p in
let new_footprint_atoms = IList.filter is_footprint_atom_not_attribute pure in let new_footprint_atoms = IList.filter is_footprint_atom_not_attribute pure in
if new_footprint_atoms == [] if new_footprint_atoms = []
then p then p
else (* add pure fact to footprint *) else (* add pure fact to footprint *)
Prop.normalize tenv (Prop.set p ~pi_fp:(p.Prop.pi_fp @ new_footprint_atoms)) Prop.normalize tenv (Prop.set p ~pi_fp:(p.Prop.pi_fp @ new_footprint_atoms))
@ -1134,7 +1134,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
let invalid_res = let invalid_res =
IList.map (function Valid_res _ -> assert false | Invalid_res ir -> ir) invalid_res0 in IList.map (function Valid_res _ -> assert false | Invalid_res ir -> ir) invalid_res0 in
let valid_res_miss_pi, valid_res_no_miss_pi = let valid_res_miss_pi, valid_res_no_miss_pi =
IList.partition (fun vr -> vr.vr_pi != []) valid_res in IList.partition (fun vr -> vr.vr_pi <> []) valid_res in
let _, valid_res_cons_pre_missing = let _, valid_res_cons_pre_missing =
IList.partition (fun vr -> vr.incons_pre_missing) valid_res in IList.partition (fun vr -> vr.incons_pre_missing) valid_res in
let deref_errors = IList.filter (function Dereference_error _ -> true | _ -> false) invalid_res in let deref_errors = IList.filter (function Dereference_error _ -> true | _ -> false) invalid_res in
@ -1144,7 +1144,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
let res_with_path_idents = let res_with_path_idents =
if !Config.footprint then if !Config.footprint then
begin begin
if valid_res_cons_pre_missing == [] then if valid_res_cons_pre_missing = [] then
(* no valid results where actual pre and missing are consistent *) (* no valid results where actual pre and missing are consistent *)
begin begin
if deref_errors <> [] then (* dereference error detected *) if deref_errors <> [] then (* dereference error detected *)
@ -1222,9 +1222,9 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
(fun (p, path) -> (prop_pure_to_footprint tenv p, path)) (fun (p, path) -> (prop_pure_to_footprint tenv p, path))
(IList.flatten (IList.map process_valid_res valid_res)) (IList.flatten (IList.map process_valid_res valid_res))
end end
else if valid_res_no_miss_pi != [] then else if valid_res_no_miss_pi <> [] then
IList.flatten (IList.map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi) IList.flatten (IList.map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
else if valid_res_miss_pi == [] then else if valid_res_miss_pi = [] then
raise (Exceptions.Precondition_not_met (call_desc None, __POS__)) raise (Exceptions.Precondition_not_met (call_desc None, __POS__))
else else
begin begin

@ -1117,7 +1117,7 @@ and progress_bar =
"Show a progress bar" "Show a progress bar"
and quiet = and quiet =
CLOpt.mk_bool ~long:"quiet" ~short:"q" ~default:(current_exe != CLOpt.Print) CLOpt.mk_bool ~long:"quiet" ~short:"q" ~default:(current_exe <> CLOpt.Print)
~exes:CLOpt.[Print] ~exes:CLOpt.[Print]
"Do not print specs on standard output" "Do not print specs on standard output"

@ -92,7 +92,7 @@ let file_modified_time ?(symlink=false) fname =
let filename_create_dir fname = let filename_create_dir fname =
let dirname = Filename.dirname fname in let dirname = Filename.dirname fname in
if (Sys.file_exists dirname) != `Yes if (Sys.file_exists dirname) <> `Yes
then Utils.create_dir dirname then Utils.create_dir dirname
let read_whole_file fd = let read_whole_file fd =
@ -161,7 +161,7 @@ module Results_dir = struct
let rec f = function let rec f = function
| [] -> base | [] -> base
| name:: names -> | name:: names ->
Filename.concat (f names) (if name ==".." then Filename.parent_dir_name else name) in Filename.concat (f names) (if String.equal name ".." then Filename.parent_dir_name else name) in
f (IList.rev path) f (IList.rev path)
(** convert a path to a filename *) (** convert a path to a filename *)

@ -25,7 +25,7 @@ let convert_string s =
let cnt = ref 0 in let cnt = ref 0 in
let s' = ref "" in let s' = ref "" in
let f c = let f c =
if c == '_' then s' := !s' ^ "\\_" if c = '_' then s' := !s' ^ "\\_"
else s' := !s' ^ Char.escaped (String.get s !cnt); else s' := !s' ^ Char.escaped (String.get s !cnt);
incr cnt in incr cnt in
String.iter ~f s; String.iter ~f s;

@ -70,7 +70,7 @@ let set_log_file_identifier (current_exe : CLOpt.exe) string_opt =
if Lazy.is_val fmt_chan_file then ( if Lazy.is_val fmt_chan_file then (
let (fmt, chan, _) = Lazy.force fmt_chan_file in let (fmt, chan, _) = Lazy.force fmt_chan_file in
F.pp_print_flush fmt () ; F.pp_print_flush fmt () ;
Pervasives.close_out_noerr chan Out_channel.close chan
) in ) in
close out_fmt_chan_file ; close out_fmt_chan_file ;
close err_fmt_chan_file close err_fmt_chan_file

@ -42,7 +42,7 @@ let write multilinks dir::dir => {
let fname = Filename.concat dir multilink_file_name; let fname = Filename.concat dir multilink_file_name;
let outc = open_out fname; let outc = open_out fname;
String.Table.iteri f::(fun key::_ data::src => output_string outc (src ^ "\n")) multilinks; String.Table.iteri f::(fun key::_ data::src => output_string outc (src ^ "\n")) multilinks;
close_out outc Out_channel.close outc
}; };
let lookup dir::dir => let lookup dir::dir =>

@ -73,7 +73,7 @@ let latex color =
(** Extend the normal colormap for the given object with the given color *) (** Extend the normal colormap for the given object with the given color *)
let extend_colormap pe (x: Obj.t) (c: color) = let extend_colormap pe (x: Obj.t) (c: color) =
let colormap (y: Obj.t) = let colormap (y: Obj.t) =
if x == y then c if phys_equal x y then c
else pe.cmap_norm y in else pe.cmap_norm y in
{ pe with cmap_norm = colormap } { pe with cmap_norm = colormap }

@ -67,7 +67,7 @@ let create_serializer (key : key) : 'a serializer =
| inc -> | inc ->
let read () = let read () =
try try
seek_in inc 0 ; In_channel.seek inc 0L ;
match_data (Marshal.from_channel inc) fname match_data (Marshal.from_channel inc) fname
with with
| Sys_error _ -> None in | Sys_error _ -> None in
@ -80,7 +80,7 @@ let create_serializer (key : key) : 'a serializer =
(* which indicates that another process is writing the same file. *) (* which indicates that another process is writing the same file. *)
SymOp.try_finally SymOp.try_finally
(fun () -> retry_exception timeout catch_exn read ()) (fun () -> retry_exception timeout catch_exn read ())
(fun () -> close_in inc) in (fun () -> In_channel.close inc) in
let to_file (fname : DB.filename) (value : 'a) = let to_file (fname : DB.filename) (value : 'a) =
let fname_str = DB.filename_to_string fname in let fname_str = DB.filename_to_string fname in
(* support nonblocking reads and writes in parallel: *) (* support nonblocking reads and writes in parallel: *)
@ -89,7 +89,7 @@ let create_serializer (key : key) : 'a serializer =
~in_dir:(Filename.dirname fname_str) (Filename.basename fname_str) ".tmp" in ~in_dir:(Filename.dirname fname_str) (Filename.basename fname_str) ".tmp" in
let outc = open_out_bin fname_tmp in let outc = open_out_bin fname_tmp in
Marshal.to_channel outc (key, version, value) []; Marshal.to_channel outc (key, version, value) [];
close_out outc; Out_channel.close outc;
Unix.rename ~src:fname_tmp ~dst:fname_str in Unix.rename ~src:fname_tmp ~dst:fname_str in
(from_string, from_file, to_file) (from_string, from_file, to_file)

@ -25,7 +25,7 @@ let read_file fname =
let cleanup () = let cleanup () =
match !cin_ref with match !cin_ref with
| None -> () | None -> ()
| Some cin -> close_in cin in | Some cin -> In_channel.close cin in
try try
let cin = open_in fname in let cin = open_in fname in
cin_ref := Some cin; cin_ref := Some cin;
@ -50,11 +50,11 @@ let copy_file fname_from fname_to =
let cleanup () = let cleanup () =
begin match !cin_ref with begin match !cin_ref with
| None -> () | None -> ()
| Some cin -> close_in cin | Some cin -> In_channel.close cin
end; end;
begin match !cout_ref with begin match !cout_ref with
| None -> () | None -> ()
| Some cout -> close_out cout | Some cout -> Out_channel.close cout
end in end in
try try
let cin = open_in fname_from in let cin = open_in fname_from in
@ -101,7 +101,7 @@ let do_outf outf_opt f =
(** close an outfile *) (** close an outfile *)
let close_outf outf = let close_outf outf =
close_out outf.out_c Out_channel.close outf.out_c
(** convert a filename to absolute path and normalize by removing occurrences of "." and ".." *) (** convert a filename to absolute path and normalize by removing occurrences of "." and ".." *)
module FileNormalize = struct module FileNormalize = struct
@ -277,7 +277,7 @@ let do_finally f g =
let with_file file ~f = let with_file file ~f =
let oc = open_out file in let oc = open_out file in
let f () = f oc in let f () = f oc in
let g () = close_out oc in let g () = Out_channel.close oc in
do_finally f g |> fst do_finally f g |> fst
let write_json_to_file destfile json = let write_json_to_file destfile json =
@ -299,7 +299,7 @@ let with_process_in command read =
(** Create a directory if it does not exist already. *) (** Create a directory if it does not exist already. *)
let create_dir dir = let create_dir dir =
try try
if (Unix.stat dir).Unix.st_kind != Unix.S_DIR then if (Unix.stat dir).Unix.st_kind <> Unix.S_DIR then
failwithf "@.ERROR: file %s exists and is not a directory@." dir failwithf "@.ERROR: file %s exists and is not a directory@." dir
with Unix.Unix_error _ -> with Unix.Unix_error _ ->
try Unix.mkdir dir ~perm:0o700 with try Unix.mkdir dir ~perm:0o700 with

@ -28,7 +28,7 @@ let load_from_cache serializer zip_path cache_dir zip_library =
let absolute_path = Filename.concat cache_dir zip_path in let absolute_path = Filename.concat cache_dir zip_path in
let deserialize = Serialization.from_file serializer in let deserialize = Serialization.from_file serializer in
let extract to_path = let extract to_path =
if (Sys.file_exists to_path) != `Yes then if (Sys.file_exists to_path) <> `Yes then
begin begin
Unix.mkdir_p (Filename.dirname to_path); Unix.mkdir_p (Filename.dirname to_path);
let lazy zip_channel = zip_library.zip_channel in let lazy zip_channel = zip_library.zip_channel in

@ -23,7 +23,7 @@ let pp fmt astate =
let initial = IdMap.empty let initial = IdMap.empty
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
try try
@ -37,7 +37,7 @@ let (<=) ~lhs ~rhs =
with Not_found -> false with Not_found -> false
let join astate1 astate2 = let join astate1 astate2 =
if astate1 == astate2 if phys_equal astate1 astate2
then astate1 then astate1
else else
IdMap.merge IdMap.merge

@ -336,7 +336,7 @@ module Make (Spec : Spec) = struct
|> Sinks.union caller_trace.sinks in |> Sinks.union caller_trace.sinks in
let passthroughs = let passthroughs =
if sources == caller_trace.sources && sinks == caller_trace.sinks if phys_equal sources caller_trace.sources && phys_equal sinks caller_trace.sinks
then then
(* this callee didn't add any new sources or any news sinks; it's just a passthrough *) (* this callee didn't add any new sources or any news sinks; it's just a passthrough *)
Passthroughs.add (Passthrough.make callee_site) caller_trace.passthroughs Passthroughs.add (Passthrough.make callee_site) caller_trace.passthroughs
@ -352,13 +352,13 @@ module Make (Spec : Spec) = struct
{ sources; sinks; passthroughs; } { sources; sinks; passthroughs; }
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
lhs == rhs || phys_equal lhs rhs ||
(Sources.subset lhs.sources rhs.sources && (Sources.subset lhs.sources rhs.sources &&
Sinks.subset lhs.sinks rhs.sinks && Sinks.subset lhs.sinks rhs.sinks &&
Passthroughs.subset lhs.passthroughs rhs.passthroughs) Passthroughs.subset lhs.passthroughs rhs.passthroughs)
let join t1 t2 = let join t1 t2 =
if t1 == t2 if phys_equal t1 t2
then t1 then t1
else else
let sources = Sources.union t1.sources t2.sources in let sources = Sources.union t1.sources t2.sources in

@ -29,7 +29,7 @@ module BottomLifted (Domain : S) = struct
let initial = Bottom let initial = Bottom
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
match lhs, rhs with match lhs, rhs with
@ -38,7 +38,7 @@ module BottomLifted (Domain : S) = struct
| NonBottom lhs, NonBottom rhs -> Domain.(<=) ~lhs ~rhs | NonBottom lhs, NonBottom rhs -> Domain.(<=) ~lhs ~rhs
let join astate1 astate2 = let join astate1 astate2 =
if astate1 == astate2 if phys_equal astate1 astate2
then astate1 then astate1
else else
match astate1, astate2 with match astate1, astate2 with
@ -47,7 +47,7 @@ module BottomLifted (Domain : S) = struct
| NonBottom a1, NonBottom a2 -> NonBottom (Domain.join a1 a2) | NonBottom a1, NonBottom a2 -> NonBottom (Domain.join a1 a2)
let widen ~prev ~next ~num_iters = let widen ~prev ~next ~num_iters =
if prev == next if phys_equal prev next
then prev then prev
else else
match prev, next with match prev, next with
@ -66,18 +66,18 @@ module Pair (Domain1 : S) (Domain2 : S) = struct
let initial = Domain1.initial, Domain2.initial let initial = Domain1.initial, Domain2.initial
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
Domain1.(<=) ~lhs:(fst lhs) ~rhs:(fst rhs) && Domain2.(<=) ~lhs:(snd lhs) ~rhs:(snd rhs) Domain1.(<=) ~lhs:(fst lhs) ~rhs:(fst rhs) && Domain2.(<=) ~lhs:(snd lhs) ~rhs:(snd rhs)
let join astate1 astate2 = let join astate1 astate2 =
if astate1 == astate2 if phys_equal astate1 astate2
then astate1 then astate1
else Domain1.join (fst astate1) (fst astate2), Domain2.join (snd astate1) (snd astate2) else Domain1.join (fst astate1) (fst astate2), Domain2.join (snd astate1) (snd astate2)
let widen ~prev ~next ~num_iters = let widen ~prev ~next ~num_iters =
if prev == next if phys_equal prev next
then prev then prev
else else
Domain1.widen ~prev:(fst prev) ~next:(fst next) ~num_iters, Domain1.widen ~prev:(fst prev) ~next:(fst next) ~num_iters,
@ -94,12 +94,12 @@ module FiniteSet (S : PrettyPrintable.PPSet) = struct
let initial = empty let initial = empty
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else subset lhs rhs else subset lhs rhs
let join astate1 astate2 = let join astate1 astate2 =
if astate1 == astate2 if phys_equal astate1 astate2
then astate1 then astate1
else union astate1 astate2 else union astate1 astate2
@ -115,7 +115,7 @@ module Map (M : PrettyPrintable.PPMap) (ValueDomain : S) = struct
(** true if all keys in [lhs] are in [rhs], and each lhs value <= corresponding rhs value *) (** true if all keys in [lhs] are in [rhs], and each lhs value <= corresponding rhs value *)
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
M.for_all M.for_all
@ -125,7 +125,7 @@ module Map (M : PrettyPrintable.PPMap) (ValueDomain : S) = struct
lhs lhs
let join astate1 astate2 = let join astate1 astate2 =
if astate1 == astate2 if phys_equal astate1 astate2
then astate1 then astate1
else else
M.merge M.merge

@ -105,7 +105,7 @@ let with_base_var var = function
| Abstracted ((_, base_typ), accesses) -> Abstracted ((var, base_typ), accesses) | Abstracted ((_, base_typ), accesses) -> Abstracted ((var, base_typ), accesses)
let rec is_prefix_path path1 path2 = let rec is_prefix_path path1 path2 =
if path1 == path2 if phys_equal path1 path2
then true then true
else else
match path1, path2 with match path1, path2 with
@ -114,7 +114,7 @@ let rec is_prefix_path path1 path2 =
| access1 :: p1, access2 :: p2 -> equal_access access1 access2 && is_prefix_path p1 p2 | access1 :: p1, access2 :: p2 -> equal_access access1 access2 && is_prefix_path p1 p2
let is_prefix ((base1, path1) as ap1) ((base2, path2) as ap2) = let is_prefix ((base1, path1) as ap1) ((base2, path2) as ap2) =
if ap1 == ap2 if phys_equal ap1 ap2
then true then true
else else
equal_base base1 base2 && is_prefix_path path1 path2 equal_base base1 base2 && is_prefix_path path1 path2

@ -28,7 +28,8 @@ module Set = struct
let normalize aps = let normalize aps =
APSet.filter APSet.filter
(fun lhs -> not (APSet.exists (fun rhs -> lhs != rhs && AccessPath.(<=) ~lhs ~rhs) aps)) (fun lhs ->
not (APSet.exists (fun rhs -> not (phys_equal lhs rhs) && AccessPath.(<=) ~lhs ~rhs) aps))
aps aps
let add = APSet.add let add = APSet.add
@ -44,7 +45,7 @@ module Set = struct
APSet.mem ap aps || APSet.exists (has_overlap ap) aps APSet.mem ap aps || APSet.exists (has_overlap ap) aps
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
let rhs_contains lhs_ap = let rhs_contains lhs_ap =
@ -52,12 +53,12 @@ module Set = struct
APSet.subset lhs rhs || APSet.for_all rhs_contains lhs APSet.subset lhs rhs || APSet.for_all rhs_contains lhs
let join aps1 aps2 = let join aps1 aps2 =
if aps1 == aps2 if phys_equal aps1 aps2
then aps1 then aps1
else APSet.union aps1 aps2 else APSet.union aps1 aps2
let widen ~prev ~next ~num_iters:_ = let widen ~prev ~next ~num_iters:_ =
if prev == next if phys_equal prev next
then prev then prev
else else
let abstract_access_path ap aps = match ap with let abstract_access_path ap aps = match ap with

@ -123,7 +123,7 @@ module Make (TraceDomain : AbstractDomain.S) = struct
Option.map ~f:fst (get_node ap tree) Option.map ~f:fst (get_node ap tree)
let rec access_tree_lteq ((lhs_trace, lhs_tree) as lhs) ((rhs_trace, rhs_tree) as rhs) = let rec access_tree_lteq ((lhs_trace, lhs_tree) as lhs) ((rhs_trace, rhs_tree) as rhs) =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
TraceDomain.(<=) ~lhs:lhs_trace ~rhs:rhs_trace && TraceDomain.(<=) ~lhs:lhs_trace ~rhs:rhs_trace &&
@ -142,7 +142,7 @@ module Make (TraceDomain : AbstractDomain.S) = struct
false false
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
BaseMap.for_all BaseMap.for_all
@ -154,7 +154,7 @@ module Make (TraceDomain : AbstractDomain.S) = struct
lhs lhs
let node_join f_node_merge f_trace_merge ((trace1, tree1) as node1) ((trace2, tree2) as node2) = let node_join f_node_merge f_trace_merge ((trace1, tree1) as node1) ((trace2, tree2) as node2) =
if node1 == node2 if phys_equal node1 node2
then node1 then node1
else else
let trace' = f_trace_merge trace1 trace2 in let trace' = f_trace_merge trace1 trace2 in
@ -163,21 +163,21 @@ module Make (TraceDomain : AbstractDomain.S) = struct
match tree1, tree2 with match tree1, tree2 with
| Subtree subtree1, Subtree subtree2 -> | Subtree subtree1, Subtree subtree2 ->
let tree' = AccessMap.merge (fun _ v1 v2 -> f_node_merge v1 v2) subtree1 subtree2 in let tree' = AccessMap.merge (fun _ v1 v2 -> f_node_merge v1 v2) subtree1 subtree2 in
if trace' == trace1 && tree' == subtree1 if phys_equal trace' trace1 && phys_equal tree' subtree1
then node1 then node1
else if trace' == trace2 && tree' == subtree2 else if phys_equal trace' trace2 && phys_equal tree' subtree2
then node2 then node2
else trace', Subtree tree' else trace', Subtree tree'
| Star, t -> | Star, t ->
(* vacuum up all the traces associated with the subtree t and join them with trace' *) (* vacuum up all the traces associated with the subtree t and join them with trace' *)
let trace'' = join_all_traces trace' t in let trace'' = join_all_traces trace' t in
if trace'' == trace1 if phys_equal trace'' trace1
then node1 then node1
else trace'', Star else trace'', Star
| t, Star -> | t, Star ->
(* same as above, but kind-of duplicated to allow address equality optimization *) (* same as above, but kind-of duplicated to allow address equality optimization *)
let trace'' = join_all_traces trace' t in let trace'' = join_all_traces trace' t in
if trace'' == trace2 if phys_equal trace'' trace2
then node2 then node2
else trace'', Star else trace'', Star
@ -185,9 +185,9 @@ module Make (TraceDomain : AbstractDomain.S) = struct
match node1_opt, node2_opt with match node1_opt, node2_opt with
| Some node1, Some node2 -> | Some node1, Some node2 ->
let joined_node = node_join node_merge TraceDomain.join node1 node2 in let joined_node = node_join node_merge TraceDomain.join node1 node2 in
if joined_node == node1 if phys_equal joined_node node1
then node1_opt then node1_opt
else if joined_node == node2 else if phys_equal joined_node node2
then node2_opt then node2_opt
else Some joined_node else Some joined_node
| None, node_opt | node_opt, None -> | None, node_opt | node_opt, None ->
@ -243,7 +243,7 @@ module Make (TraceDomain : AbstractDomain.S) = struct
add_node ap (make_normal_leaf trace) tree add_node ap (make_normal_leaf trace) tree
let join tree1 tree2 = let join tree1 tree2 =
if tree1 == tree2 if phys_equal tree1 tree2
then tree1 then tree1
else BaseMap.merge (fun _ n1 n2 -> node_merge n1 n2) tree1 tree2 else BaseMap.merge (fun _ n1 n2 -> node_merge n1 n2) tree1 tree2
@ -271,13 +271,13 @@ module Make (TraceDomain : AbstractDomain.S) = struct
then make_starred_leaf trace then make_starred_leaf trace
else else
let subtree' = AccessMap.map node_add_stars subtree in let subtree' = AccessMap.map node_add_stars subtree in
if subtree' == subtree if phys_equal subtree' subtree
then node then node
else trace, Subtree subtree' else trace, Subtree subtree'
| Star -> node | Star -> node
let widen ~prev ~next ~num_iters = let widen ~prev ~next ~num_iters =
if prev == next if phys_equal prev next
then prev then prev
else else
let trace_widen prev next = let trace_widen prev next =
@ -286,14 +286,14 @@ module Make (TraceDomain : AbstractDomain.S) = struct
match prev_node_opt, next_node_opt with match prev_node_opt, next_node_opt with
| Some prev_node, Some next_node -> | Some prev_node, Some next_node ->
let widened_node = node_join node_widen trace_widen prev_node next_node in let widened_node = node_join node_widen trace_widen prev_node next_node in
if widened_node == prev_node if phys_equal widened_node prev_node
then prev_node_opt then prev_node_opt
else if widened_node == next_node else if phys_equal widened_node next_node
then next_node_opt then next_node_opt
else Some widened_node else Some widened_node
| None, Some next_node -> | None, Some next_node ->
let widened_node = node_add_stars next_node in let widened_node = node_add_stars next_node in
if widened_node == next_node if phys_equal widened_node next_node
then next_node_opt then next_node_opt
else Some widened_node else Some widened_node
| Some _, None | None, None -> | Some _, None | None, None ->

@ -53,7 +53,7 @@ module Domain = struct
try CallsDomain.find key call_map try CallsDomain.find key call_map
with Not_found -> CallSiteSet.empty in with Not_found -> CallSiteSet.empty in
let call_set' = CallSiteSet.add call call_set in let call_set' = CallSiteSet.add call call_set in
if call_set' == call_set if phys_equal call_set' call_set
then astate then astate
else NonBottom (CallsDomain.add key call_set' call_map, vars) else NonBottom (CallsDomain.add key call_set' call_map, vars)

@ -21,7 +21,7 @@ module Domain = struct
(* return true if the key-value bindings in [rhs] are a subset of the key-value bindings in (* return true if the key-value bindings in [rhs] are a subset of the key-value bindings in
[lhs] *) [lhs] *)
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
Var.Map.for_all Var.Map.for_all
@ -31,7 +31,7 @@ module Domain = struct
rhs rhs
let join astate1 astate2 = let join astate1 astate2 =
if astate1 == astate2 if phys_equal astate1 astate2
then astate1 then astate1
else else
let keep_if_same _ v1_opt v2_opt = match v1_opt, v2_opt with let keep_if_same _ v1_opt v2_opt = match v1_opt, v2_opt with

@ -155,7 +155,7 @@ let run_plugin_and_frontend source_path frontend clang_args => {
Config.etc_dir Config.etc_dir
biniou_fname biniou_fname
basename; basename;
close_out debug_script_out Out_channel.close debug_script_out
}; };
run_clang clang_command frontend run_clang clang_command frontend
}; };

@ -33,7 +33,7 @@ type curr_class =
[@@deriving compare] [@@deriving compare]
let equal_curr_class curr_class1 curr_class2 = let equal_curr_class curr_class1 curr_class2 =
compare_curr_class curr_class1 curr_class2 == 0 compare_curr_class curr_class1 curr_class2 = 0
type str_node_map = (string, Procdesc.Node.t) Hashtbl.t type str_node_map = (string, Procdesc.Node.t) Hashtbl.t

@ -31,7 +31,7 @@ let parse_ctl_file filename =
let lexbuf = Lexing.from_channel inx in let lexbuf = Lexing.from_channel inx in
lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = fn }; lexbuf.lex_curr_p <- { lexbuf.lex_curr_p with pos_fname = fn };
let _ = parse_with_error lexbuf in let _ = parse_with_error lexbuf in
close_in inx In_channel.close inx
| None -> | None ->
Logging.out "No linters file specified. Nothing to parse.\n" Logging.out "No linters file specified. Nothing to parse.\n"

@ -671,7 +671,7 @@ struct
| Some m when is_cpp_translation translation_unit_context -> m | Some m when is_cpp_translation translation_unit_context -> m
| _ -> "" in | _ -> "" in
let mangled = (Utils.string_crc_hex32 file) ^ mangled_name in let mangled = (Utils.string_crc_hex32 file) ^ mangled_name in
if String.length file == 0 && String.length mangled_name == 0 then if String.length file = 0 && String.length mangled_name = 0 then
Procname.from_string_c_fun name Procname.from_string_c_fun name
else else
Procname.C (Procname.c name mangled) Procname.C (Procname.c name mangled)

@ -67,13 +67,13 @@ let ms_get_return_param_typ { return_param_typ } =
(* it has 1 argument (this includes self) *) (* it has 1 argument (this includes self) *)
let ms_is_getter { pointer_to_property_opt; args } = let ms_is_getter { pointer_to_property_opt; args } =
Option.is_some pointer_to_property_opt && Option.is_some pointer_to_property_opt &&
IList.length args == 1 IList.length args = 1
(* A method is a setter if it has a link to a property and *) (* A method is a setter if it has a link to a property and *)
(* it has 2 argument (this includes self) *) (* it has 2 argument (this includes self) *)
let ms_is_setter { pointer_to_property_opt; args } = let ms_is_setter { pointer_to_property_opt; args } =
Option.is_some pointer_to_property_opt && Option.is_some pointer_to_property_opt &&
IList.length args == 2 IList.length args = 2
let make_ms name args ret_type attributes loc is_instance ?is_cpp_virtual language pointer_to_parent let make_ms name args ret_type attributes loc is_instance ?is_cpp_virtual language pointer_to_parent
pointer_to_property_opt return_param_typ = pointer_to_property_opt return_param_typ =

@ -379,7 +379,7 @@ let get_const_args_indices ~shift args =
(** Creates a procedure description. *) (** Creates a procedure description. *)
let create_local_procdesc trans_unit_ctx cfg tenv ms fbody captured is_objc_inst_method = let create_local_procdesc trans_unit_ctx cfg tenv ms fbody captured is_objc_inst_method =
let defined = not ((IList.length fbody) == 0) in let defined = not ((IList.length fbody) = 0) in
let proc_name = CMethod_signature.ms_get_name ms in let proc_name = CMethod_signature.ms_get_name ms in
let pname = Procname.to_string proc_name in let pname = Procname.to_string proc_name in
let attributes = sil_func_attributes_of_attributes (CMethod_signature.ms_get_attributes ms) in let attributes = sil_func_attributes_of_attributes (CMethod_signature.ms_get_attributes ms) in

@ -28,7 +28,7 @@ struct
let open CContext in let open CContext in
let (selector, method_pointer_opt, mc_type) = let (selector, method_pointer_opt, mc_type) =
CMethod_trans.get_objc_method_data obj_c_message_expr_info in CMethod_trans.get_objc_method_data obj_c_message_expr_info in
let is_instance = mc_type != CMethod_trans.MCStatic in let is_instance = mc_type <> CMethod_trans.MCStatic in
let method_kind = Procname.objc_method_kind_of_bool is_instance in let method_kind = Procname.objc_method_kind_of_bool is_instance in
let ms_opt = let ms_opt =
match method_pointer_opt with match method_pointer_opt with
@ -1631,7 +1631,7 @@ struct
let res_trans_subexpr_list = let res_trans_subexpr_list =
initListExpr_initializers_trans trans_state var_exp 0 stmts typ false stmt_info in initListExpr_initializers_trans trans_state var_exp 0 stmts typ false stmt_info in
let rh_exps = collect_exprs res_trans_subexpr_list in let rh_exps = collect_exprs res_trans_subexpr_list in
if IList.length rh_exps == 0 then if IList.length rh_exps = 0 then
let exps = let exps =
match Sil.zero_value_of_numerical_type_option var_type with match Sil.zero_value_of_numerical_type_option var_type with
| Some zero_exp -> [(zero_exp, typ)] | Some zero_exp -> [(zero_exp, typ)]
@ -1645,7 +1645,7 @@ struct
let i = IList.length lh - IList.length rh_exps in let i = IList.length lh - IList.length rh_exps in
IList.drop_last i lh IList.drop_last i lh
else lh in else lh in
if IList.length rh_exps == IList.length lh then if IList.length rh_exps = IList.length lh then
(* Creating new instructions by assigning right hand side to left hand side expressions *) (* Creating new instructions by assigning right hand side to left hand side expressions *)
let assign_instr (lh_exp, lh_t) (rh_exp, _) = Sil.Store (lh_exp, lh_t, rh_exp, sil_loc) in let assign_instr (lh_exp, lh_t) (rh_exp, _) = Sil.Store (lh_exp, lh_t, rh_exp, sil_loc) in
let assign_instrs = let assign_instrs =

@ -114,7 +114,7 @@ let map_join m1 m2 =
let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in
(t1, ta1', locs1) in (t1, ta1', locs1) in
tjoined := M.add exp1 range1' !tjoined in tjoined := M.add exp1 range1' !tjoined in
if m1 == m2 then m1 if phys_equal m1 m2 then m1
else ( else (
M.iter extend_lhs m2; M.iter extend_lhs m2;
M.iter missing_rhs m1; M.iter missing_rhs m1;
@ -141,17 +141,17 @@ let lookup_pvar pvar typestate =
let add_id id range typestate = let add_id id range typestate =
let map' = M.add (Exp.Var id) range typestate.map in let map' = M.add (Exp.Var id) range typestate.map in
if map' == typestate.map then typestate if phys_equal map' typestate.map then typestate
else { typestate with map = map' } else { typestate with map = map' }
let add pvar range typestate = let add pvar range typestate =
let map' = M.add (Exp.Lvar pvar) range typestate.map in let map' = M.add (Exp.Lvar pvar) range typestate.map in
if map' == typestate.map then typestate if phys_equal map' typestate.map then typestate
else { typestate with map = map' } else { typestate with map = map' }
let remove_id id typestate = let remove_id id typestate =
let map' = M.remove (Exp.Var id) typestate.map in let map' = M.remove (Exp.Var id) typestate.map in
if map' == typestate.map then typestate if phys_equal map' typestate.map then typestate
else { typestate with map = map' } else { typestate with map = map' }
let get_extension typestate = typestate.extension let get_extension typestate = typestate.extension

@ -103,7 +103,7 @@ let read_package_declaration source_file =
| hd::package::[] when hd = "package" -> package | hd::package::[] when hd = "package" -> package
| _ -> loop () | _ -> loop ()
with End_of_file -> with End_of_file ->
close_in file_in; In_channel.close file_in;
empty_package in empty_package in
loop () loop ()
@ -177,7 +177,7 @@ let load_from_verbose_output () =
| JBasics.Class_structure_error _ | JBasics.Class_structure_error _
| Invalid_argument _ -> loop paths roots sources classes | Invalid_argument _ -> loop paths roots sources classes
| End_of_file -> | End_of_file ->
close_in file_in; In_channel.close file_in;
let classpath = let classpath =
IList.fold_left IList.fold_left
append_path append_path

@ -111,7 +111,7 @@ let cache_classname cn =
split [] (Filename.dirname path) in split [] (Filename.dirname path) in
let rec mkdir l p = let rec mkdir l p =
let () = let () =
if (Sys.file_exists p) != `Yes then if (Sys.file_exists p) <> `Yes then
Unix.mkdir p ~perm:493 in Unix.mkdir p ~perm:493 in
match l with match l with
| [] -> () | [] -> ()
@ -119,7 +119,7 @@ let cache_classname cn =
mkdir splitted_root_dir Filename.dir_sep; mkdir splitted_root_dir Filename.dir_sep;
let file_out = open_out(path) in let file_out = open_out(path) in
output_string file_out (string_of_float (Unix.time ())); output_string file_out (string_of_float (Unix.time ()));
close_out file_out Out_channel.close file_out
let is_classname_cached cn = let is_classname_cached cn =
Sys.file_exists (path_of_cached_classname cn) = `Yes Sys.file_exists (path_of_cached_classname cn) = `Yes

@ -15,7 +15,7 @@ open Javalib_pack
module L = Logging module L = Logging
let () = let () =
match Config.models_mode, Sys.file_exists Config.models_jar == `Yes with match Config.models_mode, Sys.file_exists Config.models_jar = `Yes with
| true, false -> | true, false ->
() ()
| false, false -> | false, false ->

@ -48,14 +48,14 @@ module Make (TaintSpecification : TaintSpec.S) = struct
{ access_tree; id_map; } { access_tree; id_map; }
let (<=) ~lhs ~rhs = let (<=) ~lhs ~rhs =
if lhs == rhs if phys_equal lhs rhs
then true then true
else else
TaintDomain.(<=) ~lhs:lhs.access_tree ~rhs:rhs.access_tree && TaintDomain.(<=) ~lhs:lhs.access_tree ~rhs:rhs.access_tree &&
IdMapDomain.(<=) ~lhs:lhs.id_map ~rhs:rhs.id_map IdMapDomain.(<=) ~lhs:lhs.id_map ~rhs:rhs.id_map
let join astate1 astate2 = let join astate1 astate2 =
if astate1 == astate2 if phys_equal astate1 astate2
then astate1 then astate1
else else
let access_tree = TaintDomain.join astate1.access_tree astate2.access_tree in let access_tree = TaintDomain.join astate1.access_tree astate2.access_tree in
@ -63,7 +63,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct
{ access_tree; id_map; } { access_tree; id_map; }
let widen ~prev ~next ~num_iters = let widen ~prev ~next ~num_iters =
if prev == next if phys_equal prev next
then prev then prev
else else
let access_tree = let access_tree =
@ -281,7 +281,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct
let output_trace = TaintSpecification.of_summary_trace in_out_summary.output_trace in let output_trace = TaintSpecification.of_summary_trace in_out_summary.output_trace in
let appended_trace = TraceDomain.append in_trace output_trace callee_site in let appended_trace = TraceDomain.append in_trace output_trace callee_site in
let joined_trace = TraceDomain.join caller_trace appended_trace in let joined_trace = TraceDomain.join caller_trace appended_trace in
if appended_trace == joined_trace if phys_equal appended_trace joined_trace
then then
access_tree access_tree
else else

@ -26,7 +26,7 @@ module MockTraceDomain = struct
(* stop others from creating top by accident, adding to top, or removing it *) (* stop others from creating top by accident, adding to top, or removing it *)
let add e s = let add e s =
assert (e <> top_str); assert (e <> top_str);
if s == top if phys_equal s top
then top then top
else add e s else add e s
@ -43,7 +43,7 @@ module MockTraceDomain = struct
(* similarly, hack printing so top looks different *) (* similarly, hack printing so top looks different *)
let pp fmt s = let pp fmt s =
if s == top if phys_equal s top
then F.fprintf fmt "T" then F.fprintf fmt "T"
else pp fmt s else pp fmt s
end end

@ -61,15 +61,15 @@ let tests =
begin begin
match ProcCfg.Normal.instrs n1 with match ProcCfg.Normal.instrs n1 with
| [instr1; instr2] -> | [instr1; instr2] ->
assert_bool "First instr should be dummy_instr1" (instr1 == dummy_instr1); assert_bool "First instr should be dummy_instr1" (phys_equal instr1 dummy_instr1);
assert_bool "Second instr should be dummy_instr2" (instr2 == dummy_instr2); assert_bool "Second instr should be dummy_instr2" (phys_equal instr2 dummy_instr2);
| _ -> assert_failure "Expected exactly two instructions" | _ -> assert_failure "Expected exactly two instructions"
end; end;
begin begin
match BackwardCfg.instrs n1 with match BackwardCfg.instrs n1 with
| [instr1; instr2] -> | [instr1; instr2] ->
assert_bool "First instr should be dummy_instr2" (instr1 == dummy_instr2); assert_bool "First instr should be dummy_instr2" (phys_equal instr1 dummy_instr2);
assert_bool "Second instr should be dummy_instr1" (instr2 == dummy_instr1); assert_bool "Second instr should be dummy_instr1" (phys_equal instr2 dummy_instr1);
| _ -> assert_failure "Expected exactly two instructions" | _ -> assert_failure "Expected exactly two instructions"
end; end;
begin begin
@ -77,10 +77,10 @@ let tests =
match InstrCfg.instr_ids n1 with match InstrCfg.instr_ids n1 with
| [ (instr1, Some (id1, ProcCfg.Instr_index 0)); | [ (instr1, Some (id1, ProcCfg.Instr_index 0));
(instr2, Some (id2, ProcCfg.Instr_index 1)); ] -> (instr2, Some (id2, ProcCfg.Instr_index 1)); ] ->
assert_bool "First instr should be dummy_instr1" (instr1 == dummy_instr1); assert_bool "First instr should be dummy_instr1" (phys_equal instr1 dummy_instr1);
assert_bool "Second instr should be dummy_instr2" (instr2 == dummy_instr2); assert_bool "Second instr should be dummy_instr2" (phys_equal instr2 dummy_instr2);
assert_bool "id1 should be id of underlying node" (id1 == node_id); assert_bool "id1 should be id of underlying node" (phys_equal id1 node_id);
assert_bool "id2 should be id of underlying node" (id2 == node_id); assert_bool "id2 should be id of underlying node" (phys_equal id2 node_id);
| _ -> assert_failure "Expected exactly two instructions with correct indices" | _ -> assert_failure "Expected exactly two instructions with correct indices"
end; end;
let backward_node_id, _ = BackwardInstrCfg.id n1 in let backward_node_id, _ = BackwardInstrCfg.id n1 in
@ -88,10 +88,10 @@ let tests =
match BackwardInstrCfg.instr_ids n1 with match BackwardInstrCfg.instr_ids n1 with
| [ (instr1, Some (id1, ProcCfg.Instr_index 1)); | [ (instr1, Some (id1, ProcCfg.Instr_index 1));
(instr2, Some (id2, ProcCfg.Instr_index 0)); ] -> (instr2, Some (id2, ProcCfg.Instr_index 0)); ] ->
assert_bool "First instr should be dummy_instr2" (instr1 == dummy_instr2); assert_bool "First instr should be dummy_instr2" (phys_equal instr1 dummy_instr2);
assert_bool "Second instr should be dummy_instr1" (instr2 == dummy_instr1); assert_bool "Second instr should be dummy_instr1" (phys_equal instr2 dummy_instr1);
assert_bool "id1 should be id of underlying node" (id1 == backward_node_id); assert_bool "id1 should be id of underlying node" (phys_equal id1 backward_node_id);
assert_bool "id2 should be id of underlying node" (id2 == backward_node_id); assert_bool "id2 should be id of underlying node" (phys_equal id2 backward_node_id);
| _ -> assert_failure "Expected exactly two instructions with correct indices" | _ -> assert_failure "Expected exactly two instructions with correct indices"
end; end;
assert_bool assert_bool

Loading…
Cancel
Save