[BetterEngineering] Replace uses of polymorphic equality

Reviewed By: jberdine

Differential Revision: D4435833

fbshipit-source-id: 4e3d14e
master
Cristiano Calcagno 8 years ago committed by Facebook Github Bot
parent cceffddd78
commit f91b3128d3

@ -45,6 +45,7 @@ let module Item = {
/* type nonrec t = list (t, bool) [@@deriving compare]; */
type _t = list (t, bool) [@@deriving compare];
type t = _t [@@deriving compare];
let equal = [%compare.equal : t];
/** Pretty print an item annotation. */
let pp fmt ann => {
@ -60,7 +61,7 @@ let module Item = {
let empty = [];
/** Check if the item annodation is empty. */
let is_empty ia => ia == [];
let is_empty ia => List.is_empty ia;
};
let module Class = {

@ -38,6 +38,7 @@ let module Item: {
/** Annotation for one item: a list of annotations with visibility. */
type nonrec t = list (t, bool) [@@deriving compare];
let equal: t => t => bool;
/** Pretty print an item annotation. */
let pp: F.formatter => t => unit;

@ -8,6 +8,8 @@
*/
open! IStd;
open! PVariant;
let module Hashtbl = Caml.Hashtbl;
let module F = Format;
@ -49,7 +51,7 @@ let load_attr defined_only::defined_only proc_name => {
res_dir_attr_filename defined::defined proc_name
);
let attr = Serialization.from_file serializer (attributes_file defined::true proc_name);
if (attr == None && defined_only == false) {
if (is_none attr && not defined_only) {
Serialization.from_file serializer (attributes_file defined::false proc_name)
} else {
attr
@ -101,7 +103,7 @@ let load_attributes proc_name =>
switch proc_attributes {
| Some attrs =>
Procname.Hash.add attr_tbl proc_name proc_attributes;
if (attrs.is_defined == true) {
if attrs.is_defined {
Procname.Hash.add defined_attr_tbl proc_name proc_attributes
}
| None => ()

@ -45,7 +45,7 @@ type t =
| PtrFld /** field offset via pointer to field: takes the address of a Csu.t and a Cptr_to_fld constant to form an Lfield expression (see prop.ml) */
[@@deriving compare];
let equal o1 o2 => compare o1 o2 == 0;
let equal = [%compare.equal : t];
/** This function returns true if the operation is injective

@ -18,8 +18,7 @@ type t =
}
[@@deriving compare]
let equal t1 t2 =
compare t1 t2 = 0
let equal = [%compare.equal : t]
let pname t =
t.pname

@ -91,18 +91,19 @@ let check_cfg_connectedness cfg => {
let succs = Procdesc.Node.get_succs n;
let preds = Procdesc.Node.get_preds n;
switch (Procdesc.Node.get_kind n) {
| Procdesc.Node.Start_node _ => IList.length succs == 0 || IList.length preds > 0
| Procdesc.Node.Exit_node _ => IList.length succs > 0 || IList.length preds == 0
| Procdesc.Node.Start_node _ => Int.equal (IList.length succs) 0 || IList.length preds > 0
| Procdesc.Node.Exit_node _ => IList.length succs > 0 || Int.equal (IList.length preds) 0
| Procdesc.Node.Stmt_node _
| Procdesc.Node.Prune_node _
| Procdesc.Node.Skip_node _ => IList.length succs == 0 || IList.length preds == 0
| Procdesc.Node.Skip_node _ =>
Int.equal (IList.length succs) 0 || Int.equal (IList.length preds) 0
| Procdesc.Node.Join_node =>
/* Join node has the exception that it may be without predecessors
and pointing to an exit node */
/* if the if brances end with a return */
switch succs {
| [n'] when is_exit_node n' => false
| _ => IList.length preds == 0
| _ => Int.equal (IList.length preds) 0
}
}
};
@ -183,11 +184,15 @@ let inline_synthetic_method ret_id etl pdesc loc_call :option Sil.instr => {
let instr' = Sil.Store (Exp.Lfield (Exp.Lvar pvar) fn ft) bt e1 loc_call;
found instr instr'
| (Sil.Call ret_id' (Exp.Const (Const.Cfun pn)) etl' _ cf, _, _)
when ret_id == None == (ret_id' == None) && IList.length etl' == IList.length etl =>
when
Bool.equal (is_none ret_id) (is_none ret_id') &&
Int.equal (IList.length etl') (IList.length etl) =>
let instr' = Sil.Call ret_id (Exp.Const (Const.Cfun pn)) etl loc_call cf;
found instr instr'
| (Sil.Call ret_id' (Exp.Const (Const.Cfun pn)) etl' _ cf, _, _)
when ret_id == None == (ret_id' == None) && IList.length etl' + 1 == IList.length etl =>
when
Bool.equal (is_none ret_id) (is_none ret_id') &&
Int.equal (IList.length etl' + 1) (IList.length etl) =>
let etl1 =
switch (IList.rev etl) {
/* remove last element */
@ -286,7 +291,7 @@ let mark_unchanged_pdescs cfg_new cfg_old => {
)
instrs1
instrs2;
compare_id n1 n2 == 0 &&
Int.equal (compare_id n1 n2) 0 &&
IList.equal Procdesc.Node.compare (Procdesc.Node.get_succs n1) (Procdesc.Node.get_succs n2) &&
IList.equal Procdesc.Node.compare (Procdesc.Node.get_preds n1) (Procdesc.Node.get_preds n2) &&
instrs_eq (Procdesc.Node.get_instrs n1) (Procdesc.Node.get_instrs n2)
@ -297,7 +302,7 @@ let mark_unchanged_pdescs cfg_new cfg_old => {
};
let att1 = Procdesc.get_attributes pd1
and att2 = Procdesc.get_attributes pd2;
att1.is_defined == att2.is_defined &&
Bool.equal att1.is_defined att2.is_defined &&
Typ.equal att1.ret_type att2.ret_type &&
formals_eq att1.formals att2.formals &&
nodes_eq (Procdesc.get_nodes pd1) (Procdesc.get_nodes pd2)

@ -27,7 +27,7 @@ type t =
| Cptr_to_fld Ident.fieldname Typ.t /** pointer to field constant, and type of the surrounding Csu.t type */
[@@deriving compare];
let equal c1 c2 => compare c1 c2 == 0;
let equal = [%compare.equal : t];
let kind_equal c1 c2 => {
let const_kind_number =
@ -38,7 +38,7 @@ let kind_equal c1 c2 => {
| Cfloat _ => 4
| Cclass _ => 5
| Cptr_to_fld _ => 6;
const_kind_number c1 == const_kind_number c2
Int.equal (const_kind_number c1) (const_kind_number c2)
};
let pp pe f =>

@ -18,6 +18,8 @@ type class_kind =
| Objc
[@@deriving compare];
let equal_class_kind = [%compare.equal : class_kind];
type t =
| Class class_kind
| Struct
@ -32,4 +34,4 @@ let name =
| Union => "union"
| Protocol => "protocol";
let equal tn1 tn2 => compare tn1 tn2 == 0;
let equal = [%compare.equal : t];

@ -18,6 +18,8 @@ type class_kind =
| Objc
[@@deriving compare];
let equal_class_kind: class_kind => class_kind => bool;
type t =
| Class class_kind
| Struct

@ -40,7 +40,7 @@ type t =
each expression represents a path, with Dpvar being the simplest one */
type vpath = option t;
let java () => !Config.curr_language == Config.Java;
let java () => Config.equal_language !Config.curr_language Config.Java;
let eradicate_java () => Config.eradicate && java ();
@ -145,7 +145,7 @@ let pp_vpath pe fmt vpath => {
fun
| Some de => pp fmt de
| None => ();
if (pe.Pp.kind == Pp.HTML) {
if (Pp.equal_print_kind pe.Pp.kind Pp.HTML) {
F.fprintf
fmt
" %a{vpath: %a}%a"

@ -30,7 +30,7 @@ type loc_trace = loc_trace_elem list
(** Data associated to a specific error *)
type err_data =
(int * int) * int * Location.t * L.ml_loc option * loc_trace *
Exceptions.err_class * Exceptions.exception_visibility
Exceptions.err_class * Exceptions.visibility
let compare_err_data
(_, _, loc1, _, _, _, _)
@ -50,13 +50,16 @@ module ErrLogHash = struct
type t = Exceptions.err_kind * bool * Localise.t * Localise.error_desc * string
[@@deriving compare]
(* NOTE: changing the hash function can change the order in which issues are reported. *)
let hash (ekind, in_footprint, err_name, desc, _) =
Hashtbl.hash (ekind, in_footprint, err_name, Localise.error_desc_hash desc)
let equal
(ekind1, in_footprint1, err_name1, desc1, _)
(ekind2, in_footprint2, err_name2, desc2, _) =
(ekind1, in_footprint1, err_name1) = (ekind2, in_footprint2, err_name2) &&
[%compare.equal : Exceptions.err_kind * bool * Localise.t]
(ekind1, in_footprint1, err_name1)
(ekind2, in_footprint2, err_name2) &&
Localise.error_desc_equal desc1 desc2
end
@ -85,7 +88,7 @@ type iter_fun =
Localise.t -> Localise.error_desc -> string ->
loc_trace ->
Exceptions.err_class ->
Exceptions.exception_visibility ->
Exceptions.visibility ->
unit
(** Apply f to nodes and error names *)
@ -109,14 +112,14 @@ let size filter (err_log: t) =
(** Print errors from error log *)
let pp_errors fmt (errlog : t) =
let f (ekind, _, ename, _, _) _ =
if ekind = Exceptions.Kerror then
if Exceptions.equal_err_kind ekind Exceptions.Kerror then
F.fprintf fmt "%a@ " Localise.pp ename in
ErrLogHash.iter f errlog
(** Print warnings from error log *)
let pp_warnings fmt (errlog : t) =
let f (ekind, _, ename, desc, _) _ =
if ekind = Exceptions.Kwarning then
if Exceptions.equal_err_kind ekind Exceptions.Kwarning then
F.fprintf fmt "%a %a@ " Localise.pp ename Localise.pp_error_desc desc in
ErrLogHash.iter f errlog
@ -128,7 +131,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
ErrDataSet.iter (pp_nodeid_session_loc fmt) eds in
let f do_fp ek (ekind, infp, err_name, desc, _) eds =
if ekind = ek && do_fp = infp
if Exceptions.equal_err_kind ekind ek && Bool.equal do_fp infp
then
F.fprintf fmt "<br>%a %a %a"
Localise.pp err_name
@ -186,17 +189,18 @@ let log_issue _ekind err_log loc node_id_key session ltr exn =
| Some ekind -> ekind
| _ -> _ekind in
let hide_java_loc_zero = (* hide java errors at location zero unless in -developer_mode *)
Config.developer_mode = false &&
!Config.curr_language = Config.Java &&
loc.Location.line = 0 in
not Config.developer_mode &&
Config.curr_language_is Config.Java &&
Int.equal loc.Location.line 0 in
let hide_memory_error =
match Localise.error_desc_get_bucket desc with
| Some bucket when bucket = Mleak_buckets.ml_bucket_unknown_origin ->
| Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin ->
not Mleak_buckets.should_raise_leak_unknown_origin
| _ -> false in
let log_it =
visibility = Exceptions.Exn_user ||
(Config.developer_mode && visibility = Exceptions.Exn_developer) in
Exceptions.equal_visibility visibility Exceptions.Exn_user ||
(Config.developer_mode &&
Exceptions.equal_visibility visibility Exceptions.Exn_developer) in
if log_it && not hide_java_loc_zero && not hide_memory_error then begin
let added =
add_issue err_log
@ -246,7 +250,8 @@ module Err_table = struct
let count = try String.Map.find_exn !err_name_map err_string with Not_found -> 0 in
err_name_map := String.Map.add ~key:err_string ~data:(count + n) !err_name_map in
let count (ekind', in_footprint, err_name, _, _) eds =
if ekind = ekind' && in_footprint then count_err err_name (ErrDataSet.cardinal eds) in
if Exceptions.equal_err_kind ekind ekind' && in_footprint
then count_err err_name (ErrDataSet.cardinal eds) in
ErrLogHash.iter count err_table;
let pp ~key:err_string ~data:count = F.fprintf fmt " %s:%d" err_string count in
String.Map.iteri ~f:pp !err_name_map
@ -309,7 +314,7 @@ let extend_table err_table err_log =
(** Size of the global per-file error table for the footprint phase *)
let err_table_size_footprint ekind =
let filter ekind' in_footprint = ekind = ekind' && in_footprint in
let filter ekind' in_footprint = Exceptions.equal_err_kind ekind ekind' && in_footprint in
Err_table.table_size filter
(** Print stats for the global per-file error table *)

@ -41,7 +41,7 @@ type iter_fun =
Localise.t -> Localise.error_desc -> string ->
loc_trace ->
Exceptions.err_class ->
Exceptions.exception_visibility ->
Exceptions.visibility ->
unit
(** Apply f to nodes and error names *)

@ -14,29 +14,36 @@ module L = Logging
module F = Format
(** visibility of the exception *)
type exception_visibility =
type visibility =
| Exn_user (** always add to error log *)
| Exn_developer (** only add to error log in developer mode *)
| Exn_system (** never add to error log *)
[@@deriving compare]
let string_of_exception_visibility vis =
let equal_visibility = [%compare.equal : visibility]
let string_of_visibility vis =
match vis with
| Exn_user -> "user"
| Exn_developer -> "developer"
| Exn_system -> "system"
(** severity of bugs *)
type exception_severity =
type severity =
| High (* high severity bug *)
| Medium (* medium severity bug *)
| Low (* low severity bug *)
(** class of error *)
type err_class = Checker | Prover | Nocat | Linters
(** class of error/warning *)
type err_class = Checker | Prover | Nocat | Linters [@@deriving compare]
let equal_err_class = [%compare.equal : err_class]
(** kind of error/warning *)
type err_kind = Kwarning | Kerror | Kinfo | Kadvice [@@deriving compare]
let equal_err_kind = [%compare.equal : err_kind]
exception Abduction_case_not_implemented of L.ml_loc
exception Analysis_stops of Localise.error_desc * L.ml_loc option
exception Array_out_of_bounds_l1 of Localise.error_desc * L.ml_loc
@ -67,7 +74,7 @@ exception Inherently_dangerous_function of Localise.error_desc
exception Internal_error of Localise.error_desc
exception Java_runtime_exception of Typename.t * string * Localise.error_desc
exception Leak of
bool * Sil.hpred * (exception_visibility * Localise.error_desc)
bool * Sil.hpred * (visibility * Localise.error_desc)
* bool * PredSymb.resource * L.ml_loc
exception Missing_fld of Ident.fieldname * L.ml_loc
exception Premature_nil_termination of Localise.error_desc * L.ml_loc
@ -333,7 +340,7 @@ let print_key = false
(** pretty print an error given its (id,key), location, kind, name, description, and optional ml location *)
let pp_err (_, node_key) loc ekind ex_name desc ml_loc_opt fmt () =
let kind = err_kind_string (if ekind = Kinfo then Kwarning else ekind) (* eclipse does not know about infos: treat as warning *) in
let kind = err_kind_string (if equal_err_kind ekind Kinfo then Kwarning else ekind) in
let pp_key fmt k = if print_key then F.fprintf fmt " key: %d " k else () in
F.fprintf fmt "%a:%d: %s: %a %a%a%a@\n"
SourceFile.pp loc.Location.file
@ -347,4 +354,5 @@ 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 *)
let handle_exception exn =
let _, _, _, visibility, _, _, _ = recognize_exception exn in
visibility = Exn_user || visibility = Exn_developer
equal_visibility visibility Exn_user ||
equal_visibility visibility Exn_developer

@ -13,15 +13,18 @@ open! IStd
(** Functions for logging and printing exceptions *)
(** visibility of the exception *)
type exception_visibility =
type visibility =
| Exn_user (** always add to error log *)
| Exn_developer (** only add to error log in developer mode *)
| Exn_system (** never add to error log *)
[@@deriving compare]
val string_of_exception_visibility : exception_visibility -> string
val equal_visibility : visibility -> visibility -> bool
val string_of_visibility : visibility -> string
(** severity of bugs *)
type exception_severity =
type severity =
| High (** high severity bug *)
| Medium (** medium severity bug *)
| Low (** low severity bug *)
@ -29,9 +32,13 @@ type exception_severity =
(** kind of error/warning *)
type err_kind = Kwarning | Kerror | Kinfo | Kadvice [@@deriving compare]
val equal_err_kind : err_kind -> err_kind -> bool
(** class of error *)
type err_class = Checker | Prover | Nocat | Linters
val equal_err_class : err_class -> err_class -> bool
exception Abduction_case_not_implemented of Logging.ml_loc
exception Analysis_stops of Localise.error_desc * Logging.ml_loc option
exception Array_of_pointsto of Logging.ml_loc
@ -62,7 +69,7 @@ exception Inherently_dangerous_function of Localise.error_desc
exception Internal_error of Localise.error_desc
exception Java_runtime_exception of Typename.t * string * Localise.error_desc
exception Leak of
bool * Sil.hpred * (exception_visibility * Localise.error_desc)
bool * Sil.hpred * (visibility * Localise.error_desc)
* bool * PredSymb.resource * Logging.ml_loc
exception Missing_fld of Ident.fieldname * Logging.ml_loc
exception Premature_nil_termination of Localise.error_desc * Logging.ml_loc
@ -109,5 +116,5 @@ val pp_err : int * int -> Location.t -> err_kind -> Localise.t -> Localise.error
(** Turn an exception into an error name, error description,
location in ml source, and category *)
val recognize_exception : exn ->
(Localise.t * Localise.error_desc * (Logging.ml_loc option) * exception_visibility *
exception_severity * err_kind option * err_class)
(Localise.t * Localise.error_desc * (Logging.ml_loc option) * visibility *
severity * err_kind option * err_class)

@ -57,7 +57,7 @@ and t =
the [dynamic_length] is that of the final extensible array, if any. */
| Sizeof Typ.t dynamic_length Subtype.t;
let equal e1 e2 => compare e1 e2 == 0;
let equal = [%compare.equal : t];
let hash = Hashtbl.hash;

@ -40,7 +40,7 @@ let module Name = {
| Footprint => footprint
| Spec => spec
| FromString s => s;
let equal n1 n2 => compare n1 n2 == 0;
let equal = [%compare.equal : t];
};
type name = Name.t [@@deriving compare];
@ -49,11 +49,11 @@ let name_spec = Name.Spec;
let name_primed = Name.Primed;
let equal_name x y => 0 == compare_name x y;
let equal_name = [%compare.equal : name];
type fieldname = {fpos: int, fname: Mangled.t} [@@deriving compare];
let equal_fieldname x y => 0 == compare_fieldname x y;
let equal_fieldname = [%compare.equal : fieldname];
type kind =
| KNone
@ -70,7 +70,7 @@ let knormal = KNormal;
let kprimed = KPrimed;
let equal_kind x y => 0 == compare_kind x y;
let equal_kind = [%compare.equal : kind];
/* timestamp for a path identifier */
let path_ident_stamp = (-3);
@ -78,7 +78,8 @@ let path_ident_stamp = (-3);
type t = {kind: kind, name: Name.t, stamp: int} [@@deriving compare];
/* 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 =>
Int.equal i1.stamp i2.stamp && equal_kind i1.kind i2.kind && equal_name i1.name i2.name;
/** {2 Set for identifiers} */
@ -254,9 +255,11 @@ let name_return = Mangled.from_string "return";
/** Return the standard name for the given kind */
let standard_name kind =>
if (kind == KNormal || kind == KNone) {
if (equal_kind kind KNormal || equal_kind kind KNone) {
Name.Normal
} else if (kind == KFootprint) {
} else if (
equal_kind kind KFootprint
) {
Name.Footprint
} else {
Name.Primed
@ -297,20 +300,22 @@ let create_footprint name stamp => create_with_stamp KFootprint name stamp;
/** Get a name of an identifier */
let get_name id => id.name;
let is_primed (id: t) => id.kind == KPrimed;
let has_kind id kind => equal_kind id.kind kind;
let is_normal (id: t) => id.kind == KNormal || id.kind == KNone;
let is_primed (id: t) => has_kind id KPrimed;
let is_footprint (id: t) => id.kind == KFootprint;
let is_normal (id: t) => has_kind id KNormal || has_kind id KNone;
let is_none (id: t) => id.kind == KNone;
let is_footprint (id: t) => has_kind id KFootprint;
let is_path (id: t) => id.kind == KNormal && id.stamp == path_ident_stamp;
let is_none (id: t) => has_kind id KNone;
let is_path (id: t) => has_kind id KNormal && Int.equal id.stamp path_ident_stamp;
let make_unprimed id =>
if (id.kind != KPrimed) {
if (not (has_kind id KPrimed)) {
assert false
} else if (id.kind == KNone) {
} else if (has_kind id KNone) {
{...id, kind: KNone}
} else {
{...id, kind: KNormal}
@ -333,14 +338,14 @@ let create_path pathstring =>
/** Convert an identifier to a string. */
let to_string id =>
if (id.kind == KNone) {
if (has_kind id KNone) {
"_"
} else {
let base_name = name_to_string id.name;
let prefix =
if (id.kind == KFootprint) {
if (has_kind id KFootprint) {
"@"
} else if (id.kind == KNormal) {
} else if (has_kind id KNormal) {
""
} else {
"_"
@ -372,9 +377,9 @@ let pp pe f id =>
| LATEX =>
let base_name = name_to_string id.name;
let style =
if (id.kind == KFootprint) {
if (has_kind id KFootprint) {
Latex.Boldface
} else if (id.kind == KNormal) {
} else if (has_kind id KNormal) {
Latex.Roman
} else {
Latex.Roman

@ -28,7 +28,7 @@ let area u i =>
};
let to_signed (unsigned, i, ptr) =>
if (area unsigned i == 3) {
if (Int.equal (area unsigned i) 3) {
None
} else {
Some
@ -42,7 +42,7 @@ let compare (unsigned1, i1, _) (unsigned2, i2, _) =>
let compare_value (unsigned1, i1, _) (unsigned2, i2, _) =>
[%compare : (int, Int64.t)] (area unsigned1 i1, i1) (area unsigned2 i2, i2);
let eq i1 i2 => compare_value i1 i2 == 0;
let eq i1 i2 => Int.equal (compare_value i1 i2) 0;
let neq i1 i2 => compare_value i1 i2 != 0;
@ -74,13 +74,13 @@ let two = of_int 2;
let minus_one = of_int (-1);
let isone (_, i, _) => i == 1L;
let isone (_, i, _) => Int64.equal i 1L;
let iszero (_, i, _) => i == 0L;
let iszero (_, i, _) => Int64.equal i 0L;
let isnull (_, i, ptr) => i == 0L && ptr;
let isnull (_, i, ptr) => Int64.equal i 0L && ptr;
let isminusone (unsigned, i, _) => not unsigned && i == (-1L);
let isminusone (unsigned, i, _) => not unsigned && Int64.equal i (-1L);
let isnegative (unsigned, i, _) => not unsigned && i < 0L;
@ -113,7 +113,7 @@ let lognot i => lift1 Int64.bit_not i;
let sub i1 i2 => add i1 (neg i2);
let pp f (unsigned, n, ptr) =>
if (ptr && n == 0L) {
if (ptr && Int64.equal n 0L) {
F.fprintf f "null"
} else if unsigned {
F.fprintf f "%Lu" n

@ -190,7 +190,7 @@ struct
(** Print an html link to the given node. *)
let pp_node_link path_to_root pname ~description ~preds ~succs ~exn ~isvisited ~isproof fmt id =
let display_name =
(if description = "" then "N" else String.sub description ~pos:0 ~len:1)
(if String.equal description "" then "N" else String.sub description ~pos:0 ~len:1)
^ "_"
^ (string_of_int id) in
let node_fname = node_filename pname id in
@ -313,8 +313,8 @@ struct
(** print an xml node *)
let rec pp_node newline indent fmt = function
| Tree { name = name; attributes = attributes; forest = forest } ->
let indent' = if newline = "" then "" else indent ^ " " in
let space = if attributes = [] then "" else " " in
let indent' = if String.equal newline "" then "" else indent ^ " " in
let space = if List.is_empty attributes then "" else " " in
let pp_inside fmt () = match forest with
| [] ->
()

@ -17,8 +17,7 @@ module F = Format
(** type of string used for localisation *)
type t = string [@@deriving compare]
let equal s1 s2 =
compare s1 s2 = 0
let equal = [%compare.equal : t]
(** pretty print a localised string *)
let pp fmt s = Format.fprintf fmt "%s" s
@ -144,7 +143,7 @@ module Tags = struct
(tag, value) :: tags'
let get tags tag =
try
let (_, v) = IList.find (fun (t, _) -> t = tag) tags in
let (_, v) = IList.find (fun (t, _) -> String.equal t tag) tags in
Some v
with Not_found -> None
end
@ -162,7 +161,7 @@ end
let error_desc_extract_tag_value err_desc tag_to_extract =
let find_value tag v =
match v with
| (t, _) when t = tag -> true
| (t, _) when String.equal t tag -> true
| _ -> false in
try
let _, s = IList.find (find_value tag_to_extract) err_desc.tags in
@ -186,15 +185,15 @@ let error_desc_set_bucket err_desc bucket show_in_message =
let tags' = Tags.update err_desc.tags Tags.bucket bucket in
let l = err_desc.descriptions in
let l' =
if show_in_message = false then l
if not show_in_message then l
else ("[" ^ bucket ^ "]") :: l in
{ err_desc with descriptions = l'; tags = tags' }
(** get the value tag, if any *)
let get_value_line_tag tags =
try
let value = snd (IList.find (fun (_tag, _) -> _tag = Tags.value) tags) in
let line = snd (IList.find (fun (_tag, _) -> _tag = Tags.line) tags) in
let value = snd (IList.find (fun (tag, _) -> String.equal tag Tags.value) tags) in
let line = snd (IList.find (fun (tag, _) -> String.equal tag Tags.line) tags) in
Some [value; line]
with Not_found -> None
@ -209,7 +208,10 @@ let error_desc_hash desc =
Hashtbl.hash (desc_get_comparable desc)
(** equality for error_desc *)
let error_desc_equal desc1 desc2 = (desc_get_comparable desc1) = (desc_get_comparable desc2)
let error_desc_equal desc1 desc2 =
[%compare.equal : string list]
(desc_get_comparable desc1)
(desc_get_comparable desc2)
let _line_tag tags tag loc =
let line_str = string_of_int loc.Location.line in
@ -244,7 +246,7 @@ let by_call_to_ra tags ra =
"by " ^ call_to_at_line tags ra.PredSymb.ra_pname ra.PredSymb.ra_loc
let rec format_typ = function
| Typ.Tptr (typ, _) when !Config.curr_language = Config.Java ->
| Typ.Tptr (typ, _) when Config.curr_language_is Config.Java ->
format_typ typ
| Typ.Tstruct name ->
Typename.name name
@ -252,7 +254,7 @@ let rec format_typ = function
Typ.to_string typ
let format_field f =
if !Config.curr_language = Config.Java
if Config.curr_language_is Config.Java
then Ident.java_fieldname_get_field f
else Ident.fieldname_to_string f
@ -276,7 +278,7 @@ type deref_str =
problem_str: string; (** description of the problem *) }
let pointer_or_object () =
if !Config.curr_language = Config.Java then "object" else "pointer"
if Config.curr_language_is Config.Java then "object" else "pointer"
let _deref_str_null proc_name_opt _problem_str tags =
let problem_str = match proc_name_opt with
@ -424,7 +426,7 @@ let desc_context_leak pname context_typ fieldname leak_path : error_desc =
let context_str = Typ.to_string context_typ in
let path_str =
let path_prefix =
if leak_path = [] then "Leaked "
if List.is_empty leak_path then "Leaked "
else (IList.fold_left leak_path_entry_to_str "" leak_path) ^ " Leaked " in
path_prefix ^ context_str in
let preamble =
@ -506,14 +508,18 @@ let dereference_string deref_str value_str access_opt loc =
| Some Initialized_automatically ->
["initialized automatically"] in
let problem_desc =
let nullable_text = if !Config.curr_language = Config.Java then "@Nullable" else "__nullable" in
let nullable_text =
if Config.curr_language_is Config.Java
then "@Nullable"
else "__nullable" in
let problem_str =
match Tags.get !tags Tags.nullable_src, Tags.get !tags Tags.weak_captured_var_src with
| Some nullable_src, _ ->
if nullable_src = value_str then "is annotated with " ^ nullable_text ^ " and is dereferenced without a null check"
if String.equal nullable_src value_str
then "is annotated with " ^ nullable_text ^ " and is dereferenced without a null check"
else "is indirectly marked " ^ nullable_text ^ " (source: " ^ nullable_src ^ ") and is dereferenced without a null check"
| None, Some weak_var_str ->
if weak_var_str = value_str then
if String.equal weak_var_str value_str then
"is a weak pointer captured in the block and is dereferenced without a null check"
else "is equal to the variable " ^ weak_var_str ^
", a weak pointer captured in the block, and is dereferenced without a null check"
@ -545,7 +551,7 @@ let parameter_field_not_null_checked_desc (desc : error_desc) exp =
| _ -> desc
let has_tag (desc : error_desc) tag =
IList.exists (fun (tag', _) -> tag = tag') desc.tags
IList.exists (fun (tag', _) -> String.equal tag tag') desc.tags
let is_parameter_not_null_checked_desc desc = has_tag desc Tags.parameter_not_null_checked
@ -594,7 +600,7 @@ let desc_condition_always_true_false i cond_str_opt loc =
Tags.add tags Tags.value value;
let description = Format.sprintf
"Boolean condition %s is always %s %s"
(if value = "" then "" else " " ^ value)
(if String.equal value "" then "" else " " ^ value)
tt_ff
(at_line tags loc) in
{ no_desc with descriptions = [description]; tags = !tags }
@ -692,8 +698,8 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc
| Some PredSymb.Rfile -> "resource" ^ typ_str ^ "acquired" ^ _to ^ value_str
| Some PredSymb.Rlock -> lock_acquired ^ _on ^ value_str
| Some PredSymb.Rignore
| None -> if value_str_opt = None then "memory" else value_str in
if desc_str = "" then [] else [desc_str] in
| None -> if is_none value_str_opt then "memory" else value_str in
if String.equal desc_str "" then [] else [desc_str] in
let by_call_to = match resource_action_opt with
| Some ra -> [(by_call_to_ra tags ra)]
| None -> [] in

@ -21,7 +21,7 @@ type t = {
}
[@@deriving compare];
let equal loc1 loc2 => compare loc1 loc2 == 0;
let equal = [%compare.equal : t];
/** Dump a location */

@ -18,7 +18,7 @@ let module F = Format;
type t = {plain: string, mangled: option string} [@@deriving compare];
let equal pn1 pn2 => compare pn1 pn2 == 0;
let equal = [%compare.equal : t];
/** Convert a string to a mangled name */
@ -54,7 +54,7 @@ let get_mangled pn =>
/** Create a mangled type name from a package name and a class name */
let from_package_class package_name class_name =>
if (package_name == "") {
if (String.equal package_name "") {
from_string class_name
} else {
from_string (package_name ^ "." ^ class_name)

@ -9,6 +9,7 @@
*)
open! IStd
open! PVariant
(** This module handles buckets of memory leaks in Objective-C/C++ *)
@ -22,29 +23,23 @@ let bucket_to_message bucket =
| `MLeak_cpp -> "[CPP]"
| `MLeak_unknown -> "[UNKNOWN ORIGIN]"
let compare_mleak_bucket =
[%compare: [ `MLeak_all | `MLeak_arc | `MLeak_cf | `MLeak_cpp | `MLeak_no_arc | `MLeak_unknown ]]
let mleak_bucket_eq b1 b2 =
compare_mleak_bucket b1 b2 = 0
let contains_all =
IList.mem mleak_bucket_eq `MLeak_all Config.ml_buckets
IList.mem PVariant.(=) `MLeak_all Config.ml_buckets
let contains_cf =
IList.mem mleak_bucket_eq `MLeak_cf Config.ml_buckets
IList.mem PVariant.(=) `MLeak_cf Config.ml_buckets
let contains_arc =
IList.mem mleak_bucket_eq `MLeak_arc Config.ml_buckets
IList.mem PVariant.(=) `MLeak_arc Config.ml_buckets
let contains_narc =
IList.mem mleak_bucket_eq `MLeak_no_arc Config.ml_buckets
IList.mem PVariant.(=) `MLeak_no_arc Config.ml_buckets
let contains_cpp =
IList.mem mleak_bucket_eq `MLeak_cpp Config.ml_buckets
IList.mem PVariant.(=) `MLeak_cpp Config.ml_buckets
let contains_unknown_origin =
IList.mem mleak_bucket_eq `MLeak_unknown Config.ml_buckets
IList.mem PVariant.(=) `MLeak_unknown Config.ml_buckets
let should_raise_leak_cf typ =
if contains_cf then
@ -79,7 +74,7 @@ let should_raise_cpp_leak =
(* If arc is passed, check leaks from code that compiles with arc*)
(* If no arc is passed check the leaks from code that compiles without arc *)
let should_raise_objc_leak typ =
if Config.ml_buckets = [] || contains_all then Some ""
if List.is_empty Config.ml_buckets || contains_all then Some ""
else if should_raise_leak_cf typ then Some (bucket_to_message `MLeak_cf)
else if should_raise_leak_arc () then Some (bucket_to_message `MLeak_arc)
else if should_raise_leak_no_arc () then Some (bucket_to_message `MLeak_no_arc)

@ -232,15 +232,15 @@ struct
(String.is_substring ~substring:cf_type typ)
let is_core_lib_retain typ funct =
function_arg_is_cftype typ && funct = cf_retain
function_arg_is_cftype typ && String.equal funct cf_retain
let is_core_lib_release typ funct =
function_arg_is_cftype typ && funct = cf_release
function_arg_is_cftype typ && String.equal funct cf_release
let is_core_graphics_release typ funct =
try
let cg_typ = IList.find
(fun lib -> (funct = (lib^upper_release))) core_graphics_types in
(fun lib -> (String.equal funct (lib^upper_release))) core_graphics_types in
(String.is_substring ~substring:(cg_typ^ref) typ)
with Not_found -> false

@ -69,6 +69,8 @@ type res_act_kind =
| Rrelease
[@@deriving compare];
let equal_res_act_kind = [%compare.equal : res_act_kind];
/** kind of dangling pointers */
type dangling_kind =
@ -85,7 +87,7 @@ type dangling_kind =
/** position in a path: proc name, node id */
type path_pos = (Procname.t, int) [@@deriving compare];
let equal_path_pos pp1 pp2 => compare_path_pos pp1 pp2 == 0;
let equal_path_pos = [%compare.equal : path_pos];
type taint_kind =
| Tk_unverified_SSL_socket
@ -155,7 +157,7 @@ type t =
| Aunsubscribed_observer
[@@deriving compare];
let equal att1 att2 => compare att1 att2 == 0;
let equal = [%compare.equal : t];
/** name of the allocation function for the given memory kind */
@ -189,7 +191,7 @@ type category =
| ACobserver
[@@deriving compare];
let equal_category att1 att2 => compare_category att1 att2 == 0;
let equal_category = [%compare.equal : category];
let to_category att =>
switch att {

@ -60,6 +60,8 @@ type res_act_kind =
| Rrelease
[@@deriving compare];
let equal_res_act_kind: res_act_kind => res_act_kind => bool;
/** kind of dangling pointers */
type dangling_kind =

@ -67,7 +67,7 @@ let module Node = {
};
let compare node1 node2 => Int.compare node1.id node2.id;
let hash node => Hashtbl.hash node.id;
let equal node1 node2 => compare node1 node2 == 0;
let equal = [%compare.equal : t];
/** Get the unique id of the node */
let get_id node => node.id;
@ -394,7 +394,7 @@ let get_slope pdesc => Node.get_generated_slope (get_start_node pdesc) Node.get_
/** Return [true] iff the procedure is defined, and not just declared */
let is_defined pdesc => pdesc.attributes.is_defined;
let is_body_empty pdesc => Node.get_succs (get_start_node pdesc) == [];
let is_body_empty pdesc => List.is_empty (Node.get_succs (get_start_node pdesc));
let is_java_synchronized pdesc => pdesc.attributes.is_java_synchronized_method;

@ -31,6 +31,8 @@ type method_kind =
| Static /* in Java, procedures called with invokestatic */
[@@deriving compare];
let equal_method_kind = [%compare.equal : method_kind];
/** Type of java procedure names. */
type java = {
@ -73,14 +75,17 @@ type t =
| ObjC_Cpp objc_cpp
[@@deriving compare];
let equal pn1 pn2 => compare pn1 pn2 == 0;
let equal = [%compare.equal : t];
/** Level of verbosity of some to_string functions. */
type detail_level =
| Verbose
| Non_verbose
| Simple;
| Simple
[@@deriving compare];
let equal_detail_level = [%compare.equal : detail_level];
let objc_method_kind_of_bool is_instance =>
if is_instance {ObjCInstanceMethod} else {ObjCClassMethod};
@ -262,7 +267,7 @@ let java_get_parameters_as_strings j =>
/** Return true if the java procedure is static */
let java_is_static =
fun
| Java j => j.kind == Static
| Java j => equal_method_kind j.kind Static
| _ => false;
@ -284,7 +289,7 @@ let java_to_string withclass::withclass=false (j: java) verbosity =>
| _ => " "
};
let output = class_name ^ "." ^ j.method_name ^ "(" ^ params ^ ")";
if (verbosity == Verbose) {
if (equal_detail_level verbosity Verbose) {
output ^ separator ^ return_type
} else {
return_type ^ separator ^ output
@ -303,7 +308,7 @@ let java_to_string withclass::withclass=false (j: java) verbosity =>
| _ => "..."
};
let method_name =
if (j.method_name == "<init>") {
if (String.equal j.method_name "<init>") {
java_get_simple_class_name j
} else {
cls_prefix ^ j.method_name
@ -402,7 +407,7 @@ let java_is_vararg =
| _ => false;
let is_objc_constructor method_name =>
method_name == "new" || String.is_prefix prefix::"init" method_name;
String.equal method_name "new" || String.is_prefix prefix::"init" method_name;
let is_objc_kind =
fun
@ -415,12 +420,12 @@ let is_objc_kind =
/** [is_constructor pname] returns true if [pname] is a constructor */
let is_constructor =
fun
| Java js => js.method_name == "<init>"
| Java js => String.equal js.method_name "<init>"
| ObjC_Cpp {kind: CPPConstructor _} => true
| ObjC_Cpp {kind, method_name} when is_objc_kind kind => is_objc_constructor method_name
| _ => false;
let is_objc_dealloc method_name => method_name == "dealloc";
let is_objc_dealloc method_name => String.equal method_name "dealloc";
/** [is_dealloc pname] returns true if [pname] is the dealloc method in Objective-C
@ -432,14 +437,14 @@ let is_destructor =
let java_is_close =
fun
| Java js => js.method_name == "close"
| Java js => String.equal js.method_name "close"
| _ => false;
/** [is_class_initializer pname] returns true if [pname] is a class initializer */
let is_class_initializer =
fun
| Java js => js.method_name == "<clinit>"
| Java js => String.equal js.method_name "<clinit>"
| _ => false;

@ -37,7 +37,7 @@ and t = {pv_hash: int, pv_name: Mangled.t, pv_kind: pvar_kind} [@@deriving compa
let compare_alpha pv1 pv2 =>
[%compare : (Mangled.t, pvar_kind)] (pv1.pv_name, pv1.pv_kind) (pv2.pv_name, pv2.pv_kind);
let equal pvar1 pvar2 => compare pvar1 pvar2 == 0;
let equal = [%compare.equal : t];
let rec _pp f pv => {
let name = pv.pv_name;
@ -242,7 +242,7 @@ let is_this pvar => Mangled.equal (get_name pvar) (Mangled.from_string "this");
/** Check if the pvar is a return var */
let is_return pv => get_name pv == Ident.name_return;
let is_return pv => Mangled.equal (get_name pv) Ident.name_return;
/** something that can't be part of a legal identifier in any conceivable language */

@ -63,6 +63,8 @@ type instr =
| Declare_locals (list (Pvar.t, Typ.t)) Location.t /** declare local variables */
[@@deriving compare];
let equal_instr = [%compare.equal : instr];
let skip_instr = Remove_temps [] Location.dummy;
@ -95,7 +97,7 @@ type atom =
| Anpred PredSymb.t (list Exp.t) /** negated predicate symbol applied to exps */
[@@deriving compare];
let equal_atom x y => compare_atom x y == 0;
let equal_atom = [%compare.equal : atom];
/** kind of lseg or dllseg predicates */
@ -104,7 +106,7 @@ type lseg_kind =
| Lseg_PE /** possibly empty (possibly circular) listseg */
[@@deriving compare];
let equal_lseg_kind k1 k2 => compare_lseg_kind k1 k2 == 0;
let equal_lseg_kind = [%compare.equal : lseg_kind];
/** The boolean is true when the pointer was dereferenced without testing for zero. */
@ -131,6 +133,8 @@ type inst =
| Ireturn_from_call int
[@@deriving compare];
let equal_inst = [%compare.equal : inst];
/** structured expressions represent a value of structured type, such as an array or a struct. */
type strexp0 'inst =
@ -151,7 +155,7 @@ type strexp = strexp0 inst;
let compare_strexp inst::inst=false se1 se2 =>
compare_strexp0 (inst ? compare_inst : (fun _ _ => 0)) se1 se2;
let equal_strexp inst::inst=false se1 se2 => compare_strexp inst::inst se1 se2 == 0;
let equal_strexp inst::inst=false se1 se2 => Int.equal (compare_strexp inst::inst se1 se2) 0;
/** an atomic heap predicate */
@ -201,19 +205,20 @@ type hpred = hpred0 inst;
let compare_hpred inst::inst=false hpred1 hpred2 =>
compare_hpred0 (inst ? compare_inst : (fun _ _ => 0)) hpred1 hpred2;
let equal_hpred inst::inst=false hpred1 hpred2 => compare_hpred inst::inst hpred1 hpred2 == 0;
let equal_hpred inst::inst=false hpred1 hpred2 =>
Int.equal (compare_hpred inst::inst hpred1 hpred2) 0;
type hpara = hpara0 inst;
let compare_hpara = compare_hpara0 (fun _ _ => 0);
let equal_hpara hpara1 hpara2 => compare_hpara hpara1 hpara2 == 0;
let equal_hpara = [%compare.equal : hpara];
type hpara_dll = hpara_dll0 inst;
let compare_hpara_dll = compare_hpara_dll0 (fun _ _ => 0);
let equal_hpara_dll hpara1 hpara2 => compare_hpara_dll hpara1 hpara2 == 0;
let equal_hpara_dll = [%compare.equal : hpara_dll];
/** Return the lhs expression of a hpred */
@ -285,14 +290,14 @@ let color_pre_wrapper pe f x =>
let color = pe.Pp.cmap_norm (Obj.repr x);
if (color != pe.Pp.color) {
(
if (pe.Pp.kind == Pp.HTML) {
if (Pp.equal_print_kind pe.Pp.kind Pp.HTML) {
Io_infer.Html.pp_start_color
} else {
Latex.pp_color
}
)
f color;
if (color == Pp.Red) {
if (Pp.equal_color color Pp.Red) {
(
Pp.{
/** All subexpressiona red */
@ -316,7 +321,7 @@ let color_pre_wrapper pe f x =>
/** Close color annotation if changed */
let color_post_wrapper changed pe f =>
if changed {
if (pe.Pp.kind == Pp.HTML) {
if (Pp.equal_print_kind pe.Pp.kind Pp.HTML) {
Io_infer.Html.pp_end_color f ()
} else {
Latex.pp_color f pe.Pp.color
@ -630,7 +635,7 @@ let module Predicates: {
};
/** return true if the environment is empty */
let is_empty env => env.num == 0;
let is_empty env => Int.equal env.num 0;
/** return the id of the hpara */
let get_hpara_id env hpara => fst (HparaHash.find env.hash hpara);
@ -791,7 +796,7 @@ let inst_partial_join inst1 inst2 => {
L.d_strln ("inst_partial_join failed on " ^ inst_to_string inst1 ^ " " ^ inst_to_string inst2);
raise IList.Fail
};
if (inst1 == inst2) {
if (equal_inst inst1 inst2) {
inst1
} else {
switch (inst1, inst2) {
@ -811,7 +816,7 @@ let inst_partial_join inst1 inst2 => {
/** meet of instrumentations */
let inst_partial_meet inst1 inst2 =>
if (inst1 == inst2) {
if (equal_inst inst1 inst2) {
inst1
} else {
inst_none
@ -886,7 +891,7 @@ let update_inst inst_old inst_new => {
/** describe an instrumentation with a string */
let pp_inst pe f inst => {
let str = inst_to_string inst;
if (pe.Pp.kind == Pp.HTML) {
if (Pp.equal_print_kind 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 ()
} else {
F.fprintf f "%s%s%s" (Binop.str pe Lt) str (Binop.str pe Gt)
@ -1403,7 +1408,7 @@ let rec ident_sorted_list_subset l1 l2 =>
| ([_, ..._], []) => false
| ([id1, ...l1], [id2, ...l2]) =>
let n = Ident.compare id1 id2;
if (n == 0) {
if (Int.equal n 0) {
ident_sorted_list_subset l1 [id2, ...l2]
} else if (n > 0) {
ident_sorted_list_subset [id1, ...l1] l2
@ -1634,13 +1639,13 @@ let rec sorted_list_check_consecutives f =>
/** substitution */
type ident_exp = (Ident.t, Exp.t) [@@deriving compare];
let equal_ident_exp ide1 ide2 => compare_ident_exp ide1 ide2 == 0;
let equal_ident_exp = [%compare.equal : ident_exp];
type subst = list ident_exp [@@deriving compare];
/** Equality for substitutions. */
let equal_subst sub1 sub2 => compare_subst sub1 sub2 == 0;
let equal_subst = [%compare.equal : subst];
let sub_check_duplicated_ids sub => {
let f (id1, _) (id2, _) => Ident.equal id1 id2;
@ -1712,9 +1717,11 @@ let sub_symmetric_difference sub1_in sub2_in => {
(sub_common, sub1_only', sub2_only')
| ([id_e1, ...sub1'], [id_e2, ...sub2']) =>
let n = compare_ident_exp id_e1 id_e2;
if (n == 0) {
if (Int.equal n 0) {
diff [id_e1, ...sub_common] sub1_only sub2_only sub1' sub2'
} else if (n < 0) {
} else if (
n < 0
) {
diff sub_common [id_e1, ...sub1_only] sub2_only sub1' sub2
} else {
diff sub_common sub1_only [id_e2, ...sub2_only] sub1 sub2'

@ -63,6 +63,8 @@ type instr =
| Declare_locals (list (Pvar.t, Typ.t)) Location.t /** declare local variables */
[@@deriving compare];
let equal_instr: instr => instr => bool;
/** compare instructions from different procedures without considering loc's, ident's, and pvar's.
the [exp_map] param gives a mapping of names used in the procedure of [instr1] to identifiers
@ -128,6 +130,8 @@ type inst =
| Ireturn_from_call int
[@@deriving compare];
let equal_inst: inst => inst => bool;
let inst_abstraction: inst;
let inst_actual_precondition: inst;

@ -147,4 +147,4 @@ let objc_ref_counter_annot = [({Annot.class_name: "ref_counter", parameters: []}
let objc_ref_counter_field = (Ident.fieldname_hidden, Typ.Tint IInt, objc_ref_counter_annot);
let is_objc_ref_counter_field (fld, _, a) =>
Ident.fieldname_is_hidden fld && Annot.Item.compare a objc_ref_counter_annot == 0;
Ident.fieldname_is_hidden fld && Annot.Item.equal a objc_ref_counter_annot;

@ -19,7 +19,7 @@ let module L = Logging;
let module F = Format;
let list_to_string list =>
if (List.length list == 0) {
if (Int.equal (List.length list) 0) {
"( sub )"
} else {
"- {" ^ String.concat sep::", " (List.map f::Typename.name list) ^ "}"
@ -30,7 +30,7 @@ type t' =
| Subtypes (list Typename.t)
[@@deriving compare];
let equal_modulo_flag (st1, _) (st2, _) => compare_t' st1 st2 == 0;
let equal_modulo_flag (st1, _) (st2, _) => [%compare.equal : t'] st1 st2;
/** denotes the current type and a list of types that are not their subtypes */
@ -40,6 +40,8 @@ type kind =
| NORMAL
[@@deriving compare];
let equal_kind = [%compare.equal : kind];
type t = (t', kind) [@@deriving compare];
type result =
@ -48,6 +50,8 @@ type result =
| Yes
[@@deriving compare];
let equal_result = [%compare.equal : result];
let max_result res1 res2 =>
if (compare_result res1 res2 <= 0) {
res2
@ -75,7 +79,7 @@ let check_subclass_tenv tenv c1 c2 :result => {
let rec loop best_result classnames :result =>
/* Check if the name c2 is found in the list of super types and
keep the best results according to Yes > Unknown > No */
if (best_result == Yes) {
if (equal_result best_result Yes) {
Yes
} else {
switch classnames {
@ -117,9 +121,9 @@ let check_subtype = {
)
};
let is_known_subtype tenv c1 c2 :bool => check_subtype tenv c1 c2 == Yes;
let is_known_subtype tenv c1 c2 :bool => equal_result (check_subtype tenv c1 c2) Yes;
let is_known_not_subtype tenv c1 c2 :bool => check_subtype tenv c1 c2 == No;
let is_known_not_subtype tenv c1 c2 :bool => equal_result (check_subtype tenv c1 c2) No;
let flag_to_string flag =>
switch flag {
@ -146,9 +150,9 @@ let subtypes_cast = (all_subtypes, CAST);
let subtypes_instof = (all_subtypes, INSTOF);
let is_cast t => snd t == CAST;
let is_cast t => equal_kind (snd t) CAST;
let is_instof t => snd t == INSTOF;
let is_instof t => equal_kind (snd t) INSTOF;
let list_intersect equal l1 l2 => {
let in_l2 a => IList.mem equal a l2;

@ -93,7 +93,8 @@ let add tenv name struct_typ => TypenameHash.replace tenv name struct_typ;
/** Get method that is being overriden by java_pname (if any) **/
let get_overriden_method tenv pname_java => {
let struct_typ_get_method_by_name (struct_typ: StructTyp.t) method_name =>
IList.find (fun meth => method_name == Procname.get_method meth) struct_typ.methods;
IList.find
(fun meth => String.equal method_name (Procname.get_method meth)) struct_typ.methods;
let rec get_overriden_method_in_supers pname_java supers =>
switch supers {
| [superclass, ...supers_tail] =>
@ -121,7 +122,7 @@ let global_tenv: ref (option t) = ref None;
/** Load a type environment from a file */
let load_from_file (filename: DB.filename) :option t =>
if (filename == DB.global_tenv_fname) {
if (DB.equal_filename filename DB.global_tenv_fname) {
if (is_none !global_tenv) {
global_tenv := Serialization.from_file tenv_serializer DB.global_tenv_fname
};
@ -135,7 +136,7 @@ let load_from_file (filename: DB.filename) :option t =>
let store_to_file (filename: DB.filename) (tenv: t) => {
/* update in-memory global tenv for later uses by this process, e.g. in single-core mode the
frontend and backend run in the same process */
if (filename == DB.global_tenv_fname) {
if (DB.equal_filename filename DB.global_tenv_fname) {
global_tenv := Some tenv
};
Serialization.to_file tenv_serializer filename tenv;

@ -135,7 +135,7 @@ type t =
| Tarray t static_length /** array type with statically fixed length */
[@@deriving compare];
let equal t1 t2 => compare t1 t2 == 0;
let equal = [%compare.equal : t];
/** type comparison that treats T* [] and T** as the same type. Needed for C/C++ */
@ -238,7 +238,7 @@ let array_elem default_opt =>
let is_class_of_kind typ ck =>
switch typ {
| Tstruct (TN_csu (Class ck') _) => ck == ck'
| Tstruct (TN_csu (Class ck') _) => Csu.equal_class_kind ck ck'
| _ => false
};

@ -16,7 +16,7 @@ type t =
| TN_csu Csu.t Mangled.t
[@@deriving compare];
let equal tn1 tn2 => compare tn1 tn2 == 0;
let equal = [%compare.equal : t];
let to_string =
fun

@ -26,7 +26,7 @@ type t =
| LNot /** Logical Not (!) */
[@@deriving compare];
let equal o1 o2 => compare o1 o2 == 0;
let equal = [%compare.equal : t];
/** String representation of unary operator. */

@ -233,7 +233,8 @@ let find_arithmetic_problem tenv proc_node_session prop exp =
uminus_unsigned := (e, typ) :: !uminus_unsigned
| Exp.UnOp(_, e, _) -> walk e
| Exp.BinOp(op, e1, e2) ->
if op = Binop.Div || op = Binop.Mod then exps_divided := e2 :: !exps_divided;
if Binop.equal op Binop.Div || Binop.equal op Binop.Mod
then exps_divided := e2 :: !exps_divided;
walk e1; walk e2
| Exp.Exn _ -> ()
| Exp.Closure _ -> ()

@ -40,7 +40,7 @@ let mk_empty_array_rearranged len =
Sil.Earray (len, [], Sil.inst_rearrange true (State.get_loc ()) (State.get_path_pos ()))
let extract_array_type typ =
if (!Config.curr_language = Config.Java) then
if (Config.curr_language_is Config.Java) then
match typ with
| Typ.Tptr (Typ.Tarray _ as arr, _) -> Some arr
| _ -> None
@ -243,7 +243,7 @@ let execute___instanceof_cast ~instof
(* In Java, we throw an exception, in C++ we return 0 in case of a cast to a pointer, *)
(* and throw an exception in case of a cast to a reference. *)
let should_throw_exception =
!Config.curr_language = Config.Java || is_cast_to_reference in
Config.curr_language_is Config.Java || is_cast_to_reference in
let deal_with_failed_cast val1 texp1 texp2 =
raise
(Tabulation.create_cast_exception

@ -171,7 +171,7 @@ let summary_values top_proc_set summary => {
F.asprintf "%t" pp
};
let node_coverage =
if (nodes_nr == 0) {
if (Int.equal nodes_nr 0) {
0.0
} else {
float_of_int nr_nodes_visited /. float_of_int nodes_nr
@ -195,7 +195,12 @@ let summary_values top_proc_set summary => {
vto: Option.value_map f::pp_failure default::"NONE" stats.Specs.stats_failure,
vsymop: stats.Specs.symops,
verr:
Errlog.size (fun ekind in_footprint => ekind == Exceptions.Kerror && in_footprint) err_log,
Errlog.size
(
fun ekind in_footprint =>
Exceptions.equal_err_kind ekind Exceptions.Kerror && in_footprint
)
err_log,
vflags: attributes.ProcAttributes.proc_flags,
vfile: SourceFile.to_string attributes.ProcAttributes.loc.Location.file,
vline: attributes.ProcAttributes.loc.Location.line,
@ -303,7 +308,7 @@ let module ProcsXml = {
};
let should_report (issue_kind: Exceptions.err_kind) issue_type error_desc eclass =>
if (not Config.filtering || eclass == Exceptions.Linters) {
if (not Config.filtering || Exceptions.equal_err_class eclass Exceptions.Linters) {
true
} else {
let analyzer_is_whitelisted =
@ -501,7 +506,7 @@ let module IssuesJson = {
Some Jsonbug_j.{file, lnum, cnum, enum}
| _ => None
};
let visibility = Exceptions.string_of_exception_visibility visibility;
let visibility = Exceptions.string_of_visibility visibility;
let bug = {
Jsonbug_j.bug_class: Exceptions.err_class_string eclass,
kind,
@ -989,7 +994,7 @@ let module PreconditionStats = {
let error_filter filters proc_name file error_desc error_name => {
let always_report () =>
Localise.error_desc_extract_tag_value error_desc "always_report" == "true";
String.equal (Localise.error_desc_extract_tag_value error_desc "always_report") "true";
(Config.write_html || not (Localise.equal error_name Localise.skip_function)) &&
(filters.Inferconfig.path_filter file || always_report ()) &&
filters.Inferconfig.error_filter error_name && filters.Inferconfig.proc_filter proc_name
@ -1000,7 +1005,8 @@ type report_kind =
| Procs
| Stats
| Calls
| Summary;
| Summary
[@@deriving compare];
type bug_format_kind =
| Json
@ -1008,7 +1014,8 @@ type bug_format_kind =
| Tests
| Text
| Xml
| Latex;
| Latex
[@@deriving compare];
let pp_issues_in_format (format_kind, outf: Utils.outfile) =>
switch format_kind {
@ -1193,7 +1200,7 @@ let process_summary filters formats_by_report_kind linereader stats top_proc_set
let module AnalysisResults = {
type t = list (string, Specs.summary);
let spec_files_from_cmdline () =>
if (Config.current_exe == CLOpt.Print) {
if (CLOpt.equal_exe Config.current_exe CLOpt.Print) {
/* Find spec files specified by command-line arguments. Not run at init time since the specs
files may be generated between init and report time. */
IList.iter
@ -1208,7 +1215,7 @@ let module AnalysisResults = {
Inferconfig.test ();
exit 0
};
if (Config.anon_args == []) {
if (List.is_empty Config.anon_args) {
load_specfiles ()
} else {
List.rev Config.anon_args
@ -1377,7 +1384,11 @@ let finalize_and_close_files format_list_by_kind stats pdflatex => {
| (Csv | Latex | Tests | Text | Xml | Json, _) => ()
};
Utils.close_outf outfile;
if ((format_kind, report_kind) == (Latex, Summary)) {
/* bug_format_kind report_kind */
if (
[%compare.equal : (bug_format_kind, report_kind)]
(format_kind, report_kind) (Latex, Summary)
) {
pdflatex outfile.fname;
let pdf_name = Filename.chop_extension outfile.fname ^ ".pdf";
ignore (Sys.command ("open " ^ pdf_name))

@ -82,7 +82,7 @@ let remove_abduced_retvars tenv p => {
}
| _ => (reach, exps);
let (reach', exps') = IList.fold_left add_hpred_if_reachable (reach, exps) sigma;
if (Sil.HpredSet.cardinal reach == Sil.HpredSet.cardinal reach') {
if (Int.equal (Sil.HpredSet.cardinal reach) (Sil.HpredSet.cardinal reach')) {
(reach, exps)
} else {
compute_reachable_hpreds_rec sigma (reach', exps')

@ -8,6 +8,8 @@
*/
open! IStd;
open! PVariant;
let aggregated_stats_filename = "aggregated_stats.json";
let aggregated_stats_by_target_filename = "aggregated_stats_by_target.json";
@ -25,7 +27,7 @@ let find_json_files_in_dir dir => {
let s = Unix.lstat path;
let json_regex = Str.regexp_case_fold ".*\\.json$";
not (Str.string_match json_files_to_ignore_regex path 0) &&
Str.string_match json_regex path 0 && s.st_kind == Unix.S_REG
Str.string_match json_regex path 0 && Polymorphic_compare.(==) s.st_kind Unix.S_REG
};
dir_exists dir ?
{

@ -85,8 +85,8 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.subst) =
L.out "@[<4> public ids : %a@\n@." pp_exp_list insts_of_public_ids;
*)
(* (not (IList.intersect compare fav_inst_of_base fav_in_pvars)) && *)
(fpv_inst_of_base = []) &&
(fpv_insts_of_private_ids = []) &&
(List.is_empty fpv_inst_of_base) &&
(List.is_empty fpv_insts_of_private_ids) &&
(not (IList.exists Ident.is_normal fav_insts_of_private_ids)) &&
(not (IList.intersect Ident.compare fav_insts_of_private_ids fav_p_leftover)) &&
(not (IList.intersect Ident.compare fav_insts_of_private_ids fav_insts_of_public_ids))
@ -617,7 +617,7 @@ let eqs_solve ids_in eqs_in =
| ((Exp.Var id1 as e1), (Exp.Var id2 as e2)) :: eqs_rest ->
let n = Ident.compare id1 id2 in
begin
if n = 0 then solve sub eqs_rest
if Int.equal n 0 then solve sub eqs_rest
else if n > 0 then solve sub ((e2, e1):: eqs_rest)
else do_default id1 e2 eqs_rest
end
@ -988,7 +988,7 @@ let get_var_retain_cycle prop_ =
let cycle = get_cycle hp prop_ in
L.d_strln "Filtering pvar in cycle ";
let cycle' = IList.flatten (IList.map find_or_block cycle) in
if cycle' = [] then do_sigma sigma'
if List.is_empty cycle' then do_sigma sigma'
else cycle' in
do_sigma sigma
@ -1016,11 +1016,13 @@ let cycle_has_weak_or_unretained_or_assign_field tenv cycle =
let rec has_weak_or_unretained_or_assign params =
match params with
| [] -> false
| att:: _ when Config.unsafe_unret = att || Config.weak = att || Config.assign = att -> true
| att:: _ when String.equal Config.unsafe_unret att ||
String.equal Config.weak att ||
String.equal Config.assign att -> true
| _:: params' -> has_weak_or_unretained_or_assign params' in
let do_annotation ((a: Annot.t), _) =
((a.class_name = Config.property_attributes) ||
(a.class_name = Config.ivar_attributes))
((String.equal a.class_name Config.property_attributes) ||
(String.equal a.class_name Config.ivar_attributes))
&& has_weak_or_unretained_or_assign a.parameters in
let rec do_cycle c =
match c with
@ -1123,7 +1125,7 @@ let check_junk ?original_prop pname tenv prop =
match resource with
| PredSymb.Rmemory PredSymb.Mobjc -> should_raise_objc_leak hpred
| PredSymb.Rmemory PredSymb.Mnew | PredSymb.Rmemory PredSymb.Mnew_array
when !Config.curr_language = Config.Clang ->
when Config.curr_language_is Config.Clang ->
Mleak_buckets.should_raise_cpp_leak
| _ -> None in
let exn_retain_cycle cycle =
@ -1144,14 +1146,14 @@ let check_junk ?original_prop pname tenv prop =
Otherwise we report a retain cycle. *)
let cycle = get_var_retain_cycle (remove_opt original_prop) in
let ignore_cycle =
(IList.length cycle = 0) ||
(Int.equal (IList.length cycle) 0) ||
(cycle_has_weak_or_unretained_or_assign_field tenv cycle) in
ignore_cycle, exn_retain_cycle cycle
| Some _, Rmemory Mobjc
| Some _, Rmemory Mnew
| Some _, Rmemory Mnew_array when !Config.curr_language = Config.Clang ->
ml_bucket_opt = None, exn_leak
| Some _, Rmemory _ -> !Config.curr_language = Config.Java, exn_leak
| Some _, Rmemory Mnew_array when Config.curr_language_is Config.Clang ->
is_none ml_bucket_opt, exn_leak
| Some _, Rmemory _ -> Config.curr_language_is Config.Java, exn_leak
| Some _, Rignore -> true, exn_leak
| Some _, Rfile -> false, exn_leak
| Some _, Rlock -> false, exn_leak
@ -1160,21 +1162,21 @@ let check_junk ?original_prop pname tenv prop =
we have a retain cycle. Objc object may not have the
Mobjc qualifier when added in footprint doing abduction *)
let cycle = get_var_retain_cycle (remove_opt original_prop) in
IList.length cycle = 0, exn_retain_cycle cycle
| _ -> !Config.curr_language = Config.Java, exn_leak) in
Int.equal (IList.length cycle) 0, exn_retain_cycle cycle
| _ -> Config.curr_language_is Config.Java, exn_leak) in
let already_reported () =
let attr_opt_equal ao1 ao2 = match ao1, ao2 with
| None, None -> true
| Some a1, Some a2 -> PredSymb.equal a1 a2
| Some _, None
| None, Some _ -> false in
(alloc_attribute = None && !leaks_reported <> []) ||
(is_none alloc_attribute && !leaks_reported <> []) ||
(* None attribute only reported if it's the first one *)
IList.mem attr_opt_equal alloc_attribute !leaks_reported in
let ignore_leak =
!Config.allow_leak || ignore_resource || is_undefined || already_reported () in
let report_and_continue =
!Config.curr_language = Config.Java || !Config.footprint in
Config.curr_language_is Config.Java || !Config.footprint in
let report_leak () =
if not report_and_continue then raise exn
else
@ -1190,7 +1192,7 @@ let check_junk ?original_prop pname tenv prop =
remove_junk_recursive [] sigma in
let rec remove_junk fp_part fav_root sigma = (* call remove_junk_once until sigma stops shrinking *)
let sigma' = remove_junk_once fp_part fav_root sigma in
if IList.length sigma' = IList.length sigma then sigma'
if Int.equal (IList.length sigma') (IList.length sigma) then sigma'
else remove_junk fp_part fav_root sigma' in
let sigma_new = remove_junk false fav_sub_sigmafp prop.Prop.sigma in
let sigma_fp_new = remove_junk true (Sil.fav_new ()) prop.Prop.sigma_fp in

@ -352,7 +352,7 @@ let generic_strexp_abstract tenv
with
| Not_found -> (p0, false) in
let rec find_then_abstract bound p0 =
if bound = 0 then p0
if Int.equal bound 0 then p0
else begin
if Config.trace_absarray then
(L.d_strln ("Applying " ^ abstraction_name ^ " to"); Prop.d_prop p0; L.d_ln (); L.d_ln ());
@ -441,7 +441,7 @@ let keep_only_indices tenv
| Sil.Earray (len, esel, inst) ->
let esel', esel_leftover' =
IList.partition (fun (e, _) -> IList.exists (Exp.equal e) indices) esel in
if esel_leftover' = [] then (sigma, false)
if List.is_empty esel_leftover' then (sigma, false)
else begin
let se' = Sil.Earray (len, esel', inst) 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 ());
keep p path keep_keys in
let p3, changed3 =
if blur_keys = [] then (p2, false)
if List.is_empty blur_keys then (p2, false)
else begin
if Config.trace_absarray then (L.d_str "blur "; d_keys blur_keys; L.d_ln ());
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_keys, _, _ =
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 List.is_empty keep_keys then default_keys else keep_keys in
abstract keep_keys' keep_keys' in
let do_array_footprint esel =
(* 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 keep_ksel = IList.filter should_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 List.is_empty 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 ());
abstract keep_keys' [] in
let do_array_reexecution esel =
@ -608,7 +608,7 @@ let remove_redundant_elements tenv prop =
| Exp.Const (Const.Cint i), Sil.Eexp (Exp.Var id, _)
when (not fp_part || IntLit.iszero i) && not (Ident.is_normal id) && occurs_at_most_once id ->
remove () (* unknown value can be removed in re-execution mode or if the index is zero *)
| Exp.Var id, Sil.Eexp _ when Ident.is_normal id = false && occurs_at_most_once id ->
| Exp.Var id, Sil.Eexp _ when not (Ident.is_normal id) && occurs_at_most_once id ->
remove () (* index unknown can be removed *)
| _ -> true in
let remove_redundant_se fp_part = function

@ -43,7 +43,7 @@ let check_nested_loop path pos_opt =
let f level p _ _ = match Paths.Path.curr_node p with
| Some node ->
do_any_node level node;
if level = 0 then do_node_caller node
if Int.equal level 0 then do_node_caller node
| None ->
() in
Paths.Path.iter_shortest_sequence f pos_opt path;
@ -67,7 +67,7 @@ let check_access access_opt de_opt =
let process_formal_letref = function
| Sil.Load (id, Exp.Lvar pvar, _, _) ->
let is_java_this =
!Config.curr_language = Config.Java && Pvar.is_this pvar in
Config.curr_language_is Config.Java && Pvar.is_this pvar in
if not is_java_this && is_formal pvar then formal_ids := id :: !formal_ids
| _ -> () in
IList.iter process_formal_letref node_instrs;
@ -100,7 +100,8 @@ let check_access access_opt de_opt =
IList.exists filter (Procdesc.Node.get_instrs node) in
let local_access_found = ref false in
let do_node node =
if (Procdesc.Node.get_loc node).Location.line = line_number && has_call_or_sets_null node then
if Int.equal (Procdesc.Node.get_loc node).Location.line line_number &&
has_call_or_sets_null node then
begin
local_access_found := true
end in

@ -34,9 +34,8 @@ let builtin_functions = Procname.Hash.create 4
let check_register_populated () =
(* check if BuiltinDefn were loaded before accessing register *)
if Procname.Hash.length builtin_functions = 0 then
if Int.equal (Procname.Hash.length builtin_functions) 0 then
failwith "Builtins were not initialized"
else ()
(** check if the function is a builtin *)
let is_registered name =

@ -86,7 +86,7 @@ let iterate_procedure_callbacks exe_env caller_pname =
IList.iter
(fun (language_opt, proc_callback) ->
let language_matches = match language_opt with
| Some language -> language = procedure_language
| Some language -> Config.equal_language language procedure_language
| None -> true in
if language_matches then
begin
@ -122,7 +122,7 @@ let iterate_cluster_callbacks all_procs exe_env proc_names =
(* Procedures matching the given language or all if no language is specified. *)
let relevant_procedures language_opt =
Option.value_map
~f:(fun l -> IList.filter (fun p -> l = get_language p) proc_names)
~f:(fun l -> IList.filter (fun p -> Config.equal_language l (get_language p)) proc_names)
~default:proc_names
language_opt in
@ -163,7 +163,7 @@ let iterate_callbacks store_summary call_graph exe_env =
let attributes_opt =
Specs.proc_resolve_attributes proc_name in
let should_reset =
Specs.get_summary proc_name = None in
is_none (Specs.get_summary proc_name) in
if should_reset
then Specs.reset_summary call_graph proc_name attributes_opt None in

@ -38,7 +38,7 @@ let cluster_should_be_analyzed cluster =
let pp_prolog fmt clusters =
let escape = Escape.escape_map (fun c -> if c = '#' then Some "\\#" else None) in
let escape = Escape.escape_map (fun c -> if Char.equal c '#' then Some "\\#" else None) in
let compilation_dbs_cmd =
IList.map (F.sprintf "--clang-compilation-db-files '%s'") !Config.clang_compilation_db_files
|> String.concat ~sep:" " |> escape in

@ -60,7 +60,7 @@ let stitch_summaries stacktrace_file summary_files out_file =
let expand_stack_frame frame =
(* TODO: Implement k > 1 case *)
let frame_id = frame_id_of_stackframe frame in
if String.Map.existsi ~f:(fun ~key ~data:_ -> key = frame_id) summary_map then
if String.Map.existsi ~f:(fun ~key ~data:_ -> String.equal key frame_id) summary_map then
String.Map.find_exn summary_map frame_id
else
stracktree_of_frame frame in

@ -1121,7 +1121,7 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st
let construct side rev_list ref_list =
let construct_offset_se (off, se) = (off, strexp_construct_fresh side se) in
let acc = IList.map construct_offset_se ref_list in
IList.rev_with_acc acc rev_list in
IList.rev_append rev_list acc in
let rec f_fld_se_list inst acc fld_se_list1 fld_se_list2 =
match fld_se_list1, fld_se_list2 with

@ -37,13 +37,14 @@ type kind_of_links =
| LinkToSSL
| LinkToDLL
| LinkRetainCycle
[@@deriving compare]
(* coordinate identifies a node using two dimension: id is an numerical identifier of the node,*)
(* lambda identifies in which hpred parameter id lays in*)
type coordinate = {
id: int;
lambda: int;
}
} [@@deriving compare]
(* define a link between two nodes. src_fld/trg_fld define the label of the src/trg field. It is*)
(* useful for having nodes from within a struct and/or to inside a struct *)
@ -53,7 +54,9 @@ type link = {
src_fld: string;
trg: coordinate;
trg_fld: string;
}
} [@@deriving compare]
let equal_link = [%compare.equal : link]
(* type of the visualized boxes/nodes in the graph*)
type dotty_node =
@ -202,7 +205,7 @@ let rec look_up_for_back_pointer e dotnodes lambda =
match dotnodes with
| [] -> []
| Dotdllseg(coo, _, _, _, e4, _, _, _):: dotnodes' ->
if Exp.equal e e4 && lambda = coo.lambda then [coo.id + 1]
if Exp.equal e e4 && Int.equal lambda coo.lambda then [coo.id + 1]
else look_up_for_back_pointer e dotnodes' lambda
| _:: dotnodes' -> look_up_for_back_pointer e dotnodes' lambda
@ -212,7 +215,7 @@ let rec select_nodes_exp_lambda dotnodes e lambda =
| [] -> []
| node:: l' ->
let (coo, e') = get_coordinate_and_exp node in
if (Exp.equal e e') && lambda = coo.lambda
if (Exp.equal e e') && Int.equal lambda coo.lambda
then node:: select_nodes_exp_lambda l' e lambda
else select_nodes_exp_lambda l' e lambda
@ -237,7 +240,7 @@ let color_to_str (c : Pp.color) =
let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list) =
let exp_color hpred (exp : Exp.t) =
if pe.Pp.cmap_norm (Obj.repr hpred) = Pp.Red then Pp.Red
if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp) in
let get_rhs_predicate (hpred, lambda) =
let n = !dotty_state_count in
@ -322,7 +325,7 @@ let rec dotty_mk_node pe sigma =
| [] -> []
| (hpred, lambda) :: sigma' ->
let exp_color (exp : Exp.t) =
if pe.Pp.cmap_norm (Obj.repr hpred) = Pp.Red then Pp.Red
if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red
else pe.Pp.cmap_norm (Obj.repr exp) in
do_hpred_lambda exp_color (hpred, lambda) @ dotty_mk_node pe sigma'
@ -629,7 +632,10 @@ let dotty_pp_link f link =
let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
let tmp_nodes = ref nodes in
let tmp_links = ref links in
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 equal_link n' ln))
!tmp_links in
let remove_node n ns =
IList.filter (fun n' -> match n' with
| Dotpointsto _ -> (get_coordinate_id n') <> (get_coordinate_id n)
@ -639,7 +645,7 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
match lns with
| [] -> []
| l:: ln' -> let n_id = get_coordinate_id n in
if l.src.id = n_id && l.src_fld ="" then (
if Int.equal l.src.id n_id && String.equal l.src_fld "" then (
(*L.out "@\n Found link (%i,%i)" l.src.id l.trg.id;*)
l:: boxes_pointed_by n ln'
)
@ -648,7 +654,7 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
match lns with
| [] -> []
| l:: ln' -> let n_id = get_coordinate_id n in
if l.trg.id = n_id && l.trg_fld ="" then (
if Int.equal l.trg.id n_id && String.equal l.trg_fld "" then (
(*L.out "@\n Found link (%i,%i)" l.src.id l.trg.id;*)
l:: boxes_pointing_at n ln' )
else boxes_pointing_at n ln' in
@ -665,7 +671,7 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
let links_from_node = boxes_pointed_by node links in
let links_to_node = boxes_pointing_at node links in
(* L.out "@\n Size of links_from=%i links_to=%i @.@." (IList.length links_from_node) (IList.length links_to_node); *)
if links_to_node =[] then begin
if List.is_empty links_to_node then begin
tmp_links:= remove_links_from links_from_node ;
tmp_nodes:= remove_node node !tmp_nodes;
end
@ -993,7 +999,7 @@ let pp_cfgnode pdesc fmt (n: Procdesc.Node.t) =
let color = if is_exn then "[color=\"red\" ]" else "" in
match Procdesc.Node.get_kind n2 with
| Procdesc.Node.Exit_node _
when is_exn = true -> (* don't print exception edges to the exit node *)
when is_exn -> (* don't print exception edges to the exit node *)
()
| _ ->
F.fprintf fmt "\n\t %a -> %a %s;"
@ -1033,7 +1039,7 @@ let print_icfg_dotty source cfg =
let fname =
match Config.icfg_dotty_outfile with
| Some file -> file
| None when Config.frontend_tests = true ->
| None when Config.frontend_tests ->
(SourceFile.to_abs_path source) ^ ".test.dot"
| None ->
DB.filename_to_string

@ -97,8 +97,8 @@ let find_nullify_after_instr node instr pvar : bool =
let found_instr = ref false in
let find_nullify = function
| Sil.Nullify (pv, _) when !found_instr -> Pvar.equal pv pvar
| _instr ->
if instr = _instr then found_instr := true;
| instr_ ->
if Sil.equal_instr instr instr_ then found_instr := true;
false in
IList.exists find_nullify node_instrs
@ -142,7 +142,7 @@ let find_normal_variable_funcall
Some (fun_exp, IList.map fst args, loc, call_flags)
| _ -> None in
let res = find_in_node_or_preds node find_declaration in
if verbose && res = None
if verbose && is_none res
then
(L.d_str
("find_normal_variable_funcall could not find " ^
@ -235,7 +235,7 @@ let rec _find_normal_variable_load tenv (seen : Exp.Set.t) node id : DExp.t opti
let fun_dexp = DExp.Dconst (Const.Cfun pname) in
let args_dexp =
let args_dexpo = IList.map (fun (e, _) -> _exp_rv_dexp tenv seen node e) args in
if IList.exists (fun x -> x = None) args_dexpo
if IList.exists is_none args_dexpo
then []
else
let unNone = function Some x -> x | None -> assert false in
@ -251,7 +251,7 @@ let rec _find_normal_variable_load tenv (seen : Exp.Set.t) node id : DExp.t opti
Some (DExp.Dpvar pvar)
| _ -> None in
let res = find_in_node_or_preds node find_declaration in
if verbose && res = None
if verbose && is_none res
then
(L.d_str
("find_normal_variable_load could not find " ^
@ -300,7 +300,7 @@ and _exp_lv_dexp tenv (_seen : Exp.Set.t) node e : DExp.t option =
| Some (fun_exp, eargs, loc, call_flags) ->
let fun_dexpo = _exp_rv_dexp tenv seen node' fun_exp in
let blame_args = IList.map (_exp_rv_dexp tenv seen node') eargs in
if IList.exists (fun x -> x = None) (fun_dexpo:: blame_args) then None
if IList.exists is_none (fun_dexpo:: blame_args) then None
else
let unNone = function Some x -> x | None -> assert false in
let args = IList.map unNone blame_args in
@ -541,7 +541,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
let nullify_pvars_notmp =
IList.filter (fun pvar -> not (Pvar.is_frontend_tmp pvar)) nullify_pvars in
value_str_from_pvars_vpath nullify_pvars_notmp vpath
| Some (Sil.Store (lexp, _, _, _)) when vpath = None ->
| Some (Sil.Store (lexp, _, _, _)) when is_none vpath ->
if verbose
then
(L.d_str "explain_leak: current instruction Set for ";
@ -768,7 +768,7 @@ let explain_dexp_access prop dexp is_nullable =
Some (Localise.Last_accessed (n, is_nullable))
| Some (Sil.Ireturn_from_call n) ->
Some (Localise.Returned_from_call n)
| Some Sil.Ialloc when !Config.curr_language = Config.Java ->
| Some Sil.Ialloc when Config.curr_language_is Config.Java ->
Some Localise.Initialized_automatically
| Some inst ->
if verbose
@ -823,7 +823,7 @@ let create_dereference_desc tenv
| _ -> access_opt in
let desc = Localise.dereference_string deref_str value_str access_opt' loc in
let desc =
if !Config.curr_language = Config.Clang && not is_premature_nil then
if Config.curr_language_is Config.Clang && not is_premature_nil then
match de_opt with
| Some (DExp.Dpvar pvar)
| Some (DExp.Dpvaraddr pvar) ->
@ -899,7 +899,7 @@ let _explain_access tenv
if verbose then (L.d_str "explain_dereference Binop.Leteref "; Sil.d_exp e; L.d_ln ());
Some e
| Some Sil.Call (_, Exp.Const (Const.Cfun fn), [(e, _)], _, _)
when Procname.to_string fn = "free" ->
when String.equal (Procname.to_string fn) "free" ->
if verbose then (L.d_str "explain_dereference Sil.Call "; Sil.d_exp e; L.d_ln ());
Some e
| Some Sil.Call (_, (Exp.Var _ as e), _, _, _) ->
@ -983,7 +983,7 @@ let find_with_exp prop exp =
if not (Pvar.is_abduced pv) && not (Pvar.is_this pv) then
res := Some (pv, Fpvar) in
let found_in_struct pv fld_lst = (* found_in_pvar has priority *)
if !res = None then res := Some (pv, Fstruct (IList.rev fld_lst)) in
if is_none !res then res := Some (pv, Fstruct (IList.rev fld_lst)) in
let rec search_struct pv fld_lst = function
| Sil.Eexp (e, _) ->
if Exp.equal e exp then found_in_struct pv fld_lst

@ -121,7 +121,7 @@ val explain_tainted_value_reaching_sensitive_function :
If there is an alloc attribute, print the function call and line number. *)
val explain_leak :
Tenv.t -> Sil.hpred -> 'a Prop.t -> PredSymb.t option -> string option ->
Exceptions.exception_visibility * Localise.error_desc
Exceptions.visibility * Localise.error_desc
(** Produce a description of the memory access performed in the current instruction, if any. *)
val explain_memory_access : Tenv.t -> Localise.deref_str -> 'a Prop.t -> Location.t -> Localise.error_desc

@ -9,6 +9,7 @@
*)
open! IStd
open! PVariant
module Hashtbl = Caml.Hashtbl
(** Support for Execution environments *)
@ -35,7 +36,7 @@ let tenv_filename file_base =
module FilenameHash = Hashtbl.Make(
struct
type t = DB.filename
let equal file1 file2 = DB.compare_filename file1 file2 = 0
let equal file1 file2 = DB.equal_filename file1 file2
let hash = Hashtbl.hash
end)
@ -148,12 +149,12 @@ let get_source exe_env pname =
(get_file_data exe_env pname)
let file_data_to_tenv file_data =
if file_data.tenv = None
if is_none file_data.tenv
then file_data.tenv <- Tenv.load_from_file file_data.tenv_file;
file_data.tenv
let file_data_to_cfg file_data =
if file_data.cfg = None
if is_none file_data.cfg
then file_data.cfg <- Cfg.load_cfg_from_file file_data.cfg_file;
file_data.cfg

@ -24,7 +24,9 @@ let rec rmtree name =
let rec rmdir dir =
match Unix.readdir dir with
| entry ->
if not (entry = Filename.current_dir_name || entry = Filename.parent_dir_name) then (
if not (String.equal entry Filename.current_dir_name ||
String.equal entry Filename.parent_dir_name)
then (
rmtree (name ^/ entry)
);
rmdir dir
@ -40,6 +42,9 @@ let rec rmtree name =
type build_system =
| BAnalyze | BAnt | BBuck | BGradle | BJava | BJavac | BMake | BMvn | BNdk | BXcode
[@@deriving compare]
let equal_build_system = [%compare.equal : build_system]
(* List of ([build system], [executable name]). Several executables may map to the same build
system. In that case, the first one in the list will be used for printing, eg, in which mode
@ -73,6 +78,9 @@ type driver_mode =
| Maven of string * string list
| PythonCapture of build_system * string list
| XcodeXcpretty
[@@deriving compare]
let equal_driver_mode = [%compare.equal : driver_mode]
let pp_driver_mode fmt driver_mode =
let log_argfile_arg fname =
@ -122,8 +130,8 @@ let clean_results_dir () =
| entry ->
if (IList.exists (String.equal entry) dirs) then (
rmtree (name ^/ entry)
) else if not (entry = Filename.current_dir_name
|| entry = Filename.parent_dir_name) then (
) else if not (String.equal entry Filename.current_dir_name
|| String.equal entry Filename.parent_dir_name) then (
clean (name ^/ entry)
);
cleandir dir
@ -199,12 +207,12 @@ let capture = function
Maven.capture ~prog ~args
| PythonCapture (build_system, build_cmd) ->
L.stdout "Capturing in %s mode...@." (string_of_build_system build_system);
let in_buck_mode = build_system = BBuck in
let in_buck_mode = equal_build_system build_system BBuck in
let infer_py = Config.lib_dir ^/ "python" ^/ "infer.py" in
let args =
List.rev_append Config.anon_args (
["--analyzer";
IList.assoc (=) Config.analyzer
IList.assoc Config.equal_analyzer Config.analyzer
(IList.map (fun (n,a) -> (a,n)) Config.string_to_analyzer)] @
(match Config.blacklist with
| Some s when in_buck_mode -> ["--blacklist-regex"; s]
@ -244,10 +252,13 @@ let capture = function
else build_cmd
) in
run_command ~prog:infer_py ~args
(fun status ->
if status = Result.Error (`Exit_non_zero Config.infer_py_argparse_error_exit_code) then
(function
| Result.Error (`Exit_non_zero exit_code) ->
if Int.equal exit_code Config.infer_py_argparse_error_exit_code then
(* swallow infer.py argument parsing error *)
Config.print_usage_exit ()
| _ ->
()
)
| XcodeXcpretty ->
L.stdout "Capturing using xcpretty...@\n";
@ -270,7 +281,7 @@ let run_parallel_analysis () =
) (fun _ -> ())
let execute_analyze () =
if Config.jobs = 1 || Config.cluster_cmdline <> None then
if Int.equal Config.jobs 1 || Config.cluster_cmdline <> None then
InferAnalyze.main ""
else
run_parallel_analysis ()
@ -376,7 +387,8 @@ let get_driver_mode () =
let () =
let driver_mode = get_driver_mode () in
if not (driver_mode = Analyze || Config.(buck || continue_capture || maven || reactive_mode)) then
if not (equal_driver_mode driver_mode Analyze ||
Config.(buck || continue_capture || maven || reactive_mode)) then
remove_results_dir () ;
create_results_dir () ;
(* re-set log files, as default files were in results_dir removed above *)
@ -396,7 +408,7 @@ let () =
if CLOpt.is_originator then (
StatsAggregator.generate_files () ;
let in_buck_mode = match driver_mode with | PythonCapture (BBuck, _) -> true | _ -> false in
if Config.analyzer = Config.Crashcontext then
if Config.equal_analyzer Config.analyzer Config.Crashcontext then
Crashcontext.crashcontext_epilogue ~in_buck_mode;
if in_buck_mode then
clean_results_dir () ;

@ -49,7 +49,7 @@ let is_matching patterns =
IList.exists
(fun pattern ->
try
(Str.search_forward pattern path 0) = 0
Int.equal (Str.search_forward pattern path 0) 0
with Not_found -> false)
patterns
@ -57,8 +57,8 @@ let is_matching patterns =
(** Check if a proc name is matching the name given as string. *)
let match_method language proc_name method_name =
not (BuiltinDecl.is_declared proc_name) &&
Procname.get_language proc_name = language &&
Procname.get_method proc_name = method_name
Config.equal_language (Procname.get_language proc_name) language &&
String.equal (Procname.get_method proc_name) method_name
(* Module to create matcher based on strings present in the source file *)
module FileContainsStringMatcher = struct
@ -76,7 +76,7 @@ module FileContainsStringMatcher = struct
loop ()
let create_matcher s_patterns =
if s_patterns = [] then
if List.is_empty s_patterns then
default_matcher
else
let source_map = ref SourceFile.Map.empty in
@ -114,7 +114,7 @@ module FileOrProcMatcher = struct
fun _ _ -> false
let create_method_matcher m_patterns =
if m_patterns = [] then
if List.is_empty m_patterns then
default_matcher
else
let pattern_map =
@ -256,19 +256,19 @@ let patterns_of_json_with_key (json_key, json) =
IList.rev (IList.fold_left collect [] l) in
let create_method_pattern assoc =
let loop mp = function
| (key, `String s) when key = "class" ->
| (key, `String s) when String.equal key "class" ->
{ mp with class_name = s }
| (key, `String s) when key = "method" ->
| (key, `String s) when String.equal key "method" ->
{ mp with method_name = Some s }
| (key, `List l) when key = "parameters" ->
| (key, `List l) when String.equal key "parameters" ->
{ mp with parameters = Some (collect_params l) }
| (key, _) when key = "language" -> mp
| (key, _) when String.equal key "language" -> mp
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.fold_left loop default_method_pattern assoc
and create_string_contains assoc =
let loop sc = function
| (key, `String pattern) when key = "source_contains" -> pattern
| (key, _) when key = "language" -> sc
| (key, `String pattern) when String.equal key "source_contains" -> pattern
| (key, _) when String.equal key "language" -> sc
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.fold_left loop default_source_contains assoc in
match detect_pattern assoc with
@ -321,7 +321,7 @@ let load_filters analyzer =
let filters_from_inferconfig inferconfig : filters =
let path_filter =
let whitelist_filter : path_filter =
if inferconfig.whitelist = [] then default_path_filter
if List.is_empty inferconfig.whitelist then default_path_filter
else is_matching (IList.map Str.regexp inferconfig.whitelist) in
let blacklist_filter : path_filter =
is_matching (IList.map Str.regexp inferconfig.blacklist) in
@ -349,10 +349,10 @@ let create_filters analyzer =
(* Decide whether a checker or error type is enabled or disabled based on*)
(* white/black listing in .inferconfig and the default value *)
let is_checker_enabled checker_name =
match IList.mem (=) checker_name Config.disable_checks,
IList.mem (=) checker_name Config.enable_checks with
match IList.mem String.(=) checker_name Config.disable_checks,
IList.mem String.(=) checker_name Config.enable_checks with
| false, false -> (* if it's not amond white/black listed then we use default value *)
not (IList.mem (=) checker_name Config.checks_disabled_by_default)
not (IList.mem String.(=) checker_name Config.checks_disabled_by_default)
| true, false -> (* if it's blacklisted and not whitelisted then it should be disabled *)
false
| false, true -> (* if it is not blacklisted and it is whitelisted then it should be enabled *)

@ -430,7 +430,7 @@ let check_assignement_guard pdesc node =
let check_guard n =
IList.for_all check_instr (Procdesc.Node.get_instrs n) in
IList.for_all check_guard succs in
if !Config.curr_language = Config.Clang &&
if Config.curr_language_is Config.Clang &&
succs_are_all_prune_nodes () &&
succs_same_loc_as_node () &&
succs_have_simple_guards () then
@ -755,8 +755,8 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
let prop'' = Abs.abstract pname tenv prop' in
let pre, post = Prop.extract_spec prop'' in
let pre' = Prop.normalize tenv (Prop.prop_sub sub pre) in
if !Config.curr_language =
Config.Java && Procdesc.get_access pdesc <> PredSymb.Private then
if Config.curr_language_is Config.Java &&
Procdesc.get_access pdesc <> PredSymb.Private then
report_context_leaks pname post.Prop.sigma tenv;
let post' =
if Prover.check_inconsistency_base tenv prop then None
@ -1141,7 +1141,7 @@ let custom_error_preconditions summary =
let remove_this_not_null tenv prop =
let collect_hpred (var_option, hpreds) = function
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (Exp.Var var, _), _)
when !Config.curr_language = Config.Java && Pvar.is_this pvar ->
when Config.curr_language_is Config.Java && Pvar.is_this pvar ->
(Some var, hpreds)
| hpred -> (var_option, hpred:: hpreds) in
let collect_atom var atoms = function
@ -1325,9 +1325,9 @@ let analyze_proc source exe_env proc_desc : Specs.summary =
let prev_summary = Specs.get_summary_unsafe "analyze_proc" proc_name in
let updated_summary =
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_is Config.Clang && Config.report_custom_error then
report_custom_errors tenv updated_summary;
if !Config.curr_language = Config.Java && Config.report_runtime_exceptions then
if Config.curr_language_is Config.Java && Config.report_runtime_exceptions then
report_runtime_exceptions tenv proc_desc updated_summary;
updated_summary

@ -122,7 +122,7 @@ and fsel_match fsel1 sub vars fsel2 =
else Some (sub, vars) (* This can lead to great information loss *)
| (fld1, se1') :: fsel1', (fld2, se2') :: fsel2' ->
let n = Ident.compare_fieldname fld1 fld2 in
if (n = 0) then begin
if Int.equal n 0 then begin
match strexp_match se1' sub vars se2' with
| None -> None
| Some (sub', vars') -> fsel_match fsel1' sub' vars' fsel2'
@ -424,7 +424,7 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 =
(sub_eids, eids_fresh) in
let sub = Sil.sub_of_list (sub_ids @ sub_eids) in
match sigma2 with
| [] -> if sigma1 = [] then true else false
| [] -> if List.is_empty sigma1 then true else false
| hpred2 :: sigma2 ->
let (hpat2, hpats2) =
let (hpred2_ren, sigma2_ren) = (Sil.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2) in
@ -485,8 +485,9 @@ let sigma_remove_hpred eq sigma e =
(** {2 Routines used when finding disjoint isomorphic sigmas from a single sigma} *)
type iso_mode = Exact | LFieldForget | RFieldForget
type iso_mode = Exact | LFieldForget | RFieldForget [@@deriving compare]
let equal_iso_mode = [%compare.equal : iso_mode]
let rec generate_todos_from_strexp mode todos sexp1 sexp2 =
match sexp1, sexp2 with
@ -496,7 +497,7 @@ let rec generate_todos_from_strexp mode todos sexp1 sexp2 =
| Sil.Eexp _, _ ->
None
| 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) && equal_iso_mode mode Exact
then None
else generate_todos_from_fel mode todos fel1 fel2
| Sil.Estruct _, _ ->
@ -513,20 +514,20 @@ and generate_todos_from_fel mode todos fel1 fel2 =
| [], [] ->
Some todos
| [], _ ->
if mode = RFieldForget then Some todos else None
if equal_iso_mode mode RFieldForget then Some todos else None
| _, [] ->
if mode = LFieldForget then Some todos else None
if equal_iso_mode mode LFieldForget then Some todos else None
| (fld1, strexp1) :: fel1', (fld2, strexp2) :: fel2' ->
let n = Ident.compare_fieldname fld1 fld2 in
if (n = 0) then
if Int.equal n 0 then
begin
match generate_todos_from_strexp mode todos strexp1 strexp2 with
| None -> None
| Some todos' -> generate_todos_from_fel mode todos' fel1' fel2'
end
else if (n < 0 && mode = LFieldForget) then
else if (n < 0 && equal_iso_mode mode LFieldForget) then
generate_todos_from_fel mode todos fel1' fel2
else if (n > 0 && mode = RFieldForget) then
else if (n > 0 && equal_iso_mode mode RFieldForget) then
generate_todos_from_fel mode todos fel1 fel2'
else
None

@ -8,6 +8,7 @@
*)
open! IStd
open! PVariant
module L = Logging
module F = Format
@ -154,7 +155,8 @@ let should_link ~target ~target_results_dir ~stats infer_out_src infer_out_dst =
let was_copied () =
let captured_src = Filename.concat infer_out_src Config.captured_dir_name in
let captured_dst = Filename.concat infer_out_dst Config.captured_dir_name in
if Sys.file_exists captured_src = `Yes && Sys.is_directory captured_src = `Yes
if Sys.file_exists captured_src = `Yes &&
Sys.is_directory captured_src = `Yes
then
begin
let captured_files = Array.to_list (Sys.readdir captured_src) in

@ -8,6 +8,7 @@
*)
open! IStd
open! PVariant
(** Module for on-demand analysis. *)
@ -63,7 +64,7 @@ let should_be_analyzed proc_name proc_attributes =
let procedure_should_be_analyzed proc_name =
match AttributesTable.load_attributes proc_name with
| Some proc_attributes when Config.reactive_capture && proc_attributes.is_defined = false ->
| Some proc_attributes when Config.reactive_capture && not proc_attributes.is_defined ->
(* try to capture procedure first *)
let defined_proc_attributes = OndemandCapture.try_capture proc_attributes in
Option.value_map ~f:(should_be_analyzed proc_name) ~default:false defined_proc_attributes

@ -150,7 +150,7 @@ end = struct
module Invariant = struct
(** check whether a stats is the dummy stats *)
let stats_is_dummy stats =
stats.max_length = - 1
Int.equal stats.max_length (-1)
(** return the stats of the path, assumes that the stats are computed *)
let get_stats = function
@ -473,7 +473,7 @@ end = struct
| None -> "", []
| Some exn_name ->
let exn_str = Typename.name exn_name in
if exn_str = ""
if String.equal exn_str ""
then "exception", [(Io_infer.Xml.tag_kind,"exception")]
else
"exception " ^ exn_str,

@ -9,6 +9,7 @@
*)
open! IStd
open! PVariant
(** mutate the cfg/cg to add dynamic dispatch handling *)
let add_dispatch_calls pdesc cg tenv =
@ -28,7 +29,7 @@ let add_dispatch_calls pdesc cg tenv =
(((_, receiver_typ) :: _) as args), loc, call_flags) as instr
when call_flags_is_dispatch call_flags ->
(* the frontend should not populate the list of targets *)
assert (call_flags.CallFlags.cf_targets = []);
assert (List.is_empty call_flags.CallFlags.cf_targets);
let receiver_typ_no_ptr = match receiver_typ with
| Typ.Tptr (typ', _) ->
typ'

@ -34,7 +34,7 @@ struct
let line_raw = input_line cin in
let line =
let len = String.length line_raw in
if len > 0 && String.get line_raw (len -1) = '\013' then
if len > 0 && Char.equal (String.get line_raw (len -1)) '\013' then
String.sub line_raw ~pos:0 ~len:(len -1)
else line_raw in
lines := line :: !lines
@ -401,7 +401,7 @@ let node_start_session node session source =
(** Finish a session, and perform delayed print actions if required *)
let node_finish_session node source =
if Config.test = false then force_delayed_prints ()
if not Config.test then force_delayed_prints ()
else L.reset_delayed_prints ();
if Config.write_html then begin
F.fprintf !curr_html_formatter "</LISTING>%a"

@ -33,11 +33,9 @@ type exposed (** kind for exposed props *)
type pi = Sil.atom list [@@deriving compare]
type sigma = Sil.hpred list [@@deriving compare]
let equal_pi pi1 pi2 =
compare_pi pi1 pi2 = 0
let equal_pi = [%compare.equal : pi]
let equal_sigma sigma1 sigma2 =
compare_sigma sigma1 sigma2 = 0
let equal_sigma = [%compare.equal : sigma]
module Core : sig
@ -116,7 +114,7 @@ let compare_prop p1 p2 =
(** Check the equality of two propositions *)
let equal_prop p1 p2 =
compare_prop p1 p2 = 0
Int.equal (compare_prop p1 p2) 0
(** {1 Functions for Pretty Printing} *)
@ -305,7 +303,7 @@ let prop_pred_env prop =
(** Pretty print a proposition. *)
let pp_prop pe0 f prop =
let pe = prop_update_obj_sub pe0 prop in
let latex = pe.Pp.kind = Pp.LATEX in
let latex = Pp.equal_print_kind pe.Pp.kind Pp.LATEX in
let do_print f () =
let subl = Sil.sub_to_list prop.sub in
(* since prop diff is based on physical equality, we need to extract the sub verbatim *)
@ -465,7 +463,8 @@ let rec create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Sil
let fresh_id =
(Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) in
Exp.Var fresh_id in
if !Config.curr_language = Config.Java && inst = Sil.Ialloc
if Config.curr_language_is Config.Java &&
Sil.equal_inst inst Sil.Ialloc
then
match typ with
| Tfloat _ -> Exp.Const (Cfloat 0.0)
@ -619,7 +618,7 @@ let compute_reachable_hpreds sigma exps =
(reach', Exp.Set.union exps reach_exps)
| _ -> reach, exps in
let reach', exps' = IList.fold_left add_hpred_if_reachable (reach, exps) sigma in
if (Sil.HpredSet.cardinal reach) = (Sil.HpredSet.cardinal reach') then (reach, exps)
if Int.equal (Sil.HpredSet.cardinal reach) (Sil.HpredSet.cardinal reach') then (reach, exps)
else compute_reachable_hpreds_rec sigma (reach', exps') in
compute_reachable_hpreds_rec sigma (Sil.HpredSet.empty, exps)
@ -705,10 +704,10 @@ module Normalize = struct
| Const _ ->
e
| Sizeof (Tarray (Tint ik, _), Some l, _)
when Typ.ikind_is_char ik && !Config.curr_language = Config.Clang ->
when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang ->
eval l
| Sizeof (Tarray (Tint ik, Some l), _, _)
when Typ.ikind_is_char ik && !Config.curr_language = Config.Clang ->
when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang ->
Const (Cint l)
| Sizeof _ ->
e
@ -789,7 +788,7 @@ module Normalize = struct
| Const (Cint n), Const (Cint m) ->
Exp.bool (IntLit.eq n m)
| Const (Cfloat v), Const (Cfloat w) ->
Exp.bool (v = w)
Exp.bool (Float.equal v w)
| e1', e2' ->
Exp.eq e1' e2'
end
@ -847,7 +846,7 @@ module Normalize = struct
| BinOp (PlusPI as oplus, e1, e2) ->
let e1' = eval e1 in
let e2' = eval e2 in
let isPlusA = oplus = Binop.PlusA in
let isPlusA = Binop.equal oplus Binop.PlusA in
let ominus = if isPlusA then Binop.MinusA else Binop.MinusPI in
let (+++) (x : Exp.t) (y : Exp.t) : Exp.t = match x, y with
| _, Const (Cint i) when IntLit.iszero i -> x
@ -910,7 +909,7 @@ module Normalize = struct
| BinOp (MinusPI as ominus, e1, e2) ->
let e1' = eval e1 in
let e2' = eval e2 in
let isMinusA = ominus = Binop.MinusA in
let isMinusA = Binop.equal ominus Binop.MinusA in
let oplus = if isMinusA then Binop.PlusA else Binop.PlusPI in
let (+++) x y : Exp.t = BinOp (oplus, x, y) in
let (---) x y : Exp.t = BinOp (ominus, x, y) in
@ -1575,7 +1574,7 @@ module Normalize = struct
unsafe_cast_to_normal
(set p ~sub:nsub' ~pi:npi' ~sigma:nsigma'') in
IList.fold_left (prop_atom_and tenv ~footprint) p' eqs_zero
| Aeq (e1, e2) when (Exp.compare e1 e2 = 0) ->
| Aeq (e1, e2) when Exp.equal e1 e2 ->
p
| Aneq (e1, e2) ->
let sigma' = sigma_intro_nonemptylseg e1 e2 p.sigma in
@ -2117,7 +2116,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 ids = Sil.fav_to_list fav in
if IList.exists Ident.is_primed ids then assert false; (* sanity check *)
if ids = [] then prop else
if List.is_empty ids then prop else
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 prop' =
@ -2441,7 +2440,7 @@ let hpred_gc_fields (fav: Sil.fav) (hpred : Sil.hpred) : Sil.hpred = match hpred
(match strexp_gc_fields fav se with
| None -> hpred
| Some se' ->
if Sil.compare_strexp se se' = 0 then hpred
if Sil.equal_strexp se se' then hpred
else Hpointsto (e, se', te))
| Hlseg _ | Hdllseg _ ->
hpred
@ -2565,7 +2564,7 @@ module CategorizePreconditions = struct
false in
let check_pre hpred_filter pre =
let check_pi pi =
pi = [] in
List.is_empty pi in
let check_sigma sigma =
IList.for_all hpred_filter sigma in
check_pi pre.pi && check_sigma pre.sigma in

@ -74,7 +74,7 @@ end = struct
type t = Exp.t * Exp.t * IntLit.t [@@deriving compare]
let equal entry1 entry2 = compare entry1 entry2 = 0
let equal = [%compare.equal : t]
let to_leq (e1, e2, n) =
Exp.BinOp(Binop.MinusA, e1, e2), Exp.int n
@ -124,7 +124,7 @@ end = struct
let sort_then_remove_redundancy constraints =
let constraints_sorted = IList.sort compare constraints in
let have_same_key (e1, e2, _) (f1, f2, _) = [%compare: Exp.t * Exp.t] (e1, e2) (f1, f2) = 0 in
let have_same_key (e1, e2, _) (f1, f2, _) = [%compare.equal: Exp.t * Exp.t] (e1, e2) (f1, f2) in
remove_redundancy have_same_key [] constraints_sorted
let remove_redundancy constraints =
@ -140,9 +140,9 @@ end = struct
let e1, e2, n = constr in
let f1, f2, m = constr' in
let c1 = [%compare: Exp.t * Exp.t] (e1, e2) (f1, f2) in
if c1 = 0 && IntLit.lt n m then
if Int.equal c1 0 && IntLit.lt n m then
combine acc_todos acc_seen constraints_new rest'
else if c1 = 0 then
else if Int.equal c1 0 then
combine acc_todos acc_seen rest constraints_old
else if c1 < 0 then
combine (constr:: acc_todos) (constr:: acc_seen) rest constraints_old
@ -484,7 +484,7 @@ end = struct
IList.map (function
| _, Exp.Const (Const.Cint n) -> n
| _ -> assert false) e_upper_list in
if upper_list = [] then None
if List.is_empty upper_list then None
else Some (compute_min_from_nonempty_int_list upper_list)
(** Find a IntLit.t n such that [t |- n < e] if possible. *)
@ -501,7 +501,7 @@ end = struct
IList.map (function
| Exp.Const (Const.Cint n), _ -> n
| _ -> assert false) e_lower_list in
if lower_list = [] then None
if List.is_empty lower_list then None
else Some (compute_max_from_nonempty_int_list lower_list)
(** 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
in f sigma_irrelevant' e sigma_rest
| Some _ ->
if (k = Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then
if (Sil.equal_lseg_kind k Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else if (Exp.equal e2 Exp.zero) then
@ -782,13 +782,18 @@ let check_allocatedness tenv prop e =
| Sil.Hpointsto (base, _, _) ->
is_root tenv prop base n_e <> None
| Sil.Hlseg (k, _, e1, e2, _) ->
if k = Sil.Lseg_NE || check_disequal tenv prop e1 e2 then
if Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop e1 e2 then
is_root tenv prop e1 n_e <> None
else false
else
false
| 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 Sil.equal_lseg_kind 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
else false
else
false
in IList.exists f spatial_part
(** Compute an upper bound of an expression *)
@ -861,13 +866,14 @@ let check_inconsistency_base tenv prop =
let procedure_attr =
Procdesc.get_attributes pdesc in
let is_java_this pvar =
procedure_attr.ProcAttributes.language = Config.Java && Pvar.is_this pvar in
Config.equal_language procedure_attr.ProcAttributes.language Config.Java &&
Pvar.is_this pvar in
let is_objc_instance_self pvar =
procedure_attr.ProcAttributes.language = Config.Clang &&
Pvar.get_name pvar = Mangled.from_string "self" &&
Config.equal_language procedure_attr.ProcAttributes.language Config.Clang &&
Mangled.equal (Pvar.get_name pvar) (Mangled.from_string "self") &&
procedure_attr.ProcAttributes.is_objc_instance_method in
let is_cpp_this pvar =
procedure_attr.ProcAttributes.language = Config.Clang &&
Config.equal_language procedure_attr.ProcAttributes.language Config.Clang &&
Pvar.is_this pvar &&
procedure_attr.ProcAttributes.is_cpp_instance_method in
let do_hpred = function
@ -885,7 +891,7 @@ let check_inconsistency_base tenv prop =
| Sil.Aneq (e1, e2) ->
(match e1, e2 with
| Exp.Const c1, Exp.Const c2 -> Const.equal c1 c2
| _ -> (Exp.compare e1 e2 = 0))
| _ -> Exp.equal e1 e2)
| Sil.Apred _ | Anpred _ -> false in
let inconsistent_inequalities () =
let ineq = Inequalities.from_prop tenv prop in
@ -1202,7 +1208,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))))
| Exp.Const (Const.Cint n1), Exp.BinOp (Binop.PlusA, f1, Exp.Const (Const.Cint n2)) ->
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 Binop.equal op1 op2 ->
do_imply (do_imply subs e1 e2) f1 f2
| Exp.BinOp (Binop.PlusA, Exp.Var v1, e1), e2 ->
do_imply subs (Exp.Var v1) (Exp.BinOp (Binop.MinusA, e2, e1))
@ -1846,7 +1852,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
raise (Exceptions.Abduction_case_not_implemented __POS__))
| _ -> ()
in
if Exp.equal e2 f2 && k = Sil.Lseg_PE then (subs, prop1)
if Exp.equal e2 f2 && Sil.equal_lseg_kind k Sil.Lseg_PE then (subs, prop1)
else
(match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
@ -2218,7 +2224,7 @@ let is_cover tenv cases =
let cnt = ref 0 in (* counter for timeout checks, as this function can take exponential time *)
let check () =
incr cnt;
if (!cnt mod 100 = 0) then SymOp.check_wallclock_alarm () in
if Int.equal (!cnt mod 100) 0 then SymOp.check_wallclock_alarm () in
let rec _is_cover acc_pi cases =
check ();
match cases with

@ -268,7 +268,7 @@ let rec _strexp_extend_values
let replace acc (res_atoms', res_se', res_typ') =
let replace_ise ise = if Exp.equal e (fst ise) then (e, res_se') else ise in
let res_esel' = IList.map replace_ise esel in
if (Typ.equal res_typ' typ') || (IList.length res_esel' = 1) then
if (Typ.equal res_typ' typ') || Int.equal (IList.length res_esel') 1 then
( res_atoms'
, Sil.Earray (len, res_esel', inst_arr)
, Typ.Tarray (res_typ', len_for_typ') )
@ -293,7 +293,7 @@ and array_case_analysis_index pname tenv orig_prop
index off inst_arr inst
=
let check_sound t' =
if not (Typ.equal typ_cont t' || array_cont = [])
if not (Typ.equal typ_cont t' || List.is_empty array_cont)
then raise (Exceptions.Bad_footprint __POS__) in
let index_in_array =
IList.exists (fun (i, _) -> Prover.check_equal tenv Prop.prop_emp index i) array_cont in
@ -620,7 +620,9 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
(* don't warn on @GuardedBy("ui_thread") in any form *)
let is_ui_thread str =
let lowercase_str = String.lowercase str in
lowercase_str = "ui_thread" || lowercase_str = "ui-thread" || lowercase_str = "uithread" in
String.equal lowercase_str "ui_thread" ||
String.equal lowercase_str "ui-thread" ||
String.equal lowercase_str "uithread" in
is_invalid_exp_str str || is_ui_thread str in
let guarded_by_str_is_this guarded_by_str =
String.is_suffix ~suffix:"this" guarded_by_str in
@ -699,8 +701,8 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
let is_guarded_by_fld guarded_by_str fld _ =
(* this comparison needs to be somewhat fuzzy, since programmers are free to write
@GuardedBy("mLock"), @GuardedBy("MyClass.mLock"), or use other conventions *)
Ident.fieldname_to_flat_string fld = guarded_by_str ||
Ident.fieldname_to_string fld = guarded_by_str in
String.equal (Ident.fieldname_to_flat_string fld) guarded_by_str ||
String.equal (Ident.fieldname_to_string fld) guarded_by_str in
let get_fld_strexp_and_typ typ f flds =
let match_one (fld, strexp) =
@ -779,7 +781,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
match extract_guarded_by_str proc_annot with
| Some proc_guarded_by_str ->
(* the lock is not held, but the procedure is annotated with @GuardedBy *)
proc_guarded_by_str = guarded_by_str
String.equal proc_guarded_by_str guarded_by_str
| None -> false in
let is_synchronized_on_class guarded_by_str =
guarded_by_str_is_current_class guarded_by_str pname &&
@ -820,7 +822,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
let proc_annot, _ = proc_signature.Annotations.ret in
match extract_suppress_warnings_str proc_annot with
| Some suppression_str->
suppression_str = "InvalidAccessToGuardedField"
String.equal suppression_str "InvalidAccessToGuardedField"
| None -> false in
let should_warn pdesc =
(* adding this check implements "by reference" semantics for guarded-by rather than "by value"
@ -1137,7 +1139,8 @@ let check_type_size tenv pname prop texp off typ_from_instr =
match type_at_offset tenv texp off with
| Some typ_of_object ->
L.d_str "typ_o: "; Typ.d_full typ_of_object; L.d_ln ();
if Prover.type_size_comparable typ_from_instr typ_of_object && Prover.check_type_size_leq typ_from_instr typ_of_object = false
if Prover.type_size_comparable typ_from_instr typ_of_object &&
not (Prover.check_type_size_leq typ_from_instr typ_of_object)
then begin
let deref_str = Localise.deref_str_pointer_size_mismatch typ_from_instr typ_of_object in
let loc = State.get_loc () in
@ -1419,7 +1422,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc =
Some (Exp.Lfield(e'', fn, t)), true (* the block dereferences is a field of an object*)
| Some (_, e) -> Some e, false
| _ -> None, false in
if (!Config.curr_language = Config.Clang) &&
if Config.curr_language_is Config.Clang &&
fun_exp_may_be_null () &&
not (is_fun_exp_captured_var ()) then
begin

@ -53,7 +53,7 @@ let log_issue
?ltr
exn =
let should_suppress_lint summary =
!Config.curr_language = Config.Java &&
Config.curr_language_is Config.Java &&
let annotated_signature =
Annotations.get_annotated_signature summary.Specs.attributes in
let ret_annotation, _ = annotated_signature.Annotations.ret in

@ -9,6 +9,7 @@
*)
open! IStd
open! PVariant
module Hashtbl = Caml.Hashtbl
(** Specifications and spec table *)
@ -36,7 +37,7 @@ module Jprop = struct
(** Return true if the two join_prop's are equal *)
let equal jp1 jp2 =
compare jp1 jp2 = 0
Int.equal (compare jp1 jp2) 0
let to_prop = function
| Prop (_, p) -> p
@ -303,9 +304,13 @@ type stats =
call_stats : call_stats;
}
type status = ACTIVE | INACTIVE | STALE
type status = ACTIVE | INACTIVE | STALE [@@deriving compare]
type phase = FOOTPRINT | RE_EXECUTION
let equal_status = [%compare.equal : status]
type phase = FOOTPRINT | RE_EXECUTION [@@deriving compare]
let equal_phase = [%compare.equal : phase]
type dependency_map_t = int Procname.Map.t
@ -412,10 +417,10 @@ let describe_timestamp summary =
("Timestamp", Printf.sprintf "%d" summary.timestamp)
let describe_status summary =
("Status", if summary.status = ACTIVE then "ACTIVE" else "INACTIVE")
("Status", if equal_status summary.status ACTIVE then "ACTIVE" else "INACTIVE")
let describe_phase summary =
("Phase", if summary.phase = FOOTPRINT then "FOOTPRINT" else "RE_EXECUTION")
("Phase", if equal_phase summary.phase FOOTPRINT then "FOOTPRINT" else "RE_EXECUTION")
(** Return the signature of a procedure declaration as a string *)
let get_signature summary =
@ -424,7 +429,7 @@ let get_signature summary =
(fun (p, typ) ->
let pp f = F.fprintf f "%a %a" (Typ.pp_full Pp.text) typ Mangled.pp p in
let decl = F.asprintf "%t" pp in
s := if !s = "" then decl else !s ^ ", " ^ decl)
s := if String.equal !s "" then decl else !s ^ ", " ^ decl)
summary.attributes.ProcAttributes.formals;
let pp f =
F.fprintf
@ -669,7 +674,7 @@ let get_status summary =
summary.status
let is_active summary =
get_status summary = ACTIVE
equal_status (get_status summary) ACTIVE
let get_timestamp summary =
summary.timestamp

@ -214,7 +214,7 @@ let mk_find_duplicate_nodes proc_desc : (Procdesc.Node.t -> Procdesc.NodeSet.t)
| _ -> raise Not_found in
let duplicates =
let equal_normalized_instrs (_, normalized_instrs') =
IList.compare Sil.compare_instr node_normalized_instrs normalized_instrs' = 0 in
IList.equal Sil.compare_instr node_normalized_instrs normalized_instrs' in
IList.filter equal_normalized_instrs elements in
IList.fold_left
(fun nset (node', _) -> Procdesc.NodeSet.add node' nset)
@ -283,7 +283,7 @@ let mark_execution_start node =
let mark_execution_end node =
let fs = get_failure_stats node in
let success = fs.instr_fail = 0 in
let success = Int.equal fs.instr_fail 0 in
fs.instr_ok <- 0;
fs.instr_fail <- 0;
if success then fs.node_ok <- fs.node_ok + 1
@ -299,7 +299,7 @@ let mark_instr_fail exn =
let session = get_session () in
let loc_trace = get_loc_trace () in
let fs = get_failure_stats (get_node ()) in
if fs.first_failure = None then
if is_none fs.first_failure then
fs.first_failure <- Some (loc, key, (session :> int), loc_trace, exn);
fs.instr_fail <- fs.instr_fail + 1

@ -9,6 +9,7 @@
*)
open! IStd
open! PVariant
(** Symbolic Execution *)
@ -108,7 +109,7 @@ let rec apply_offlist
(* we are in a lookup of an uninitialized value *)
lookup_inst := Some inst_curr;
let alloc_attribute_opt =
if inst_curr = Sil.Iinitial then None
if Sil.equal_inst inst_curr Sil.Iinitial then None
else Attribute.get_undef tenv p root_lexp in
let deref_str = Localise.deref_str_uninitialized alloc_attribute_opt in
let err_desc = Errdesc.explain_memory_access tenv deref_str p (State.get_loc ()) in
@ -381,7 +382,7 @@ let call_should_be_skipped callee_summary =
(* skip abstract methods *)
|| callee_summary.Specs.attributes.ProcAttributes.is_abstract
(* treat calls with no specs as skip functions in angelic mode *)
|| (Config.angelic_execution && Specs.get_specs_from_payload callee_summary = [])
|| (Config.angelic_execution && List.is_empty (Specs.get_specs_from_payload callee_summary))
(** In case of constant string dereference, return the result immediately *)
let check_constant_string_dereference lexp =
@ -472,7 +473,7 @@ let check_deallocate_static_memory prop_after =
prop_after
let method_exists right_proc_name methods =
if !Config.curr_language = Config.Java then
if Config.curr_language_is Config.Java then
IList.exists (fun meth_name -> Procname.equal right_proc_name meth_name) methods
else (* ObjC/C++ case : The attribute map will only exist when we have code for the method or
the method has been called directly somewhere. It can still be that this is not the
@ -681,11 +682,11 @@ let call_constructor_url_update_args pname actual_params =
let parts = Str.split (Str.regexp_string "://") s in
(match parts with
| frst:: _ ->
if frst = "http" ||
frst = "ftp" ||
frst = "https" ||
frst = "mailto" ||
frst = "jar"
if String.equal frst "http" ||
String.equal frst "ftp" ||
String.equal frst "https" ||
String.equal frst "mailto" ||
String.equal frst "jar"
then
[this; (Exp.Const (Const.Cstr frst), atype)]
else actual_params
@ -770,7 +771,7 @@ let normalize_params tenv pdesc prop actual_params =
let do_error_checks tenv node_opt instr pname pdesc = match node_opt with
| Some node ->
if !Config.curr_language = Config.Java then
if Config.curr_language_is Config.Java then
PrintfArgs.check_printf_args_ok tenv node instr pname pdesc
| None ->
()
@ -932,7 +933,7 @@ let execute_load ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc
Rearrange.rearrange ~report_deref_errors pdesc tenv n_rhs_exp' typ prop' loc in
IList.rev (IList.fold_left (execute_load_ pdesc tenv id loc) [] iter_list)
with Rearrange.ARRAY_ACCESS ->
if (Config.array_level = 0) then assert false
if Int.equal Config.array_level 0 then assert false
else
let undef = Exp.get_undefined false in
[Prop.conjoin_eq tenv (Exp.Var id) undef prop_]
@ -971,7 +972,7 @@ let execute_store ?(report_deref_errors=true) pname pdesc tenv lhs_exp typ rhs_e
let iter_list = Rearrange.rearrange ~report_deref_errors pdesc tenv n_lhs_exp' typ prop loc in
IList.rev (IList.fold_left (execute_store_ pdesc tenv n_rhs_exp) [] iter_list)
with Rearrange.ARRAY_ACCESS ->
if (Config.array_level = 0) then assert false
if Int.equal Config.array_level 0 then assert false
else [prop_]
(** Execute [instr] with a symbolic heap [prop].*)
@ -1116,7 +1117,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
let callee_pdesc_opt = Ondemand.get_proc_desc resolved_pname in
let ret_typ_opt = Option.map ~f:Procdesc.get_ret_type callee_pdesc_opt in
let sentinel_result =
if !Config.curr_language = Config.Clang then
if Config.curr_language_is Config.Clang then
check_variadic_sentinel_if_present
(call_args prop_r callee_pname actual_params ret_id loc)
else [(prop_r, path)] in
@ -1391,7 +1392,8 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots
let check_taint_if_nums_match (prop_acc, param_num) (actual_exp, _actual_typ) =
let prop_acc' =
try
let _, taint_kind = IList.find (fun (num, _) -> num = param_num) param_nums in
let _, taint_kind =
IList.find (fun (num, _) -> Int.equal num param_num) param_nums in
check_untainted tenv actual_exp taint_kind caller_pname callee_pname prop_acc
with Not_found -> prop_acc in
prop_acc', param_num + 1 in
@ -1535,7 +1537,7 @@ and proc_call summary {Builtin.pdesc; tenv; prop_= pre; path; ret_id; args= actu
| _, None -> true
| _, Some (id, _) -> Errdesc.id_is_assigned_then_dead (State.get_node ()) id in
if is_ignored
&& Specs.get_flag summary ProcAttributes.proc_flag_ignore_return = None then
&& is_none (Specs.get_flag summary ProcAttributes.proc_flag_ignore_return) then
let err_desc = Localise.desc_return_value_ignored callee_pname loc in
let exn = (Exceptions.Return_value_ignored (err_desc, __POS__)) in
Reporting.log_warning caller_pname exn in
@ -1598,7 +1600,7 @@ and sym_exec_wrapper handle_exn tenv pdesc instr ((prop: Prop.normal Prop.t), pa
let fav_normal = Sil.fav_from_list (IList.map snd ids_primed_normal) in
p', fav_normal in
let prop_normal_to_primed fav_normal p = (* rename given normal vars to fresh primed *)
if Sil.fav_to_list fav_normal = [] then p
if List.is_empty (Sil.fav_to_list fav_normal) then p
else Prop.exist_quantify tenv fav_normal p in
try
let pre_process_prop p =

@ -123,7 +123,7 @@ let spec_find_rename trace_call (proc_name : Procname.t)
let f spec =
incr count; (!count, spec_rename_vars proc_name spec) in
let specs, formals = Specs.get_specs_formals proc_name in
if specs = [] then
if List.is_empty specs then
begin
trace_call Specs.CallStats.CR_not_found;
raise (Exceptions.Precondition_not_found
@ -166,7 +166,7 @@ let process_splitting
let fav_sub2 = (* vars which represent expansions of fields *)
let fav = Sil.fav_new () in
IList.iter (Sil.exp_fav_add fav) (Sil.sub_range sub2);
let filter id = Ident.get_stamp id = - 1 in
let filter id = Int.equal (Ident.get_stamp id) (-1) in
Sil.fav_filter_ident fav filter;
fav in
let fav_pre = Prop.prop_fav actual_pre in
@ -267,12 +267,12 @@ let rec find_dereference_without_null_check_in_sexp = function
| Sil.Eexp (_, inst) -> find_dereference_without_null_check_in_inst inst
| Sil.Estruct (fsel, inst) ->
let res = find_dereference_without_null_check_in_inst inst in
if res = None then
if is_none res then
find_dereference_without_null_check_in_sexp_list (IList.map snd fsel)
else res
| Sil.Earray (_, esel, inst) ->
let res = find_dereference_without_null_check_in_inst inst in
if res = None then
if is_none res then
find_dereference_without_null_check_in_sexp_list (IList.map snd esel)
else res
and find_dereference_without_null_check_in_sexp_list = function
@ -386,7 +386,8 @@ let post_process_post tenv
| _ -> false in
let atom_update_alloc_attribute = function
| Sil.Apred (Aresource ra, [e])
when not (ra.ra_kind = PredSymb.Rrelease && actual_pre_has_freed_attribute e) ->
when not (PredSymb.equal_res_act_kind ra.ra_kind PredSymb.Rrelease &&
actual_pre_has_freed_attribute e) ->
(* unless it was already freed before the call *)
let vpath, _ = Errdesc.vpath_find tenv post e in
let ra' = { ra with ra_pname = callee_pname; ra_loc = loc; ra_vpath = vpath } in
@ -467,7 +468,8 @@ let texp_star tenv texp1 texp2 =
| _ -> ftal_sub ftal1 ftal2' end in
let typ_star (t1: Typ.t) (t2: Typ.t) =
match t1, t2 with
| Tstruct (TN_csu (csu1, _) as name1), Tstruct (TN_csu (csu2, _) as name2) when csu1 = csu2 -> (
| Tstruct (TN_csu (csu1, _) as name1), Tstruct (TN_csu (csu2, _) as name2)
when Csu.equal csu1 csu2 -> (
match Tenv.lookup tenv name1, Tenv.lookup tenv name2 with
| Some { fields = fields1 }, Some { fields = fields2 } when ftal_sub fields1 fields2 ->
t2
@ -678,7 +680,7 @@ let combine tenv
let caller_pname = Procdesc.get_proc_name caller_pdesc in
let instantiated_post =
let posts' =
if !Config.footprint && posts = []
if !Config.footprint && List.is_empty posts
then (* in case of divergence, produce a prop *)
(* with updated footprint and inconsistent current *)
[(Prop.set Prop.prop_emp ~pi:[Sil.Aneq (Exp.zero, Exp.zero)], path_pre)]
@ -761,7 +763,7 @@ let combine tenv
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
Prop.conjoin_eq tenv e' (Exp.Var id) p
| Sil.Hpointsto (_, Sil.Estruct (ftl, _), _), _
when IList.length ftl = (if ret_id = None then 0 else 1) ->
when Int.equal (IList.length ftl) (if is_none ret_id then 0 else 1) ->
(* TODO(jjb): Is this case dead? *)
let rec do_ftl_ids p = function
| [], None -> p
@ -787,7 +789,7 @@ let combine tenv
else Some post_p3 in
post_p4 in
let _results = IList.map (fun (p, path) -> (compute_result p, path)) instantiated_post in
if IList.exists (fun (x, _) -> x = None) _results then (* at least one combine failed *)
if IList.exists (fun (x, _) -> is_none x) _results then (* at least one combine failed *)
None
else
let results =
@ -827,7 +829,7 @@ let report_taint_error e taint_info callee_pname caller_pname calling_prop =
let check_taint_on_variadic_function tenv callee_pname caller_pname actual_params calling_prop =
let rec n_tail lst n = (* return the tail of a list from element n *)
if n = 1 then lst
if Int.equal n 1 then lst
else match lst with
| [] -> []
| _::lst' -> n_tail lst' (n-1) in
@ -916,7 +918,7 @@ let mk_posts tenv ret_id prop callee_pname callee_attrs posts =
IList.map taint_retval posts
| None -> posts in
let posts' =
if Config.idempotent_getters && !Config.curr_language = Config.Java
if Config.idempotent_getters && Config.curr_language_is Config.Java
then mk_getter_idempotent posts
else posts in
if Config.taint_analysis then mk_retval_tainted posts' else posts'
@ -1080,12 +1082,12 @@ let exe_spec
(* missing fields minus hidden fields *)
let missing_fld_nohidden =
IList.filter (fun hp -> not (hpred_missing_hidden hp)) missing_fld in
if !Config.footprint = false && split.missing_sigma <> [] then
if not !Config.footprint && split.missing_sigma <> [] then
begin
L.d_strln "Implication error: missing_sigma not empty in re-execution";
Invalid_res Missing_sigma_not_empty
end
else if !Config.footprint = false && missing_fld_nohidden <> [] then
else if not !Config.footprint && missing_fld_nohidden <> [] then
begin
L.d_strln "Implication error: missing_fld not empty in re-execution";
Invalid_res Missing_fld_not_empty
@ -1119,7 +1121,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
let pure = Prop.get_pure p in
let new_footprint_atoms = IList.filter is_footprint_atom_not_attribute pure in
if new_footprint_atoms = []
if List.is_empty new_footprint_atoms
then p
else (* add pure fact to footprint *)
Prop.normalize tenv (Prop.set p ~pi_fp:(p.Prop.pi_fp @ new_footprint_atoms))
@ -1146,7 +1148,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
let res_with_path_idents =
if !Config.footprint then
begin
if valid_res_cons_pre_missing = [] then
if List.is_empty valid_res_cons_pre_missing then
(* no valid results where actual pre and missing are consistent *)
begin
if deref_errors <> [] then (* dereference error detected *)
@ -1211,7 +1213,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
else (* combine the valid results, and store diverging states *)
let process_valid_res vr =
let save_diverging_states () =
if not vr.incons_pre_missing && vr.vr_cons_res = []
if not vr.incons_pre_missing && List.is_empty vr.vr_cons_res
then (* no consistent results on one spec: divergence *)
let incons_res =
IList.map
@ -1226,7 +1228,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
end
else if valid_res_no_miss_pi <> [] then
IList.flatten (IList.map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
else if valid_res_miss_pi = [] then
else if List.is_empty valid_res_miss_pi then
raise (Exceptions.Precondition_not_met (call_desc None, __POS__))
else
begin
@ -1253,11 +1255,11 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
let should_add_ret_attr _ =
let is_likely_getter = function
| Procname.Java pn_java ->
IList.length (Procname.java_get_parameters pn_java) = 0
Int.equal (IList.length (Procname.java_get_parameters pn_java)) 0
| _ ->
false in
(Config.idempotent_getters &&
!Config.curr_language = Config.Java &&
Config.curr_language_is Config.Java &&
is_likely_getter callee_pname)
|| returns_nullable ret_annot in
match ret_id with

@ -361,7 +361,7 @@ let has_taint_annotation fieldname (struct_typ: StructTyp.t) =
(* add tainting attributes to a list of paramenters *)
let get_params_to_taint tainted_param_nums formal_params =
let get_taint_kind index =
try Some (IList.find (fun (taint_index, _) -> index = taint_index) tainted_param_nums)
try Some (IList.find (fun (taint_index, _) -> Int.equal index taint_index) tainted_param_nums)
with Not_found -> None in
let collect_params_to_taint params_to_taint_acc (index, param) =
match get_taint_kind index with

@ -14,6 +14,8 @@ open! IStd
module F = Format
module YBU = Yojson.Basic.Util
let (=) = String.equal
(** This is the subset of Arg.spec that we actually use. What's important is that all these specs
call back functions. We use this to mark deprecated arguments. What's not important is that, eg,
Arg.Float is missing. *)
@ -34,8 +36,10 @@ let is_env_var_set v =
(** Each command line option may appear in the --help list of any executable, these tags are used to
specify which executables for which an option will be documented. *)
type exe = Analyze | Clang | Driver | Interactive | Print
type exe = Analyze | Clang | Driver | Interactive | Print [@@deriving compare]
let equal_exe = [%compare.equal : exe]
(** Association list of executable (base)names to their [exe]s. *)
let exes = [
@ -48,7 +52,7 @@ let exes = [
let exe_name =
let exe_to_name = IList.map (fun (n,a) -> (a,n)) exes in
fun exe -> IList.assoc (=) exe exe_to_name
fun exe -> IList.assoc equal_exe exe exe_to_name
let frontend_exes = [Clang]
@ -113,7 +117,7 @@ let xdesc {long; short; spec; doc} =
(* translate Symbol to String for better formatting of --help messages *)
| Symbol (symbols, action) ->
String (fun arg ->
if IList.mem ( = ) arg symbols then
if IList.mem String.equal arg symbols then
action arg
else
raise (Arg.Bad (F.sprintf "wrong argument '%s'; option '%s' expects one of: %s"
@ -135,7 +139,7 @@ let wrap_line indent_string wrap_length line =
if new_length > wrap_length && non_empty then
(line::rev_lines, true, indent_string ^ word, indent_length + word_length)
else
let sep = if line_length = indent_length then "" else word_sep in
let sep = if Int.equal line_length indent_length then "" else word_sep in
let new_line = line ^ sep ^ word in
if new_length > wrap_length && new_non_empty then
(new_line::rev_lines, false, indent_string, indent_length)
@ -222,7 +226,7 @@ let add exes desc =
full_desc_list := desc :: !full_desc_list ;
IList.iter (fun (exe, desc_list) ->
let desc =
if IList.mem ( = ) exe exes then
if IList.mem equal_exe exe exes then
desc
else
{desc with meta = ""; doc = ""} in
@ -444,11 +448,11 @@ let mk_path_list ?(default=[]) ?(deprecated=[]) ~long ?short ?exes ?(meta="path"
~default_to_string:(String.concat ~sep:", ")
~default ~deprecated ~long ~short ~exes ~meta
let mk_symbol ~default ~symbols ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc =
let mk_symbol ~default ~symbols ~eq ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc =
let strings = IList.map fst symbols in
let sym_to_str = IList.map (fun (x,y) -> (y,x)) symbols in
let of_string str = IList.assoc String.equal str symbols in
let to_string sym = IList.assoc ( = ) sym sym_to_str in
let to_string sym = IList.assoc eq sym sym_to_str in
mk ~deprecated ~long ?short ~default ?exes ~meta doc
~default_to_string:(fun s -> to_string s)
~mk_setter:(fun var str -> var := of_string str)
@ -464,10 +468,10 @@ let mk_symbol_opt ~symbols ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc =
~decode_json:(string_json_decoder ~long)
~mk_spec:(fun set -> Symbol (strings, set))
let mk_symbol_seq ?(default=[]) ~symbols ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc =
let mk_symbol_seq ?(default=[]) ~symbols ~eq ?(deprecated=[]) ~long ?short ?exes ?(meta="") doc =
let sym_to_str = IList.map (fun (x,y) -> (y,x)) symbols in
let of_string str = IList.assoc String.equal str symbols in
let to_string sym = IList.assoc ( = ) sym sym_to_str in
let to_string sym = IList.assoc eq sym sym_to_str in
mk ~deprecated ~long ?short ~default ?exes ~meta:(",-separated sequence" ^ meta) doc
~default_to_string:(fun syms -> String.concat ~sep:" " (IList.map to_string syms))
~mk_setter:(fun var str_seq ->
@ -531,7 +535,7 @@ let decode_inferconfig_to_argv current_exe path =
| Error msg ->
F.eprintf "WARNING: Could not read or parse Infer config in %s:@\n%s@." path msg ;
`Assoc [] in
let desc_list = !(IList.assoc ( = ) current_exe exe_desc_lists) in
let desc_list = !(IList.assoc equal_exe current_exe exe_desc_lists) in
let json_config = YBU.to_assoc json in
let one_config_item result (key, json_val) =
try
@ -653,7 +657,7 @@ let parse ?(incomplete=false) ?(accept_unknown=false) ?config_file current_exe e
let add_to_curr_speclist ?(add_help=false) ?header exe =
let mk_header_spec heading =
("", Unit (fun () -> ()), "\n " ^ heading ^ "\n") in
let exe_descs = IList.assoc ( = ) exe exe_desc_lists in
let exe_descs = IList.assoc equal_exe exe exe_desc_lists in
let (exe_speclist, widths) = normalize !exe_descs in
let exe_speclist = if add_help
then add_or_suppress_help (exe_speclist, widths)
@ -677,7 +681,7 @@ let parse ?(incomplete=false) ?(accept_unknown=false) ?config_file current_exe e
current exe *)
(* reset the speclist between calls to this function *)
curr_speclist := [];
if current_exe = Driver then (
if equal_exe current_exe Driver then (
add_to_curr_speclist ~add_help:true ~header:"Driver options" current_exe;
add_to_curr_speclist ~header:"Analysis (backend) options" Analyze;
add_to_curr_speclist ~header:"Clang frontend options" Clang

@ -11,7 +11,9 @@
open! IStd
type exe = Analyze | Clang | Driver | Interactive | Print
type exe = Analyze | Clang | Driver | Interactive | Print [@@ deriving compare]
val equal_exe : exe -> exe -> bool
(** Association list of executable (base)names to their [exe]s. *)
val exes : (string * exe) list
@ -96,7 +98,7 @@ val mk_path_list : ?default:string list -> string list ref t
(** [mk_symbol long symbols] defines a command line flag [--long <symbol>] where [(<symbol>,_)] is
an element of [symbols]. *)
val mk_symbol : default:'a -> symbols:(string * 'a) list -> 'a ref t
val mk_symbol : default:'a -> symbols:(string * 'a) list -> eq:('a -> 'a -> bool) -> 'a ref t
(** [mk_symbol_opt] is similar to [mk_symbol] but defaults to [None]. *)
val mk_symbol_opt : symbols:(string * 'a) list -> 'a option ref t
@ -104,7 +106,8 @@ val mk_symbol_opt : symbols:(string * 'a) list -> 'a option ref t
(** [mk_symbol_seq long symbols] defines a command line flag [--long <symbol sequence>] where
[<symbol sequence>] is a comma-separated sequence of [<symbol>]s such that [(<symbol>,_)] is an
element of [symbols]. *)
val mk_symbol_seq : ?default:'a list -> symbols:(string * 'a) list -> 'a list ref t
val mk_symbol_seq :
?default:'a list -> symbols:(string * 'a) list -> eq:('a -> 'a -> bool) -> 'a list ref t
val mk_set_from_json : default:'a -> default_to_string:('a -> string)
-> f:(Yojson.Basic.json -> 'a) -> 'a ref t

@ -9,6 +9,7 @@
*)
open! IStd
open! PVariant
(** Configuration values: either constant, determined at compile time, or set at startup
time by system calls, environment variables, or command line options *)
@ -18,7 +19,9 @@ module F = Format
type analyzer = Capture | Compile | Infer | Eradicate | Checkers | Tracing
| Crashcontext | Linters | Quandary | Threadsafety
| Crashcontext | Linters | Quandary | Threadsafety [@@deriving compare]
let equal_analyzer = [%compare.equal : analyzer]
let string_to_analyzer =
[("capture", Capture); ("compile", Compile);
@ -27,7 +30,7 @@ let string_to_analyzer =
("quandary", Quandary); ("threadsafety", Threadsafety)]
let string_of_analyzer a =
IList.find (fun (_, a') -> a = a') string_to_analyzer |> fst
IList.find (fun (_, a') -> equal_analyzer a a') string_to_analyzer |> fst
let clang_frontend_action_symbols = [
("lint", `Lint);
@ -37,6 +40,8 @@ let clang_frontend_action_symbols = [
type language = Clang | Java [@@deriving compare]
let equal_language = [%compare.equal : language]
let string_of_language = function
| Java -> "Java"
| Clang -> "C_CPP"
@ -642,7 +647,7 @@ and (
) =
let developer_mode =
CLOpt.mk_bool ~long:"developer-mode"
~default:CLOpt.(current_exe = Print)
~default:CLOpt.(equal_exe current_exe Print)
"Show internal exceptions"
and filtering =
@ -657,7 +662,7 @@ and (
and print_types =
CLOpt.mk_bool ~long:"print-types"
~default:(current_exe = CLOpt.Clang)
~default:CLOpt.(equal_exe current_exe Clang)
"Print types in symbolic heaps"
and reports_include_ml_loc =
@ -910,7 +915,7 @@ and ml_buckets =
- 'arc' from code compiled in ARC mode,\n\
- 'narc' from code not compiled in ARC mode,\n\
- 'cpp' from C++ code"
~symbols:ml_bucket_symbols
~symbols:ml_bucket_symbols ~eq:PVariant.(=)
and models_mode =
CLOpt.mk_bool ~deprecated:["models_mode"; "-models_mode"] ~long:"models-mode"
@ -1296,7 +1301,7 @@ let post_parsing_initialization () =
Unix.close_process_full chans |> ignore;
err in
let analyzer_name =
IList.assoc (=)
IList.assoc equal_analyzer
(match !analyzer with Some a -> a | None -> Infer)
(IList.map (fun (n,a) -> (a,n)) string_to_analyzer) in
let infer_version = Version.commit in
@ -1332,8 +1337,8 @@ let post_parsing_initialization () =
else
(Some default_symops_timeout, Some default_seconds_timeout)
in
if !symops_per_iteration = None then symops_per_iteration := symops_timeout ;
if !seconds_per_iteration = None then seconds_per_iteration := seconds_timeout ;
if is_none !symops_per_iteration then symops_per_iteration := symops_timeout ;
if is_none !seconds_per_iteration then seconds_per_iteration := seconds_timeout ;
match !analyzer with
| Some Checkers -> checkers := true
@ -1518,13 +1523,13 @@ and xml_specs = !xml_specs
(** Configuration values derived from command-line options *)
let analysis_path_regex_whitelist analyzer =
IList.assoc (=) analyzer analysis_path_regex_whitelist_options
IList.assoc equal_analyzer analyzer analysis_path_regex_whitelist_options
and analysis_path_regex_blacklist analyzer =
IList.assoc (=) analyzer analysis_path_regex_blacklist_options
IList.assoc equal_analyzer analyzer analysis_path_regex_blacklist_options
and analysis_blacklist_files_containing analyzer =
IList.assoc (=) analyzer analysis_blacklist_files_containing_options
IList.assoc equal_analyzer analyzer analysis_blacklist_files_containing_options
and analysis_suppress_errors analyzer =
IList.assoc (=) analyzer analysis_suppress_errors_options
IList.assoc equal_analyzer analyzer analysis_suppress_errors_options
let checkers_enabled = not (eradicate || crashcontext || quandary || threadsafety)
@ -1605,6 +1610,9 @@ let arc_mode = ref false
(** Current language *)
let curr_language = ref Clang
let curr_language_is lang =
equal_language !curr_language lang
(** Flag for footprint discovery mode *)
let footprint = ref true

@ -16,7 +16,9 @@ open! IStd
(** Various kind of analyzers *)
type analyzer = Capture | Compile | Infer | Eradicate | Checkers | Tracing
| Crashcontext | Linters | Quandary | Threadsafety
| Crashcontext | Linters | Quandary | Threadsafety [@@deriving compare]
val equal_analyzer : analyzer -> analyzer -> bool
(** Association list of analyzers and their names *)
val string_to_analyzer : (string * analyzer) list
@ -25,6 +27,8 @@ val string_of_analyzer : analyzer -> string
type language = Clang | Java [@@deriving compare]
val equal_language : language -> language -> bool
val string_of_language : language -> string
@ -291,6 +295,8 @@ val arc_mode : bool ref
val curr_language : language ref
val curr_language_is : language -> bool
val footprint : bool ref
(** Call f x with footprint set to true.

@ -9,6 +9,7 @@
*)
open! IStd
open! PVariant
(** Database of analysis results *)
@ -57,6 +58,8 @@ let find_source_dirs () =
type filename = string [@@deriving compare]
let equal_filename = [%compare.equal : filename]
let filename_concat = Filename.concat
let filename_to_string s = s
@ -118,7 +121,7 @@ let update_file_with_lock dir fname update =
reset_file fd;
let str = update buf in
let i = Unix.write fd ~buf:str ~pos:0 ~len:(String.length str) in
if (i = String.length str) then (
if Int.equal i (String.length str) then (
Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L;
Unix.close fd
) else (

@ -17,6 +17,8 @@ open! IStd
(** generic file name *)
type filename [@@deriving compare]
val equal_filename : filename -> filename -> bool
module FilenameSet : Caml.Set.S with type elt = filename
module FilenameMap : Caml.Map.S with type key = filename

@ -54,7 +54,7 @@ let escape_dotty s =
let escape_path s =
let map = function
| c ->
if Char.escaped c = Filename.dir_sep
if String.equal (Char.escaped c) Filename.dir_sep
then Some "_"
else None in
escape_map map s

@ -88,11 +88,6 @@ let rec drop_first n = function
let drop_last n list =
rev (drop_first n (rev list))
(** Returns (reverse input_list) *)
let rec rev_with_acc acc = function
| [] -> acc
| x :: xs -> rev_with_acc (x:: acc) xs
(** tail-recursive variant of List.append *)
let append l1 l2 =
rev_append (rev l1) l2
@ -166,9 +161,9 @@ let remove_irrelevant_duplicates compare relevant l =
let rec merge_sorted_nodup compare res xs1 xs2 =
match xs1, xs2 with
| [], _ ->
rev_with_acc xs2 res
rev_append res xs2
| _, [] ->
rev_with_acc xs1 res
rev_append res xs1
| x1 :: xs1', x2 :: xs2' ->
let n = compare x1 x2 in
if n = 0 then

@ -81,9 +81,6 @@ val drop_first : int -> 'a list -> 'a list
(* Drops the last n elements from a list. *)
val drop_last : int -> 'a list -> 'a list
(** Returns (reverse input_list)[@]acc *)
val rev_with_acc : 'a list -> 'a list -> 'a list
(** Remove consecutive equal elements from a list (according to the given comparison functions) *)
val remove_duplicates : ('a -> 'a -> int) -> 'a list -> 'a list

@ -52,7 +52,12 @@ module IntSet = Caml.Set.Make(Int)
(* Compare police: generic compare mostly disabled. *)
let compare = No_polymorphic_compare.compare
let equal = No_polymorphic_compare.equal
(* let (=) = equal *)
module PVariant = struct
(* Equality for polymorphic variants *)
let (=) (v1 : [> ]) (v2 : [> ]) = Polymorphic_compare.(=) v1 v2
end
let failwithf fmt =
Format.kfprintf (fun _ -> failwith (Format.flush_str_formatter ()))

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

@ -8,6 +8,8 @@
*/
open! IStd;
open! PVariant;
let module F = Format;
let module L = Logging;

@ -17,10 +17,14 @@ module F = Format
type simple_kind = SIM_DEFAULT | SIM_WITH_TYP
(** Kind of printing *)
type printkind = TEXT | LATEX | HTML
type print_kind = TEXT | LATEX | HTML [@@deriving compare]
(** Colors supported in printing *)
type color = Black | Blue | Green | Orange | Red
let equal_print_kind = [%compare.equal : print_kind];
(** Colors supported in printing *)
type color = Black | Blue | Green | Orange | Red [@@deriving compare]
let equal_color = [%compare.equal : color]
(** map subexpressions (as Obj.t element compared by physical equality) to colors *)
type colormap = Obj.t -> color
@ -28,7 +32,7 @@ type colormap = Obj.t -> color
(** Print environment threaded through all the printing functions *)
type env = {
opt : simple_kind; (** Current option for simple printing *)
kind : printkind; (** Current kind of printing *)
kind : print_kind; (** Current kind of printing *)
cmap_norm : colormap; (** Current colormap for the normal part *)
cmap_foot : colormap; (** Current colormap for the footprint part *)
color : color; (** Current color *)

@ -12,7 +12,9 @@ open! IStd
(** Pretty Printing} *)
(** Colors supported in printing *)
type color = Black | Blue | Green | Orange | Red
type color = Black | Blue | Green | Orange | Red [@@deriving compare]
val equal_color : color -> color -> bool
(** map subexpressions (as Obj.t element compared by physical equality) to colors *)
type colormap = Obj.t -> color
@ -21,12 +23,14 @@ type colormap = Obj.t -> color
type simple_kind = SIM_DEFAULT | SIM_WITH_TYP
(** Kind of printing *)
type printkind = TEXT | LATEX | HTML
type print_kind = TEXT | LATEX | HTML [@@deriving compare]
val equal_print_kind : print_kind -> print_kind -> bool
(** Print environment threaded through all the printing functions *)
type env = {
opt : simple_kind; (** Current option for simple printing *)
kind : printkind; (** Current kind of printing *)
kind : print_kind; (** Current kind of printing *)
cmap_norm : colormap; (** Current colormap for the normal part *)
cmap_foot : colormap; (** Current colormap for the footprint part *)
color : color; (** Current color *)

@ -88,7 +88,7 @@ let run_jobs_in_parallel jobs_stack gen_prog prog_to_string =
|> never_returns
| `In_the_parent pid_child ->
jobs_map := PidMap.add pid_child (prog_to_string job_prog) !jobs_map;
if Stack.length jobs_stack = 0 || !current_jobs_count >= Config.jobs then
if Int.equal (Stack.length jobs_stack) 0 || !current_jobs_count >= Config.jobs then
wait_for_child (pid_to_program !jobs_map) current_jobs_count jobs_map
done in
run_job ();

@ -8,6 +8,7 @@
*)
open! IStd
open! PVariant
let count_newlines (path: string): int =
let f file = In_channel.fold_lines file ~init:0 ~f:(fun i _ -> i + 1) in
@ -19,8 +20,7 @@ type t =
| RelativeInferModel of string (* relative to infer models *)
[@@deriving compare]
let equal sf1 sf2 =
compare sf1 sf2 = 0
let equal = [%compare.equal : t]
module OrderedSourceFile =
struct

@ -53,7 +53,7 @@ let compute_statistics values => {
Array.sort
cmp::(
fun a b =>
if (a == b) {
if (Float.equal a b) {
0
} else if (a -. b < 0.0) {
(-1)

@ -8,6 +8,7 @@
* of patent rights can be found in the PATENTS file in the same directory.
*)
open! IStd
open! PVariant
module F = Format
module Hashtbl = Caml.Hashtbl
@ -123,7 +124,7 @@ let filename_to_absolute ~root fname =
let filename_to_relative ~root fname =
let rec relativize_if_under origin target =
match origin, target with
| x :: xs, y :: ys when x = y -> relativize_if_under xs ys
| x :: xs, y :: ys when String.equal x y -> relativize_if_under xs ys
| [], [] -> Some "."
| [], ys -> Some (Filename.of_parts ys)
| _ -> None
@ -241,7 +242,7 @@ let create_dir dir =
try Unix.mkdir dir ~perm:0o700 with
Unix.Unix_error _ ->
let created_concurrently = (* check if another process created it meanwhile *)
try (Unix.stat dir).Unix.st_kind = Unix.S_DIR
try Polymorphic_compare.(=) ((Unix.stat dir).Unix.st_kind) Unix.S_DIR
with Unix.Unix_error _ -> false in
if not created_concurrently then
failwithf "@.ERROR: cannot create directory %s@." dir

@ -8,6 +8,7 @@
*)
open! IStd
open! PVariant
module L = Logging
@ -80,7 +81,7 @@ let zip_libraries =
IList.fold_left add_zip [] Config.specs_library in
if Config.checkers then
zip_libs
else if Sys.file_exists Config.models_jar = `Yes then
else if (Sys.file_exists Config.models_jar) = `Yes then
(mk_zip_lib true Config.models_jar) :: zip_libs
else
zip_libs

@ -57,8 +57,7 @@ module Make (Kind : Kind) = struct
if false, report only if the value passed to the sink is itself a source *)
}
let equal t1 t2 =
compare t1 t2 = 0
let equal = [%compare.equal : t]
let kind t =
t.kind

@ -8,6 +8,7 @@
*)
open! IStd
open! PVariant
module F = Format
module L = Logging

@ -47,7 +47,7 @@ let frame_matches_location frame_obj loc =
let matches_file = String.is_suffix ~suffix:frame_obj.file_str lfname in
let matches_line = match frame_obj.line_num with
| None -> false
| Some line -> line = loc.Location.line in
| Some line -> Int.equal line loc.Location.line in
matches_file && matches_line
let parse_stack_frame frame_str =

@ -106,7 +106,7 @@ module Expander (TraceElem : TraceElem.S) = struct
let matching_elems =
IList.filter
(fun callee_elem ->
TraceElem.Kind.compare (TraceElem.kind callee_elem) elem_kind = 0 &&
[%compare.equal : TraceElem.Kind.t] (TraceElem.kind callee_elem) elem_kind &&
not (is_recursive callee_elem seen_acc'))
elems in
(* arbitrarily pick one elem and explore it further *)
@ -139,13 +139,12 @@ module Make (Spec : Spec) = struct
passthroughs : Passthrough.Set.t; (** calls that occurred between source and sink *)
} [@@deriving compare]
let equal = [%compare.equal : t]
type astate = t
type path = Passthroughs.t * (Source.t * Passthroughs.t) list * (Sink.t * Passthroughs.t) list
let equal t1 t2 =
compare t1 t2 = 0
let pp fmt t =
F.fprintf
fmt

@ -17,29 +17,25 @@ let compare__array_sensitive_typ = Typ.array_sensitive_compare
type base = Var.t * _array_sensitive_typ [@@deriving compare]
let equal_base base1 base2 =
compare_base base1 base2 = 0
let equal_base = [%compare.equal : base]
type access =
| ArrayAccess of Typ.t
| FieldAccess of Ident.fieldname * Typ.t
[@@deriving compare]
let equal_access access1 access2 =
compare_access access1 access2 = 0
let equal_access = [%compare.equal : access]
type raw = base * access list [@@deriving compare]
let equal_raw ap1 ap2 =
compare_raw ap1 ap2 = 0
let equal_raw = [%compare.equal : raw]
type t =
| Abstracted of raw
| Exact of raw
[@@deriving compare]
let equal ap1 ap2 =
compare ap1 ap2 = 0
let equal = [%compare.equal : t]
let base_of_pvar pvar typ =
Var.of_pvar pvar, typ

@ -63,12 +63,12 @@ let ia_ends_with ia ann_name =
let ia_contains ia ann_name =
let found = ref false in
ia_iter (fun a -> if ann_name = a.Annot.class_name then found := true) ia;
ia_iter (fun a -> if String.equal ann_name a.Annot.class_name then found := true) ia;
!found
let ia_get ia ann_name =
let found = ref None in
ia_iter (fun a -> if ann_name = a.Annot.class_name then found := Some a) ia;
ia_iter (fun a -> if String.equal ann_name a.Annot.class_name then found := Some a) ia;
!found
let ma_contains ma ann_names =
@ -286,7 +286,7 @@ let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
let name_str = Mangled.to_string name in
let len = String.length name_str in
len >= 2 &&
String.sub name_str ~pos:0 ~len:1 = "x" &&
String.equal (String.sub name_str ~pos:0 ~len:1) "x" &&
let s = String.sub name_str ~pos:1 ~len:(len - 1) in
let is_int =
try
@ -296,7 +296,7 @@ let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
with Failure _ -> false in
is_int in
let check_param (name, ia, t) =
if Mangled.to_string name = "this" then true
if String.equal (Mangled.to_string name) "this" then true
else
name_is_x_number name &&
Annot.Item.is_empty ia &&
@ -356,7 +356,7 @@ let annotated_signature_mark proc_name ann asig (b, bs) =
L.stdout " ANNOTATED SIGNATURE: %a@." (pp_annotated_signature proc_name) asig;
assert false in
let rec combine l1 l2 = match l1, l2 with
| (p, ia, t):: l1', l2' when Mangled.to_string p = "this" ->
| (p, ia, t):: l1', l2' when String.equal (Mangled.to_string p) "this" ->
(p, ia, t) :: combine l1' l2'
| (s, ia, t):: l1', x:: l2' ->
mark_param (s, ia, t) x :: combine l1' l2'

@ -23,7 +23,7 @@ module PP = struct
let pp_loc_range linereader nbefore nafter fmt loc =
let printline n =
match Printer.LineReader.from_loc linereader { loc with Location.line = n } with
| Some s -> F.fprintf fmt "%s%s@\n" (if n = loc.Location.line then "-->" else " ") s
| Some s -> F.fprintf fmt "%s%s@\n" (if Int.equal n loc.Location.line then "-->" else " ") s
| _ -> () in
F.fprintf fmt "%a:%d@\n" SourceFile.pp loc.Location.file loc.Location.line;
for n = loc.Location.line - nbefore to loc.Location.line + nafter do printline n done
@ -200,7 +200,7 @@ let callback_check_write_to_parcel_java
let is_write_to_parcel this_expr this_type =
let method_match () =
Procname.java_get_method pname_java = "writeToParcel" in
String.equal (Procname.java_get_method pname_java) "writeToParcel" in
let expr_match () = Exp.is_this this_expr in
let type_match () =
let class_name =
@ -234,10 +234,10 @@ let callback_check_write_to_parcel_java
let class_name = Procname.java_get_class_name pname_java in
let method_name = Procname.java_get_method pname_java in
(try
class_name = "android.os.Parcel" &&
(String.sub method_name ~pos:0 ~len:5 = "write"
String.equal class_name "android.os.Parcel" &&
(String.equal (String.sub method_name ~pos:0 ~len:5) "write"
||
String.sub method_name ~pos:0 ~len:4 = "read")
String.equal (String.sub method_name ~pos:0 ~len:4) "read")
with Invalid_argument _ -> false)
| _ -> assert false in
@ -247,8 +247,9 @@ let callback_check_write_to_parcel_java
let wn = Procname.java_get_method wc in
let postfix_length = String.length wn - 5 in (* covers writeList <-> readArrayList etc. *)
(try
String.sub rn ~pos:(String.length rn - postfix_length) ~len:postfix_length =
String.sub wn ~pos:5 ~len:postfix_length
String.equal
(String.sub rn ~pos:(String.length rn - postfix_length) ~len:postfix_length)
(String.sub wn ~pos:5 ~len:postfix_length)
with Invalid_argument _ -> false)
| _ ->
false in
@ -326,7 +327,7 @@ let callback_monitor_nullcheck { Callbacks.proc_desc; idenv; proc_name } =
let class_formals =
let is_class_type (p, typ) =
match typ with
| Typ.Tptr _ when Mangled.to_string p = "this" ->
| Typ.Tptr _ when String.equal (Mangled.to_string p) "this" ->
false (* no need to null check 'this' *)
| Typ.Tstruct _ -> true
| Typ.Tptr (Typ.Tstruct _, _) -> true

@ -29,7 +29,7 @@ module ConstantMap = Exp.Map
module ConstantFlow = Dataflow.MakeDF(struct
type t = (Const.t option) ConstantMap.t [@@deriving compare]
let equal m n = compare m n = 0
let equal = [%compare.equal : t]
let pp fmt constants =
let pp_key fmt = Exp.pp fmt in
@ -56,12 +56,12 @@ module ConstantFlow = Dataflow.MakeDF(struct
let has_class pn name = match pn with
| Procname.Java pn_java ->
Procname.java_get_class_name pn_java = name
String.equal (Procname.java_get_class_name pn_java) name
| _ ->
false in
let has_method pn name = match pn with
| Procname.Java pn_java ->
Procname.java_get_method pn_java = name
String.equal (Procname.java_get_method pn_java) name
| _ ->
false in

@ -102,7 +102,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
| (Exp.Lvar pvar, Typ.Tptr _) -> Domain.kill_copies_with_var (Var.of_pvar pvar) astate_acc
| _ -> astate_acc in
let astate' = Option.value_map ~f:kill_ret_id ~default:astate ret_id in
if !Config.curr_language = Config.Java
if Config.curr_language_is Config.Java
then astate' (* Java doesn't have pass-by-reference *)
else IList.fold_left kill_actuals_by_ref astate' actuals
| Sil.Store _ | Prune _ | Nullify _ | Abstract _ | Remove_temps _ | Declare_locals _ ->

@ -176,7 +176,7 @@ let callback_test_dataflow { Callbacks.proc_desc; tenv } =
let module DFCount = MakeDF(struct
type t = int
let equal = Int.equal
let join n m = if n = 0 then m else n
let join n m = if Int.equal n 0 then m else n
let do_node _ n s =
if verbose then L.stdout "visiting node %a with state %d@." Procdesc.Node.pp n s;
[s + 1], [s + 1]

Some files were not shown because too many files have changed in this diff Show More

Loading…
Cancel
Save