From b1421bc27f2c907d5a53d05c4814b82bef300ba5 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Wed, 25 Jan 2017 05:16:22 -0800 Subject: [PATCH] [BetterEngineering] Remove remaining uses of polymorphic equality Summary: Remove the remaining uses of polymorphic equality `=`. In case of basic types, this is replaced by String.equal or Int.equal. In case of `= []`, this is replaced by `List.is_empty`. In case of `= None`, this is replaced by `is_none`. In case of a datatype definition such as `type a = A | B`, a `compare_a` function is defined by adding `type a = A | B [@deriving compare]` and a `equal_a` function is defined as `let equal_a = [%compare.equal : a]`. In case of comparison with a polymorphic variant `= `Yes`, the equality defined in `PVariant.(=)` is used. Typically, `open! Pvariant` is added at the beginning of the file to cover all the uses. Reviewed By: jberdine Differential Revision: D4456129 fbshipit-source-id: f31c433 --- infer/src/IR/PredSymb.re | 2 + infer/src/IR/PredSymb.rei | 2 + infer/src/IR/Procdesc.re | 7 +-- infer/src/IR/Procdesc.rei | 2 + infer/src/IR/Sil.re | 8 +-- infer/src/IR/Typ.re | 2 + infer/src/IR/Typ.rei | 2 + infer/src/backend/BuiltinDefn.ml | 6 +- infer/src/backend/dom.ml | 12 ++-- infer/src/backend/interproc.ml | 21 ++++--- infer/src/backend/joinState.ml | 3 + infer/src/backend/joinState.mli | 3 + infer/src/backend/specs.mli | 2 + infer/src/base/IStd.ml | 2 +- infer/src/checkers/BoundedCallTree.ml | 2 +- infer/src/checkers/SimpleChecker.ml | 2 +- infer/src/checkers/ThreadSafety.ml | 6 +- infer/src/checkers/ThreadSafetyDomain.ml | 2 +- infer/src/checkers/Trace.ml | 2 +- infer/src/checkers/annotationReachability.ml | 10 ++-- infer/src/checkers/checkDeadCode.ml | 2 +- infer/src/checkers/checkTraceCallSequence.ml | 10 ++-- .../checkers/fragmentRetainsViewChecker.ml | 2 +- infer/src/checkers/repeatedCallsChecker.ml | 13 ++-- infer/src/checkers/sqlChecker.ml | 4 +- infer/src/clang/CType_decl.ml | 2 +- infer/src/clang/Capture.re | 5 +- infer/src/clang/ClangWrapper.re | 4 +- infer/src/clang/ComponentKit.ml | 3 +- infer/src/clang/cAst_utils.ml | 24 +++----- infer/src/clang/cAst_utils.mli | 6 -- infer/src/clang/cContext.ml | 3 +- infer/src/clang/cField_decl.ml | 2 +- infer/src/clang/cFrontend_config.ml | 4 +- infer/src/clang/cFrontend_config.mli | 4 +- infer/src/clang/cFrontend_errors.ml | 2 +- infer/src/clang/cGeneral_utils.ml | 12 ++-- infer/src/clang/cLocation.ml | 1 + infer/src/clang/cMethod_signature.ml | 4 +- infer/src/clang/cMethod_trans.ml | 23 +++++--- infer/src/clang/cMethod_trans.mli | 4 +- infer/src/clang/cPredicates.ml | 22 +++---- infer/src/clang/cTL.ml | 10 ++-- infer/src/clang/cTrans.ml | 23 ++++---- infer/src/clang/cTrans_models.ml | 59 ++++++++++--------- infer/src/clang/cTrans_utils.ml | 12 ++-- infer/src/clang/cVar_decl.ml | 4 +- infer/src/eradicate/eradicate.ml | 10 ++-- infer/src/eradicate/eradicateChecks.ml | 27 +++++---- infer/src/eradicate/typeCheck.ml | 20 ++++--- infer/src/harness/androidFramework.ml | 2 +- infer/src/harness/inhabit.ml | 4 +- infer/src/integration/Maven.ml | 4 +- infer/src/java/jFrontend.ml | 17 +++--- infer/src/java/jTrans.ml | 22 +++---- infer/src/java/jTransExn.ml | 2 +- infer/src/java/jTransType.ml | 4 +- infer/src/unit/TraceTests.ml | 6 +- infer/src/unit/accessPathTests.ml | 2 +- infer/src/unit/accessTreeTests.ml | 2 +- infer/src/unit/procCfgTests.ml | 4 +- infer/src/unit/schedulerTests.ml | 6 +- 62 files changed, 274 insertions(+), 220 deletions(-) diff --git a/infer/src/IR/PredSymb.re b/infer/src/IR/PredSymb.re index 0a3e913b2..cdc0a0978 100644 --- a/infer/src/IR/PredSymb.re +++ b/infer/src/IR/PredSymb.re @@ -28,6 +28,8 @@ type access = | Protected [@@deriving compare]; +let equal_access = [%compare.equal : access]; + /** Return the value of the FA_sentinel attribute in [attr_list] if it is found */ let get_sentinel_func_attribute_value attr_list => diff --git a/infer/src/IR/PredSymb.rei b/infer/src/IR/PredSymb.rei index 7fe738094..ca74a9af5 100644 --- a/infer/src/IR/PredSymb.rei +++ b/infer/src/IR/PredSymb.rei @@ -34,6 +34,8 @@ type access = | Protected [@@deriving compare]; +let equal_access: access => access => bool; + type mem_kind = | Mmalloc /** memory allocated with malloc */ | Mnew /** memory allocated with new */ diff --git a/infer/src/IR/Procdesc.re b/infer/src/IR/Procdesc.re index 11d5cb105..effc716a7 100644 --- a/infer/src/IR/Procdesc.re +++ b/infer/src/IR/Procdesc.re @@ -17,7 +17,8 @@ let module F = Format; /* =============== START of module Node =============== */ let module Node = { - type id = int; + type id = int [@@deriving compare]; + let equal_id = [%compare.equal : id]; type nodekind = | Start_node Procname.t | Exit_node Procname.t @@ -26,6 +27,7 @@ let module Node = { | Prune_node bool Sil.if_kind string /** (true/false branch, if_kind, comment) */ | Skip_node string [@@deriving compare]; + let equal_nodekind = [%compare.equal : nodekind]; /** a node */ type t = { @@ -68,9 +70,6 @@ let module Node = { /** Get the unique id of the node */ let get_id node => node.id; - - /** compare node ids */ - let compare_id = Int.compare; let get_succs node => node.succs; type node = t; let module NodeSet = Caml.Set.Make { diff --git a/infer/src/IR/Procdesc.rei b/infer/src/IR/Procdesc.rei index 02391efbb..5e7449b7d 100644 --- a/infer/src/IR/Procdesc.rei +++ b/infer/src/IR/Procdesc.rei @@ -18,6 +18,7 @@ let module Node: { /** node id */ type id = private int [@@deriving compare]; + let equal_id: id => id => bool; /** kind of cfg node */ type nodekind = @@ -28,6 +29,7 @@ let module Node: { | Prune_node bool Sil.if_kind string /** (true/false branch, if_kind, comment) */ | Skip_node string [@@deriving compare]; + let equal_nodekind: nodekind => nodekind => bool; /** kind of Stmt_node for an exception handler. */ let exn_handler_kind: nodekind; diff --git a/infer/src/IR/Sil.re b/infer/src/IR/Sil.re index cdc7bffb6..96e44eea4 100644 --- a/infer/src/IR/Sil.re +++ b/infer/src/IR/Sil.re @@ -2094,7 +2094,7 @@ let compare_structural_instr instr1 instr2 exp_map => { } }; let id_list_compare_structural ids1 ids2 exp_map => { - let n = Pervasives.compare (IList.length ids1) (IList.length ids2); + let n = Int.compare (IList.length ids1) (IList.length ids2); if (n != 0) { (n, exp_map) } else { @@ -2150,14 +2150,14 @@ let compare_structural_instr instr1 instr2 exp_map => { if (n != 0) { n } else { - Pervasives.compare ik1 ik2 + compare_if_kind ik1 ik2 } }, exp_map ) | (Call ret_id1 e1 arg_ts1 _ cf1, Call ret_id2 e2 arg_ts2 _ cf2) => let args_compare_structural args1 args2 exp_map => { - let n = Pervasives.compare (IList.length args1) (IList.length args2); + let n = Int.compare (IList.length args1) (IList.length args2); if (n != 0) { (n, exp_map) } else { @@ -2199,7 +2199,7 @@ let compare_structural_instr instr1 instr2 exp_map => { | (Remove_temps temps1 _, Remove_temps temps2 _) => id_list_compare_structural temps1 temps2 exp_map | (Declare_locals ptl1 _, Declare_locals ptl2 _) => - let n = Pervasives.compare (IList.length ptl1) (IList.length ptl2); + let n = Int.compare (IList.length ptl1) (IList.length ptl2); if (n != 0) { (n, exp_map) } else { diff --git a/infer/src/IR/Typ.re b/infer/src/IR/Typ.re index 5d823a8a6..2e31eaef2 100644 --- a/infer/src/IR/Typ.re +++ b/infer/src/IR/Typ.re @@ -108,6 +108,8 @@ type ptr_kind = | Pk_objc_autoreleasing /** Obj-C __autoreleasing pointer */ [@@deriving compare]; +let equal_ptr_kind = [%compare.equal : ptr_kind]; + let ptr_kind_string = fun | Pk_reference => "&" diff --git a/infer/src/IR/Typ.rei b/infer/src/IR/Typ.rei index a8b89fdd8..68a30c461 100644 --- a/infer/src/IR/Typ.rei +++ b/infer/src/IR/Typ.rei @@ -63,6 +63,8 @@ type ptr_kind = | Pk_objc_autoreleasing /** Obj-C __autoreleasing pointer */ [@@deriving compare]; +let equal_ptr_kind: ptr_kind => ptr_kind => bool; + /** statically determined length of an array type, if any */ type static_length = option IntLit.t [@@deriving compare]; diff --git a/infer/src/backend/BuiltinDefn.ml b/infer/src/backend/BuiltinDefn.ml index d29067026..73472a86a 100644 --- a/infer/src/backend/BuiltinDefn.ml +++ b/infer/src/backend/BuiltinDefn.ml @@ -699,7 +699,7 @@ let _execute_free_nonzero mk pdesc tenv instr prop lexp typ loc = IList.rev prop_list end with Rearrange.ARRAY_ACCESS -> - if (Config.array_level = 0) then assert false + if (Int.equal Config.array_level 0) then assert false else begin L.d_strln ".... Array containing allocated heap cells ...."; L.d_str " Instr: "; Sil.d_instr instr; L.d_ln (); @@ -929,8 +929,8 @@ let execute___infer_fail { Builtin.pdesc; tenv; prop_; path; args; loc; } let execute___assert_fail { Builtin.pdesc; tenv; prop_; path; args; loc; } : Builtin.ret_typ = let error_str = - match args with - | l when IList.length l = 4 -> + match IList.length args with + | 4 -> Config.default_failure_name | _ -> raise (Exceptions.Wrong_argument_number __POS__) in diff --git a/infer/src/backend/dom.ml b/infer/src/backend/dom.ml index 0f1878a61..51de0f6ba 100644 --- a/infer/src/backend/dom.ml +++ b/infer/src/backend/dom.ml @@ -251,7 +251,7 @@ module CheckJoinPre : InfoLossCheckerSig = struct | Exp.Lvar _ -> false | Exp.Var id when Ident.is_normal id -> IList.length es >= 1 | Exp.Var _ -> - if Config.join_cond = 0 then + if Int.equal Config.join_cond 0 then IList.exists (Exp.equal Exp.zero) es else if Dangling.check side e then begin @@ -989,7 +989,7 @@ and dynamic_length_partial_join l1 l2 = option_partial_join (fun len1 len2 -> Some (length_partial_join len1 len2)) l1 l2 and typ_partial_join t1 t2 = match t1, t2 with - | Typ.Tptr (t1, pk1), Typ.Tptr (t2, pk2) when Typ.compare_ptr_kind pk1 pk2 = 0 -> + | Typ.Tptr (t1, pk1), Typ.Tptr (t2, pk2) when Typ.equal_ptr_kind pk1 pk2 -> Typ.Tptr (typ_partial_join t1 t2, pk1) | Typ.Tarray (typ1, len1), Typ.Tarray (typ2, len2) -> let t = typ_partial_join typ1 typ2 in @@ -1069,7 +1069,7 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S end | (fld1, se1):: fld_se_list1', (fld2, se2):: fld_se_list2' -> let comparison = Ident.compare_fieldname fld1 fld2 in - if comparison = 0 then + if Int.equal comparison 0 then let strexp' = strexp_partial_join mode se1 se2 in let fld_se_list_new = (fld1, strexp') :: acc in f_fld_se_list inst mode fld_se_list_new fld_se_list1' fld_se_list2' @@ -1633,7 +1633,7 @@ let pi_partial_join tenv mode match Rename.get_other_atoms tenv side a with | None -> None | Some (a_res, a_op) -> - if mode = JoinState.Pre then join_atom_check_pre p_op a_op; + if JoinState.equal_mode mode JoinState.Pre then join_atom_check_pre p_op a_op; if Attribute.is_pred a then join_atom_check_attribute p_op a_op; if not (Prover.check_atom tenv p_op a_op) then None else begin @@ -1756,7 +1756,7 @@ let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed let es1 = sigma_get_start_lexps_sort sigma1 in let es2 = sigma_get_start_lexps_sort sigma2 in - let simple_check = IList.length es1 = IList.length es2 in + let simple_check = Int.equal (IList.length es1) (IList.length es2) in let rec expensive_check es1' es2' = match (es1', es2') with | [], [] -> true @@ -2017,7 +2017,7 @@ let proplist_meet_generate tenv plist = let propset_meet_generate_pre tenv pset = let plist = Propset.to_proplist pset in - if Config.meet_level = 0 then plist + if Int.equal Config.meet_level 0 then plist else let pset1 = proplist_meet_generate tenv plist in let pset_new = Propset.diff pset1 pset in diff --git a/infer/src/backend/interproc.ml b/infer/src/backend/interproc.ml index b78726c73..03fd67c2b 100644 --- a/infer/src/backend/interproc.ml +++ b/infer/src/backend/interproc.ml @@ -9,6 +9,8 @@ *) open! IStd +open! PVariant + module Hashtbl = Caml.Hashtbl (** Interprocedural Analysis *) @@ -529,7 +531,7 @@ let forward_tabulate tenv pdesc wl source = let log_string proc_name = let summary = Specs.get_summary_unsafe "forward_tabulate" proc_name in let phase_string = - if Specs.get_phase summary = Specs.FOOTPRINT then "FP" else "RE" in + if Specs.equal_phase (Specs.get_phase summary) Specs.FOOTPRINT then "FP" else "RE" in let timestamp = Specs.get_timestamp summary in F.sprintf "[%s:%d] %s" phase_string timestamp (Procname.to_string proc_name) in L.d_strln ("**** " ^ (log_string pname) ^ " " ^ @@ -1174,14 +1176,14 @@ let is_unavoidable tenv pre = let report_runtime_exceptions tenv pdesc summary = let pname = Specs.get_proc_name summary in let is_public_method = - (Specs.get_attributes summary).ProcAttributes.access = PredSymb.Public in + PredSymb.equal_access (Specs.get_attributes summary).access PredSymb.Public in let is_main = is_public_method && (match pname with | Procname.Java pname_java -> Procname.java_is_static pname - && (Procname.java_get_method pname_java) = "main" + && String.equal (Procname.java_get_method pname_java) "main" | _ -> false) in let is_annotated = @@ -1235,7 +1237,7 @@ let update_specs tenv proc_name phase (new_specs : Specs.NormSpec.t list) (Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map) SpecMap.empty old_specs) in let re_exe_filter old_spec = (* filter out pres which failed re-exe *) - if phase = Specs.RE_EXECUTION && + if Specs.equal_phase phase Specs.RE_EXECUTION && not (IList.exists (fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) new_specs) @@ -1395,7 +1397,7 @@ let perform_transition exe_env tenv proc_name source = [] in transition_footprint_re_exe tenv proc_name joined_pres in match Specs.get_summary proc_name with - | Some summary when Specs.get_phase summary = Specs.FOOTPRINT -> + | Some summary when Specs.equal_phase (Specs.get_phase summary) Specs.FOOTPRINT -> transition () | _ -> () @@ -1404,7 +1406,7 @@ let interprocedural_algorithm exe_env : unit = let call_graph = Exe_env.get_cg exe_env in let filter_initial proc_name = let summary = Specs.get_summary_unsafe "main_algorithm" proc_name in - Specs.get_timestamp summary = 0 in + Int.equal (Specs.get_timestamp summary) 0 in let procs_to_analyze = IList.filter filter_initial (Cg.get_defined_nodes call_graph) in let to_analyze proc_name = @@ -1461,7 +1463,7 @@ let do_analysis exe_env = (fun ((pn, _) as x) -> let should_init () = Config.models_mode || - Specs.get_summary pn = None in + is_none (Specs.get_summary pn) in if should_init () then init_proc x) procs_and_defined_children; @@ -1547,7 +1549,7 @@ let print_stats_cfg proc_shadowed source cfg = let compute_stats_proc proc_desc = let proc_name = Procdesc.get_proc_name proc_desc in if proc_shadowed proc_desc || - Specs.get_summary proc_name = None then + is_none (Specs.get_summary proc_name) then L.out "print_stats: ignoring function %a which is also defined in another file@." Procname.pp proc_name else @@ -1560,7 +1562,8 @@ let print_stats_cfg proc_shadowed source cfg = let () = match specs, Errlog.size - (fun ekind in_footprint -> ekind = Exceptions.Kerror && in_footprint) + (fun ekind in_footprint -> + Exceptions.equal_err_kind ekind Exceptions.Kerror && in_footprint) err_log with | [], 0 -> incr num_nospec_noerror_proc | _, 0 -> incr num_spec_noerror_proc diff --git a/infer/src/backend/joinState.ml b/infer/src/backend/joinState.ml index 1732c614a..0101d871a 100644 --- a/infer/src/backend/joinState.ml +++ b/infer/src/backend/joinState.ml @@ -14,6 +14,9 @@ open! IStd type mode = | Pre | Post +[@@deriving compare] + +let equal_mode = [%compare.equal : mode] (** set to true when we are doing join of footprints *) let footprint = ref false diff --git a/infer/src/backend/joinState.mli b/infer/src/backend/joinState.mli index e70954905..2c2b48a6a 100644 --- a/infer/src/backend/joinState.mli +++ b/infer/src/backend/joinState.mli @@ -14,6 +14,9 @@ open! IStd type mode = | Pre | Post +[@@deriving compare] + +val equal_mode : mode -> mode -> bool val get_footprint : unit -> bool val set_footprint : bool -> unit diff --git a/infer/src/backend/specs.mli b/infer/src/backend/specs.mli index 7292f239f..be5dbb479 100644 --- a/infer/src/backend/specs.mli +++ b/infer/src/backend/specs.mli @@ -119,6 +119,8 @@ type status = ACTIVE | INACTIVE | STALE type phase = FOOTPRINT | RE_EXECUTION +val equal_phase : phase -> phase -> bool + type dependency_map_t = int Procname.Map.t type call_summary = CallSite.Set.t Annot.Map.t diff --git a/infer/src/base/IStd.ml b/infer/src/base/IStd.ml index 54edd9810..4ecf456c4 100644 --- a/infer/src/base/IStd.ml +++ b/infer/src/base/IStd.ml @@ -52,7 +52,7 @@ 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 *) +let (=) = No_polymorphic_compare.(=) module PVariant = struct (* Equality for polymorphic variants *) diff --git a/infer/src/checkers/BoundedCallTree.ml b/infer/src/checkers/BoundedCallTree.ml index ed3a1d426..b5776afa1 100644 --- a/infer/src/checkers/BoundedCallTree.ml +++ b/infer/src/checkers/BoundedCallTree.ml @@ -124,7 +124,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Procname.C _ -> true (* Needed for test code. *) | Procname.Block _ | Procname.Linters_dummy_method -> failwith "Proc type not supported by crashcontext: block" in - frame.Stacktrace.method_str = (Procname.get_method caller) && + String.equal frame.Stacktrace.method_str (Procname.get_method caller) && matches_class caller in let all_frames = IList.flatten (IList.map (fun trace -> trace.Stacktrace.frames) traces) in diff --git a/infer/src/checkers/SimpleChecker.ml b/infer/src/checkers/SimpleChecker.ml index 516140402..715ac4c5d 100644 --- a/infer/src/checkers/SimpleChecker.ml +++ b/infer/src/checkers/SimpleChecker.ml @@ -95,7 +95,7 @@ module Make (Spec : Spec) : S = struct (* should never fail since keys in the invariant map should always be real node id's *) let node = IList.find - (fun node -> Procdesc.Node.compare_id node_id (Procdesc.Node.get_id node) = 0) + (fun node -> Procdesc.Node.equal_id node_id (Procdesc.Node.get_id node)) nodes in Domain.iter (fun astate -> diff --git a/infer/src/checkers/ThreadSafety.ml b/infer/src/checkers/ThreadSafety.ml index eda23aec9..53bb81a73 100644 --- a/infer/src/checkers/ThreadSafety.ml +++ b/infer/src/checkers/ThreadSafety.ml @@ -388,7 +388,9 @@ let is_immutable_collection_class class_name tenv = "com.google.common.collect.ImmutableTable"; ] in PatternMatch.supertype_exists - tenv (fun typename _ -> IList.mem (=) (Typename.name typename) immutable_collections) class_name + tenv + (fun typename _ -> IList.mem String.equal (Typename.name typename) immutable_collections) + class_name let is_call_to_builder_class_method = function | Procname.Java java_pname -> is_builder_class (Procname.java_get_class_name java_pname) @@ -560,7 +562,7 @@ let should_report_on_file file_env = fun (_, tenv, pname, _) -> match get_current_class_and_threadsafe_superclasses tenv pname with | Some (_, thread_safe_annotated_classes) -> - not (thread_safe_annotated_classes = []) + not (List.is_empty thread_safe_annotated_classes) | _ -> false in let current_class_marked_not_threadsafe = diff --git a/infer/src/checkers/ThreadSafetyDomain.ml b/infer/src/checkers/ThreadSafetyDomain.ml index 894b7cda4..7d3b8012d 100644 --- a/infer/src/checkers/ThreadSafetyDomain.ml +++ b/infer/src/checkers/ThreadSafetyDomain.ml @@ -49,7 +49,7 @@ module PathDomain = SinkTrace.Make(TraceElem) module IntMap = PrettyPrintable.MakePPMap(struct type t = int - let compare = Pervasives.compare + let compare = Int.compare let pp_key fmt = F.fprintf fmt "%d" end) diff --git a/infer/src/checkers/Trace.ml b/infer/src/checkers/Trace.ml index 1403e8702..c493ad113 100644 --- a/infer/src/checkers/Trace.ml +++ b/infer/src/checkers/Trace.ml @@ -288,7 +288,7 @@ module Make (Spec : Spec) = struct (fun passthrough1 passthrough2 -> let loc1 = CallSite.loc (Passthrough.site passthrough1) in let loc2 = CallSite.loc (Passthrough.site passthrough2) in - Pervasives.compare loc1.Location.line loc2.Location.line) + Int.compare loc1.Location.line loc2.Location.line) (Passthroughs.elements passthroughs) in IList.fold_right trace_elem_of_passthrough sorted_passthroughs acc0 in diff --git a/infer/src/checkers/annotationReachability.ml b/infer/src/checkers/annotationReachability.ml index 7be77dc31..fc77a3c72 100644 --- a/infer/src/checkers/annotationReachability.ml +++ b/infer/src/checkers/annotationReachability.ml @@ -194,7 +194,7 @@ let report_allocation_stack Reporting.log_error pname ~loc:fst_call_loc ~ltr:final_trace exn let report_annotation_stack src_annot snk_annot src_pname loc trace stack_str snk_pname call_loc = - if snk_annot = dummy_constructor_annot + if String.equal snk_annot dummy_constructor_annot then report_allocation_stack src_annot src_pname loc trace stack_str snk_pname call_loc else let final_trace = IList.rev (update_trace call_loc trace) in @@ -209,7 +209,7 @@ let report_annotation_stack src_annot snk_annot src_pname loc trace stack_str sn exp_pname_str snk_annot in let msg = - if src_annot = Annotations.performance_critical + if String.equal src_annot Annotations.performance_critical then calls_expensive_method else annotation_reachability_error in let exn = @@ -259,7 +259,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let is_unlikely pname = match pname with | Procname.Java java_pname -> - (Procname.java_get_method java_pname) = "unlikely" + String.equal (Procname.java_get_method java_pname) "unlikely" | _ -> false let is_tracking_exp astate = function @@ -283,7 +283,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct (* TODO: generalize this to allow sanitizers for other annotation types, store it in [extras] so we can compute it just once *) let method_is_sanitizer annot tenv pname = - if annot.Annot.class_name = dummy_constructor_annot + if String.equal annot.Annot.class_name dummy_constructor_annot then method_has_ignore_allocation_annot tenv pname else false @@ -393,7 +393,7 @@ module Interprocedural = struct (CallSite.make proc_name loc) calls in let calls = extract_calls_with_annot snk_annot call_map in - if not (IList.length calls = 0) + if not (Int.equal (IList.length calls) 0) then IList.iter (report_src_snk_path calls) src_annot_list in let initial = diff --git a/infer/src/checkers/checkDeadCode.ml b/infer/src/checkers/checkDeadCode.ml index 1fbba6cd0..5eb9c82a8 100644 --- a/infer/src/checkers/checkDeadCode.ml +++ b/infer/src/checkers/checkDeadCode.ml @@ -83,7 +83,7 @@ let check_final_state tenv proc_name proc_desc final_s = let description = Format.sprintf "Node not visited: %d" (Procdesc.Node.get_id n :> int) in let report = match Procdesc.Node.get_kind n with | Procdesc.Node.Join_node -> false - | k when k = Procdesc.Node.exn_sink_kind -> false + | k when Procdesc.Node.equal_nodekind k Procdesc.Node.exn_sink_kind -> false | _ -> true in if report then report_error tenv description proc_name proc_desc loc in diff --git a/infer/src/checkers/checkTraceCallSequence.ml b/infer/src/checkers/checkTraceCallSequence.ml index ef9de4503..8ebff4898 100644 --- a/infer/src/checkers/checkTraceCallSequence.ml +++ b/infer/src/checkers/checkTraceCallSequence.ml @@ -47,13 +47,13 @@ module APIs = struct let method_match pn pkgname cname mname = match pn with | Procname.Java pn_java -> - Procname.java_get_method pn_java = mname + String.equal (Procname.java_get_method pn_java) mname && (match pkgname with | "" -> - Procname.java_get_simple_class_name pn_java = cname + String.equal (Procname.java_get_simple_class_name pn_java) cname | _ -> - Procname.java_get_class_name pn_java = pkgname ^ "." ^ cname) + String.equal (Procname.java_get_class_name pn_java) (pkgname ^ "." ^ cname)) | _ -> false let is_begin pn = @@ -113,11 +113,11 @@ module State = struct (** State is balanced. *) let is_balanced s = - ElemSet.for_all (fun elem -> Elem.get_int elem = 0) s + ElemSet.for_all (fun elem -> Int.equal (Elem.get_int elem) 0) s let equal = ElemSet.equal - let has_zero s = ElemSet.exists (fun elem -> Elem.get_int elem = 0) s + let has_zero s = ElemSet.exists (fun elem -> Int.equal (Elem.get_int elem) 0) s (** Map a function to the elements of the set, and filter out inconsistencies. *) let map2 (f : Elem.t -> Elem.t list) (s : t) : t = diff --git a/infer/src/checkers/fragmentRetainsViewChecker.ml b/infer/src/checkers/fragmentRetainsViewChecker.ml index dc9f7d810..7e0ddade6 100644 --- a/infer/src/checkers/fragmentRetainsViewChecker.ml +++ b/infer/src/checkers/fragmentRetainsViewChecker.ml @@ -24,7 +24,7 @@ let callback_fragment_retains_view_java pname_java { Callbacks.proc_desc; tenv } = (* TODO: complain if onDestroyView is not defined, yet the Fragment has View fields *) (* TODO: handle fields nullified in callees in the same file *) - let is_on_destroy_view = Procname.java_get_method pname_java = "onDestroyView" in + let is_on_destroy_view = String.equal (Procname.java_get_method pname_java) "onDestroyView" in let fld_typ_is_view = function | Typ.Tptr (Tstruct tname, _) -> AndroidFramework.is_view tenv tname | _ -> false in diff --git a/infer/src/checkers/repeatedCallsChecker.ml b/infer/src/checkers/repeatedCallsChecker.ml index bd144b9db..4679e0e6d 100644 --- a/infer/src/checkers/repeatedCallsChecker.ml +++ b/infer/src/checkers/repeatedCallsChecker.ml @@ -56,6 +56,9 @@ struct type paths = | AllPaths (** Check on all paths *) | SomePath (** Check if some path exists *) + [@@deriving compare] + + let equal_paths = [%compare.equal : paths] (** Check if the procedure performs an allocation operation. If [paths] is AllPaths, check if an allocation happens on all paths. @@ -77,21 +80,21 @@ struct let module DFAllocCheck = Dataflow.MakeDF(struct type t = Location.t option [@@deriving compare] - let equal x y = compare x y = 0 - let _join _paths l1o l2o = (* join with left priority *) + let equal = [%compare.equal : t] + let join_ paths_ l1o l2o = (* join with left priority *) match l1o, l2o with | None, None -> None | Some loc, None | None, Some loc -> - if _paths = AllPaths then None else Some loc + if equal_paths paths_ AllPaths then None else Some loc | Some loc1, Some _ -> Some loc1 (* left priority *) - let join = _join paths + let join = join_ paths let do_node _ node lo1 = let lo2 = node_allocates node in let lo' = (* use left priority join to implement transfer function *) - _join SomePath lo1 lo2 in + join_ SomePath lo1 lo2 in [lo'], [lo'] let proc_throws _ = Dataflow.DontKnow end) in diff --git a/infer/src/checkers/sqlChecker.ml b/infer/src/checkers/sqlChecker.ml index 255bf370a..c4f923f04 100644 --- a/infer/src/checkers/sqlChecker.ml +++ b/infer/src/checkers/sqlChecker.ml @@ -29,8 +29,8 @@ let callback_sql { Callbacks.proc_desc; proc_name; tenv } = (* Check for SQL string concatenations *) let do_instr const_map node instr = let do_call pn_java i1 i2 l = - if Procname.java_get_class_name pn_java = "java.lang.StringBuilder" - && Procname.java_get_method pn_java = "append" + if String.equal (Procname.java_get_class_name pn_java) "java.lang.StringBuilder" + && String.equal (Procname.java_get_method pn_java) "append" then begin let rvar1 = Exp.Var i1 in diff --git a/infer/src/clang/CType_decl.ml b/infer/src/clang/CType_decl.ml index 2875f50b6..7d973a8e7 100644 --- a/infer/src/clang/CType_decl.ml +++ b/infer/src/clang/CType_decl.ml @@ -180,7 +180,7 @@ and get_record_declaration_struct_type tenv decl = [StructTyp.objc_ref_counter_field] else [] in let annots = - if csu = Csu.Class Csu.CPP then Annot.Class.cpp + if Csu.equal csu (Csu.Class Csu.CPP) then Annot.Class.cpp else Annot.Item.empty (* No annotations for structs *) in if is_complete_definition then ( CAst_utils.update_sil_types_map type_ptr (Typ.Tstruct sil_typename); diff --git a/infer/src/clang/Capture.re b/infer/src/clang/Capture.re index c803cadb6..6a6b6d872 100644 --- a/infer/src/clang/Capture.re +++ b/infer/src/clang/Capture.re @@ -158,7 +158,10 @@ let cc1_capture clang_cmd => { Utils.filename_to_absolute root::root orig_argv.(Array.length orig_argv - 1) }; Logging.out "@\n*** Beginning capture of file %s ***@\n" source_path; - if (Config.analyzer == Config.Compile || CLocation.is_file_blacklisted source_path) { + if ( + Config.equal_analyzer Config.analyzer Config.Compile || + CLocation.is_file_blacklisted source_path + ) { Logging.out "@\n Skip the analysis of source file %s@\n@\n" source_path; /* We still need to run clang, but we don't have to attach the plugin. */ run_clang (ClangCommand.command_to_run clang_cmd) Utils.consume_in diff --git a/infer/src/clang/ClangWrapper.re b/infer/src/clang/ClangWrapper.re index c631eb880..40f120693 100644 --- a/infer/src/clang/ClangWrapper.re +++ b/infer/src/clang/ClangWrapper.re @@ -105,8 +105,8 @@ let exe prog::prog args::args => { | None => (clang_xx, false) }; IList.iter exec_action_item commands; - if (commands == [] || should_run_original_command) { - if (commands == []) { + if (List.is_empty commands || should_run_original_command) { + if (List.is_empty commands) { /* No command to execute after -###, let's execute the original command instead. diff --git a/infer/src/clang/ComponentKit.ml b/infer/src/clang/ComponentKit.ml index 92a0dd928..993c558d5 100644 --- a/infer/src/clang/ComponentKit.ml +++ b/infer/src/clang/ComponentKit.ml @@ -8,6 +8,7 @@ *) open! IStd +open! PVariant let get_source_range an = match an with @@ -231,7 +232,7 @@ let component_with_multiple_factory_methods_advice context an = | ObjCMethodDecl (decl_info, _, _) -> decl_info.Clang_ast_t.di_attributes | _ -> assert false in let unavailable_attrs = (IList.filter is_unavailable_attr attrs) in - let is_available = IList.length unavailable_attrs = 0 in + let is_available = Int.equal (IList.length unavailable_attrs) 0 in (CAst_utils.is_objc_factory_method if_decl decl) && is_available in let check_interface if_decl = diff --git a/infer/src/clang/cAst_utils.ml b/infer/src/clang/cAst_utils.ml index a9fa769ae..a4604728c 100644 --- a/infer/src/clang/cAst_utils.ml +++ b/infer/src/clang/cAst_utils.ml @@ -8,6 +8,7 @@ *) open! IStd +open! PVariant (** Functions for transformations of ast nodes *) @@ -105,15 +106,6 @@ let generated_ivar_name property_name = } | _ -> make_name_decl property_name.Clang_ast_t.ni_name -let compare_property_attribute = - [%compare: [ - `Readonly | `Assign | `Readwrite | `Retain | `Copy | `Nonatomic | `Atomic - | `Weak | `Strong | `Unsafe_unretained | `ExplicitGetter | `ExplicitSetter - ]] - -let equal_property_attribute att1 att2 = - compare_property_attribute att1 att2 = 0 - let get_memory_management_attributes () = [`Assign; `Retain; `Copy; `Weak; `Strong; `Unsafe_unretained] @@ -235,8 +227,10 @@ let get_decl_from_typ_ptr typ_ptr = let is_type_nonnull type_ptr = let open Clang_ast_t in match get_type type_ptr with - | Some AttributedType (_, attr_info) -> attr_info.ati_attr_kind = `Nonnull - | _ -> false + | Some AttributedType (_, attr_info) -> + attr_info.ati_attr_kind = `Nonnull + | _ -> + false let is_type_nullable type_ptr = let open Clang_ast_t in @@ -283,7 +277,7 @@ let get_function_decl_with_body decl_ptr = | Some (CXXDestructorDecl (_, _, _, fdecl_info, _)) -> fdecl_info.Clang_ast_t.fdi_decl_ptr_with_body | _ -> Some decl_ptr in - if decl_ptr' = (Some decl_ptr) then decl_opt + if [%compare.equal : int option] decl_ptr' (Some decl_ptr) then decl_opt else get_decl_opt decl_ptr' let get_info_from_decl_ref decl_ref = @@ -317,7 +311,7 @@ let is_ptr_to_objc_class typ class_name = | Some ObjCInterfaceType (_, ptr) -> (match get_decl ptr with | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> - String.compare ndi.ni_name class_name = 0 + String.equal ndi.ni_name class_name | _ -> false) | _ -> false) | _ -> false @@ -442,7 +436,7 @@ let if_decl_to_di_pointer_opt if_decl = let is_instance_type type_ptr = match name_opt_of_typedef_type_ptr type_ptr with - | Some name -> name = "instancetype" + | Some name -> String.equal name "instancetype" | None -> false let return_type_matches_class_type rtp type_decl_pointer = @@ -452,7 +446,7 @@ let return_type_matches_class_type rtp type_decl_pointer = let return_type_decl_opt = type_ptr_to_objc_interface rtp in let return_type_decl_pointer_opt = Option.map ~f:if_decl_to_di_pointer_opt return_type_decl_opt in - (Some type_decl_pointer) = return_type_decl_pointer_opt + [%compare.equal : int option option] (Some type_decl_pointer) return_type_decl_pointer_opt let is_objc_factory_method if_decl meth_decl = let if_type_decl_pointer = if_decl_to_di_pointer_opt if_decl in diff --git a/infer/src/clang/cAst_utils.mli b/infer/src/clang/cAst_utils.mli index 9a96b69a8..ac7c1f734 100644 --- a/infer/src/clang/cAst_utils.mli +++ b/infer/src/clang/cAst_utils.mli @@ -23,15 +23,9 @@ val name_opt_of_name_info_opt : Clang_ast_t.named_decl_info option -> string opt val property_name : Clang_ast_t.obj_c_property_impl_decl_info -> Clang_ast_t.named_decl_info -val compare_property_attribute : - Clang_ast_t.property_attribute -> Clang_ast_t.property_attribute -> int - val generated_ivar_name : Clang_ast_t.named_decl_info -> Clang_ast_t.named_decl_info -val equal_property_attribute : - Clang_ast_t.property_attribute -> Clang_ast_t.property_attribute -> bool - val get_memory_management_attributes : unit -> Clang_ast_t.property_attribute list val is_retain : Clang_ast_t.property_attribute option -> bool diff --git a/infer/src/clang/cContext.ml b/infer/src/clang/cContext.ml index dad5bdb7d..6a1e190ad 100644 --- a/infer/src/clang/cContext.ml +++ b/infer/src/clang/cContext.ml @@ -32,8 +32,7 @@ type curr_class = | ContextNoCls [@@deriving compare] -let equal_curr_class curr_class1 curr_class2 = - compare_curr_class curr_class1 curr_class2 = 0 +let equal_curr_class = [%compare.equal : curr_class] type str_node_map = (string, Procdesc.Node.t) Hashtbl.t diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index 49eb0e827..10b1c1fe9 100644 --- a/infer/src/clang/cField_decl.ml +++ b/infer/src/clang/cField_decl.ml @@ -92,7 +92,7 @@ let modelled_fields_in_classes = let modelled_field class_name_info = let modelled_field_in_class res (class_name, field_name, typ) = - if class_name = class_name_info.Clang_ast_t.ni_name then + if String.equal class_name class_name_info.Clang_ast_t.ni_name then let class_name_qualified = class_name_info.Clang_ast_t.ni_qual_name in let field_name_qualified = CAst_utils.make_qual_name_decl class_name_qualified field_name in let name = CGeneral_utils.mk_class_field_name field_name_qualified in diff --git a/infer/src/clang/cFrontend_config.ml b/infer/src/clang/cFrontend_config.ml index dea232785..b85f02572 100644 --- a/infer/src/clang/cFrontend_config.ml +++ b/infer/src/clang/cFrontend_config.ml @@ -11,7 +11,9 @@ open! IStd (** Module that contains constants and global state used in the frontend *) -type clang_lang = C | CPP | ObjC | ObjCPP +type clang_lang = C | CPP | ObjC | ObjCPP [@@deriving compare] + +let equal_clang_lang = [%compare.equal : clang_lang] type translation_unit_context = { lang : clang_lang; diff --git a/infer/src/clang/cFrontend_config.mli b/infer/src/clang/cFrontend_config.mli index cbc4091d1..9903bc15e 100644 --- a/infer/src/clang/cFrontend_config.mli +++ b/infer/src/clang/cFrontend_config.mli @@ -11,7 +11,9 @@ open! IStd (** Module that contains constants and global state used in the frontend *) -type clang_lang = C | CPP | ObjC | ObjCPP +type clang_lang = C | CPP | ObjC | ObjCPP [@@deriving compare] + +val equal_clang_lang : clang_lang -> clang_lang -> bool type translation_unit_context = { lang : clang_lang; diff --git a/infer/src/clang/cFrontend_errors.ml b/infer/src/clang/cFrontend_errors.ml index a17ef2917..45eae4b55 100644 --- a/infer/src/clang/cFrontend_errors.ml +++ b/infer/src/clang/cFrontend_errors.ml @@ -135,7 +135,7 @@ let expand_checkers checkers = match acc with | True | False -> acc - | Atomic (name, [p]) when formula_id_const = p -> + | Atomic (name, [p]) when String.equal formula_id_const p -> Logging.out " -Expanding formula identifier '%s'\n" name; (match Core.Std.String.Map.find map name with | Some f1 -> expand f1 map diff --git a/infer/src/clang/cGeneral_utils.ml b/infer/src/clang/cGeneral_utils.ml index a3d607014..cecc4eea8 100644 --- a/infer/src/clang/cGeneral_utils.ml +++ b/infer/src/clang/cGeneral_utils.ml @@ -44,7 +44,7 @@ let append_no_duplicates_methods list1 list2 = append_no_duplicates Procname.equal list1 list2 let append_no_duplicates_annotations list1 list2 = - let eq (annot1, _) (annot2, _) = annot1.Annot.class_name = annot2.Annot.class_name in + let eq (annot1, _) (annot2, _) = String.equal annot1.Annot.class_name annot2.Annot.class_name in append_no_duplicates eq list1 list2 let add_no_duplicates_fields field_tuple l = @@ -86,7 +86,7 @@ let rec collect_list_tuples l (a, a1, b, c, d) = let is_static_var var_decl_info = match var_decl_info.Clang_ast_t.vdi_storage_class with - | Some sc -> sc = CFrontend_config.static + | Some sc -> String.equal sc CFrontend_config.static | _ -> false let block_procname_with_index defining_proc i = @@ -139,11 +139,13 @@ let mk_class_field_name field_qual_name = let is_cpp_translation translation_unit_context = let lang = translation_unit_context.CFrontend_config.lang in - lang = CFrontend_config.CPP || lang = CFrontend_config.ObjCPP + CFrontend_config.equal_clang_lang lang CFrontend_config.CPP || + CFrontend_config.equal_clang_lang lang CFrontend_config.ObjCPP let is_objc_extension translation_unit_context = let lang = translation_unit_context.CFrontend_config.lang in - lang = CFrontend_config.ObjC || lang = CFrontend_config.ObjCPP + CFrontend_config.equal_clang_lang lang CFrontend_config.ObjC || + CFrontend_config.equal_clang_lang lang CFrontend_config.ObjCPP let rec get_mangled_method_name function_decl_info method_decl_info = (* For virtual methods return mangled name of the method from most base class @@ -183,7 +185,7 @@ let mk_procname_from_function translation_unit_context name function_decl_info_o | Some m when is_cpp_translation translation_unit_context -> m | _ -> "" in let mangled = (Utils.string_crc_hex32 file) ^ mangled_name in - if String.length file = 0 && String.length mangled_name = 0 then + if String.is_empty file && String.is_empty mangled_name then Procname.from_string_c_fun name else Procname.C (Procname.c name mangled) diff --git a/infer/src/clang/cLocation.ml b/infer/src/clang/cLocation.ml index 65f8018b5..bbfcbb68e 100644 --- a/infer/src/clang/cLocation.ml +++ b/infer/src/clang/cLocation.ml @@ -8,6 +8,7 @@ *) open! IStd +open! PVariant (** Module for function to retrieve the location (file, line, etc) of instructions *) diff --git a/infer/src/clang/cMethod_signature.ml b/infer/src/clang/cMethod_signature.ml index d25210941..3dfef7807 100644 --- a/infer/src/clang/cMethod_signature.ml +++ b/infer/src/clang/cMethod_signature.ml @@ -66,13 +66,13 @@ let ms_get_return_param_typ { return_param_typ } = (* it has 1 argument (this includes self) *) let ms_is_getter { pointer_to_property_opt; args } = Option.is_some pointer_to_property_opt && - IList.length args = 1 + Int.equal (IList.length args) 1 (* A method is a setter if it has a link to a property and *) (* it has 2 argument (this includes self) *) let ms_is_setter { pointer_to_property_opt; args } = Option.is_some pointer_to_property_opt && - IList.length args = 2 + Int.equal (IList.length args) 2 let make_ms name args ret_type attributes loc is_instance ?is_cpp_virtual language pointer_to_parent pointer_to_property_opt return_param_typ = diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index 370a7a916..f618c6355 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -23,7 +23,9 @@ exception Invalid_declaration type method_call_type = | MCVirtual | MCNoVirtual - | MCStatic + | MCStatic [@@deriving compare] + +let equal_method_call_type = [%compare.equal : method_call_type] type function_method_decl_info = | Func_decl_info of Clang_ast_t.function_decl_info * Clang_ast_t.type_ptr @@ -297,10 +299,14 @@ let get_formal_parameters tenv ms = | [] -> [] | (mangled, {Clang_ast_t.qt_type_ptr}):: pl' -> let should_add_pointer name ms = - let is_objc_self = name = CFrontend_config.self && - CMethod_signature.ms_get_lang ms = CFrontend_config.ObjC in - let is_cxx_this = name = CFrontend_config.this && - CMethod_signature.ms_get_lang ms = CFrontend_config.CPP in + let is_objc_self = + String.equal name CFrontend_config.self && + CFrontend_config.equal_clang_lang + (CMethod_signature.ms_get_lang ms) CFrontend_config.ObjC in + let is_cxx_this = + String.equal name CFrontend_config.this && + CFrontend_config.equal_clang_lang + (CMethod_signature.ms_get_lang ms) CFrontend_config.CPP in (is_objc_self && CMethod_signature.ms_is_instance ms) || is_cxx_this in let tp = if should_add_pointer (Mangled.to_string mangled) ms then (Ast_expressions.create_pointer_type qt_type_ptr) @@ -377,14 +383,15 @@ let get_const_args_indices ~shift args = (** Creates a procedure description. *) let create_local_procdesc trans_unit_ctx cfg tenv ms fbody captured is_objc_inst_method = - let defined = not ((IList.length fbody) = 0) in + let defined = not (Int.equal (IList.length fbody) 0) in let proc_name = CMethod_signature.ms_get_name ms in let pname = Procname.to_string proc_name in let attributes = sil_func_attributes_of_attributes (CMethod_signature.ms_get_attributes ms) in let method_annotation = sil_method_annotation_of_args (CMethod_signature.ms_get_args ms) in - let is_cpp_inst_method = CMethod_signature.ms_is_instance ms - && CMethod_signature.ms_get_lang ms = CFrontend_config.CPP in + let is_cpp_inst_method = + CMethod_signature.ms_is_instance ms && + CFrontend_config.equal_clang_lang (CMethod_signature.ms_get_lang ms) CFrontend_config.CPP in let create_new_procdesc () = let formals = get_formal_parameters tenv ms in let captured_mangled = IList.map (fun (var, t) -> (Pvar.get_name var), t) captured in diff --git a/infer/src/clang/cMethod_trans.mli b/infer/src/clang/cMethod_trans.mli index 5be48a536..067cd5c99 100644 --- a/infer/src/clang/cMethod_trans.mli +++ b/infer/src/clang/cMethod_trans.mli @@ -19,7 +19,9 @@ open! IStd type method_call_type = | MCVirtual | MCNoVirtual - | MCStatic + | MCStatic [@@deriving compare] + +val equal_method_call_type : method_call_type -> method_call_type -> bool val should_add_return_param : Typ.t -> is_objc_method:bool -> bool diff --git a/infer/src/clang/cPredicates.ml b/infer/src/clang/cPredicates.ml index df003825a..63e1261c2 100644 --- a/infer/src/clang/cPredicates.ml +++ b/infer/src/clang/cPredicates.ml @@ -61,12 +61,12 @@ let pp_predicate fmt (name, arglist) = Format.fprintf fmt "%s(%a)" name (Pp.comma_seq Format.pp_print_string) arglist let is_declaration_kind decl s = - Clang_ast_proj.get_decl_kind_string decl = s + String.equal (Clang_ast_proj.get_decl_kind_string decl) s (* st |= call_method(m) *) let call_method m st = match st with - | Clang_ast_t.ObjCMessageExpr (_, _, _, omei) -> omei.omei_selector = m + | Clang_ast_t.ObjCMessageExpr (_, _, _, omei) -> String.equal omei.omei_selector m | _ -> false let property_name_contains_word word decl = @@ -92,7 +92,7 @@ let decl_ref_is_in names st = | Clang_ast_t.DeclRefExpr (_, _, _, drti) -> (match drti.drti_decl_ref with | Some dr -> let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in - IList.exists (fun n -> n = ndi.ni_name) names + IList.exists (String.equal ndi.ni_name) names | _ -> false) | _ -> false @@ -120,7 +120,7 @@ let is_property_pointer_type decl = | Some ObjCObjectPointerType _ | Some BlockPointerType _ -> true | Some TypedefType (_, tti) -> - (CAst_utils.name_of_typedef_type_info tti) = CFrontend_config.id_cl + String.equal (CAst_utils.name_of_typedef_type_info tti) CFrontend_config.id_cl | exception Not_found -> false | _ -> false) | _ -> false @@ -137,7 +137,7 @@ let is_ivar_atomic stmt = (match CAst_utils.get_decl ivar_pointer with | Some d -> let attributes = get_ivar_attributes d in - IList.exists (CAst_utils.equal_property_attribute `Atomic) attributes + IList.exists (PVariant.(=) `Atomic) attributes | _ -> false) | _ -> false @@ -154,7 +154,7 @@ let is_method_property_accessor_of_ivar stmt context = match CAst_utils.get_decl_opt_with_decl_ref property_opt with | Some ObjCPropertyDecl (_, _, pdi) -> (match pdi.opdi_ivar_decl with - | Some decl_ref -> decl_ref.dr_decl_pointer = ivar_pointer + | Some decl_ref -> Int.equal decl_ref.dr_decl_pointer ivar_pointer | None -> false) | _ -> false else false @@ -188,7 +188,7 @@ let is_binop_with_kind str_kind stmt = failwith ("Binary operator kind " ^ str_kind ^ " is not valid"); match stmt with | Clang_ast_t.BinaryOperator (_, _, _, boi) -> - Clang_ast_proj.string_of_binop_kind boi.boi_kind = str_kind + String.equal (Clang_ast_proj.string_of_binop_kind boi.boi_kind) str_kind | _ -> false let is_unop_with_kind str_kind stmt = @@ -196,18 +196,18 @@ let is_unop_with_kind str_kind stmt = failwith ("Unary operator kind " ^ str_kind ^ " is not valid"); match stmt with | Clang_ast_t.UnaryOperator (_, _, _, uoi) -> - Clang_ast_proj.string_of_unop_kind uoi.uoi_kind = str_kind + String.equal (Clang_ast_proj.string_of_unop_kind uoi.uoi_kind) str_kind | _ -> false let is_stmt nodename stmt = if not (Clang_ast_proj.is_valid_astnode_kind nodename) then failwith ("Statement " ^ nodename ^ " is not a valid statement"); - nodename = Clang_ast_proj.get_stmt_kind_string stmt + String.equal nodename (Clang_ast_proj.get_stmt_kind_string stmt) let is_decl nodename decl = if not (Clang_ast_proj.is_valid_astnode_kind nodename) then failwith ("Declaration " ^ nodename ^ " is not a valid declaration"); - nodename = Clang_ast_proj.get_decl_kind_string decl + String.equal nodename (Clang_ast_proj.get_decl_kind_string decl) let isa classname stmt = match Clang_ast_proj.get_expr_tuple stmt with @@ -220,5 +220,5 @@ let decl_unavailable_in_supported_ios_sdk decl = let available_attr_ios_sdk = get_available_attr_ios_sdk decl in match available_attr_ios_sdk, Config.iphoneos_target_sdk_version with | Some available_attr_ios_sdk, Some iphoneos_target_sdk_version -> - Utils.compare_versions available_attr_ios_sdk iphoneos_target_sdk_version = 1 + Int.equal (Utils.compare_versions available_attr_ios_sdk iphoneos_target_sdk_version) 1 | _ -> false diff --git a/infer/src/clang/cTL.ml b/infer/src/clang/cTL.ml index d451da288..f2fbbc85a 100644 --- a/infer/src/clang/cTL.ml +++ b/infer/src/clang/cTL.ml @@ -53,6 +53,8 @@ type ast_node = | Stmt of Clang_ast_t.stmt | Decl of Clang_ast_t.decl +let equal_ast_node = Poly.(=) + module Debug = struct let pp_transition fmt trans_opt = let pp_aux fmt trans = match trans with @@ -175,7 +177,7 @@ module Debug = struct let root_node = get_root tree in let children = get_children tree in let edge child_node = - if root_node.content.ast_node = child_node.content.ast_node then + if equal_ast_node root_node.content.ast_node child_node.content.ast_node then Printf.sprintf "%d -> %d [style=dotted]" root_node.id child_node.id else Printf.sprintf "%d -> %d [style=bold]" root_node.id child_node.id in @@ -196,9 +198,9 @@ module Debug = struct let smart_string_of_formula phi = let num_children = IList.length children in match phi with - | And _ when num_children = 2 -> "(...) AND (...)" - | Or _ when num_children = 2 -> "(...) OR (...)" - | Implies _ when num_children = 2 -> "(...) ==> (...)" + | And _ when Int.equal num_children 2 -> "(...) AND (...)" + | Or _ when Int.equal num_children 2 -> "(...) OR (...)" + | Implies _ when Int.equal num_children 2 -> "(...) ==> (...)" | Not _ -> "NOT(...)" | _ -> Format.asprintf "%a" pp_formula phi in Format.sprintf "(%d)\\n%s\\n%s\\n%s" diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index 6ee37d207..b192ae372 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -8,6 +8,7 @@ *) open! IStd +open! PVariant (** Translates instructions: (statements and expressions) from the ast into sil *) @@ -447,7 +448,7 @@ struct Some BuiltinDecl.__objc_release_cf | _ when CTrans_models.is_retain_builtin name type_ptr -> Some BuiltinDecl.__objc_retain_cf - | _ when name = CFrontend_config.malloc && + | _ when String.equal name CFrontend_config.malloc && CGeneral_utils.is_objc_extension trans_unit_ctx -> Some BuiltinDecl.malloc_no_fail | _ -> None @@ -874,7 +875,7 @@ struct ~f:CTrans_models.is_cf_retain_release ~default:false callee_pname_opt in let act_params = let params = IList.tl (collect_exprs result_trans_subexprs) in - if IList.length params = IList.length params_stmt then + if Int.equal (IList.length params) (IList.length params_stmt) then params else (Logging.err_debug "WARNING: stmt_list and res_trans_par.exps must have same size. \ @@ -913,7 +914,7 @@ struct let procname = Procdesc.get_proc_name context.procdesc in let sil_loc = CLocation.get_sil_location si context in (* first for method address, second for 'this' expression *) - assert ((IList.length result_trans_callee.exps) = 2); + assert (Int.equal (IList.length result_trans_callee.exps) 2); let (sil_method, _) = IList.hd result_trans_callee.exps in let callee_pname = match sil_method with @@ -1012,12 +1013,13 @@ struct let receiver_kind = obj_c_message_expr_info.Clang_ast_t.omei_receiver_kind in let selector = obj_c_message_expr_info.Clang_ast_t.omei_selector in (* class method *) - if selector = CFrontend_config.class_method && CType.is_class method_type then + if String.equal selector CFrontend_config.class_method && CType.is_class method_type then let class_name = CMethod_trans.get_class_name_method_call_from_receiver_kind context obj_c_message_expr_info act_params in raise (Self.SelfClassException class_name) (* alloc or new *) - else if (selector = CFrontend_config.alloc) || (selector = CFrontend_config.new_str) then + else if String.equal selector CFrontend_config.alloc || + String.equal selector CFrontend_config.new_str then match receiver_kind with | `Class type_ptr -> let class_opt = @@ -1075,7 +1077,8 @@ struct obj_c_message_expr_info in let res_trans_subexpr_list = res_trans_add_self :: res_trans_subexpr_list in let subexpr_exprs = collect_exprs res_trans_subexpr_list in - let is_virtual = method_call_type = CMethod_trans.MCVirtual in + let is_virtual = + CMethod_trans.equal_method_call_type method_call_type CMethod_trans.MCVirtual in Cg.add_edge context.CContext.cg procname callee_name; let param_exps, instr_block_param = @@ -1217,7 +1220,7 @@ struct IList.iter (fun n' -> Procdesc.node_set_succs_exn context.procdesc n' [prune_t; prune_f] []) res_trans_cond.leaf_nodes; - let rnodes = if (IList.length res_trans_cond.root_nodes) = 0 then + let rnodes = if Int.equal (IList.length res_trans_cond.root_nodes) 0 then [prune_t; prune_f] else res_trans_cond.root_nodes in { empty_res_trans with @@ -1251,7 +1254,7 @@ struct (fun n -> Procdesc.node_set_succs_exn context.procdesc n res_trans_s2.root_nodes []) prune_to_s2; let root_nodes_to_parent = - if (IList.length res_trans_s1.root_nodes) = 0 + if Int.equal (IList.length res_trans_s1.root_nodes) 0 then res_trans_s1.leaf_nodes else res_trans_s1.root_nodes in let (exp1, typ1) = extract_exp res_trans_s1.exps in @@ -1630,7 +1633,7 @@ struct let res_trans_subexpr_list = initListExpr_initializers_trans trans_state var_exp 0 stmts typ false stmt_info in let rh_exps = collect_exprs res_trans_subexpr_list in - if IList.length rh_exps = 0 then + if Int.equal (IList.length rh_exps) 0 then let exps = match Sil.zero_value_of_numerical_type_option var_type with | Some zero_exp -> [(zero_exp, typ)] @@ -1644,7 +1647,7 @@ struct let i = IList.length lh - IList.length rh_exps in IList.drop_last i lh else lh in - if IList.length rh_exps = IList.length lh then + if Int.equal (IList.length rh_exps) (IList.length lh) then (* Creating new instructions by assigning right hand side to left hand side expressions *) let assign_instr (lh_exp, lh_t) (rh_exp, _) = Sil.Store (lh_exp, lh_t, rh_exp, sil_loc) in let assign_instrs = diff --git a/infer/src/clang/cTrans_models.ml b/infer/src/clang/cTrans_models.ml index e3c0b0440..537f3076b 100644 --- a/infer/src/clang/cTrans_models.ml +++ b/infer/src/clang/cTrans_models.ml @@ -12,10 +12,10 @@ open! IStd open Objc_models let is_cf_non_null_alloc pname = - Procname.to_string pname = CFrontend_config.cf_non_null_alloc + String.equal (Procname.to_string pname) CFrontend_config.cf_non_null_alloc let is_alloc pname = - Procname.to_string pname = CFrontend_config.cf_alloc + String.equal (Procname.to_string pname) CFrontend_config.cf_alloc let is_alloc_model typ pname = if Specs.summary_exists pname then false @@ -27,13 +27,13 @@ let is_alloc_model typ pname = Core_foundation_model.is_core_lib_create typ funct let is_builtin_expect pname = - Procname.to_string pname = CFrontend_config.builtin_expect + String.equal (Procname.to_string pname) CFrontend_config.builtin_expect let is_builtin_object_size pname = - (Procname.to_string pname) = CFrontend_config.builtin_object_size + String.equal (Procname.to_string pname) CFrontend_config.builtin_object_size let is_replace_with_deref_first_arg pname = - (Procname.to_string pname) = CFrontend_config.replace_with_deref_first_arg_attr + String.equal (Procname.to_string pname) CFrontend_config.replace_with_deref_first_arg_attr let is_retain_predefined_model typ pname = let funct = Procname.to_string pname in @@ -45,13 +45,13 @@ let is_release_predefined_model typ pname = Core_foundation_model.is_core_graphics_release typ funct let is_retain_method funct = - funct = CFrontend_config.retain + String.equal funct CFrontend_config.retain let is_release_method funct = - funct = CFrontend_config.release + String.equal funct CFrontend_config.release let is_autorelease_method funct = - funct = CFrontend_config.autorelease + String.equal funct CFrontend_config.autorelease let get_builtinname method_name = if is_retain_method method_name then @@ -63,7 +63,7 @@ let get_builtinname method_name = else None let is_modeled_builtin funct = - funct = CFrontend_config.builtin_memset_chk + String.equal funct CFrontend_config.builtin_memset_chk let is_modeled_attribute attr_name = IList.mem String.equal attr_name CFrontend_config.modeled_function_attributes @@ -89,17 +89,17 @@ let is_retain_builtin funct fun_type = | _ -> false let is_assert_log_s funct = - funct = CFrontend_config.assert_rtn || - funct = CFrontend_config.assert_fail || - funct = CFrontend_config.fbAssertWithSignalAndLogFunctionHelper || + String.equal funct CFrontend_config.assert_rtn || + String.equal funct CFrontend_config.assert_fail || + String.equal funct CFrontend_config.fbAssertWithSignalAndLogFunctionHelper || String.is_substring ~substring:CFrontend_config.google_MakeCheckOpString funct let is_assert_log_method m = - m = CFrontend_config.google_LogMessageFatal + String.equal m CFrontend_config.google_LogMessageFatal let is_handleFailureInMethod funct = - funct = CFrontend_config.handleFailureInMethod || - funct = CFrontend_config.handleFailureInFunction + String.equal funct CFrontend_config.handleFailureInMethod || + String.equal funct CFrontend_config.handleFailureInFunction let is_retain_or_release funct = is_retain_method funct || @@ -108,10 +108,10 @@ let is_retain_or_release funct = let is_toll_free_bridging pn = let funct = (Procname.to_string pn) in - funct = CFrontend_config.cf_bridging_release || - funct = CFrontend_config.cf_bridging_retain || - funct = CFrontend_config.cf_autorelease || - funct = CFrontend_config.ns_make_collectable + String.equal funct CFrontend_config.cf_bridging_release || + String.equal funct CFrontend_config.cf_bridging_retain || + String.equal funct CFrontend_config.cf_autorelease || + String.equal funct CFrontend_config.ns_make_collectable let is_cf_retain_release pn = Procname.equal pn BuiltinDecl.__objc_retain_cf @@ -143,8 +143,8 @@ let get_predefined_ms_method condition class_name method_name method_kind mk_pro let get_predefined_ms_stringWithUTF8String class_name method_name mk_procname lang = let condition = - class_name = CFrontend_config.nsstring_cl - && method_name = CFrontend_config.string_with_utf8_m in + String.equal class_name CFrontend_config.nsstring_cl && + String.equal method_name CFrontend_config.string_with_utf8_m in let id_type = Ast_expressions.create_id_type in let args = [(Mangled.from_string "x", Ast_expressions.create_char_star_qual_type ~is_const:true)] in @@ -164,8 +164,8 @@ let get_predefined_ms_retain_release method_name mk_procname lang = let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname lang = let condition = - method_name = CFrontend_config.init - && class_name = CFrontend_config.nsautorelease_pool_cl in + String.equal method_name CFrontend_config.init && + String.equal class_name CFrontend_config.nsautorelease_pool_cl in let class_type = Ast_expressions.create_class_qual_type (class_name, `OBJC) in get_predefined_ms_method condition class_name method_name Procname.ObjCInstanceMethod mk_procname lang [(Mangled.from_string CFrontend_config.self, class_type)] @@ -173,8 +173,10 @@ let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname la let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname lang = let condition = - (method_name = CFrontend_config.release || method_name = CFrontend_config.drain) - && class_name = CFrontend_config.nsautorelease_pool_cl in + (String.equal method_name CFrontend_config.release || + String.equal method_name CFrontend_config.drain) + && + String.equal class_name CFrontend_config.nsautorelease_pool_cl in let class_type = Ast_expressions.create_class_qual_type (class_name, `OBJC) in let args = [(Mangled.from_string CFrontend_config.self, class_type)] in get_predefined_ms_method condition class_name method_name Procname.ObjCInstanceMethod @@ -182,7 +184,7 @@ let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procna [] (Some BuiltinDecl.__objc_release_autorelease_pool) let get_predefined_ms_is_kind_of_class class_name method_name mk_procname lang = - let condition = method_name = CFrontend_config.is_kind_of_class in + let condition = String.equal method_name CFrontend_config.is_kind_of_class in let class_type = Ast_expressions.create_class_qual_type (class_name, `OBJC) in let args = [(Mangled.from_string CFrontend_config.self, class_type)] in get_predefined_ms_method condition class_name method_name Procname.ObjCInstanceMethod @@ -214,7 +216,8 @@ let is_dispatch_function_name function_name = let rec is_dispatch functions = match functions with | [] -> None - | (el, block_arg_pos):: rest -> if (el = function_name) then - Some (el, block_arg_pos) + | (el, block_arg_pos):: rest -> + if (String.equal el function_name) + then Some (el, block_arg_pos) else is_dispatch rest in is_dispatch dispatch_functions diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index 207fb5ce3..a6ccf0d7c 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -231,7 +231,7 @@ struct let own_priority_node pri stmt_info = match pri with - | Busy p when p = stmt_info.Clang_ast_t.si_pointer -> true + | Busy p when Int.equal p stmt_info.Clang_ast_t.si_pointer -> true | _ -> false (* Used by translation functions to handle potenatial cfg nodes. *) @@ -356,9 +356,9 @@ let new_or_alloc_trans trans_state loc stmt_info type_ptr class_name_opt selecto match class_name_opt with | Some class_name -> class_name | None -> CType.classname_of_type function_type in - if selector = CFrontend_config.alloc then + if String.equal selector CFrontend_config.alloc then alloc_trans trans_state loc stmt_info function_type true None - else if selector = CFrontend_config.new_str then + else if String.equal selector CFrontend_config.new_str then objc_new_trans trans_state loc stmt_info class_name function_type else assert false @@ -596,7 +596,7 @@ struct else empty_res_trans let is_var_self pvar is_objc_method = - let is_self = Mangled.to_string (Pvar.get_name pvar) = CFrontend_config.self in + let is_self = String.equal (Mangled.to_string (Pvar.get_name pvar)) CFrontend_config.self in is_self && is_objc_method end @@ -612,7 +612,7 @@ let is_owning_name n = else ( let prefix = Str.string_before s' (String.length fam) in let suffix = Str.string_after s' (String.length fam) in - prefix = fam && not (Str.string_match (Str.regexp "[a-z]") suffix 0) + String.equal prefix fam && not (Str.string_match (Str.regexp "[a-z]") suffix 0) ) in match Str.split (Str.regexp_string ":") n with | fst:: _ -> @@ -706,7 +706,7 @@ let is_dispatch_function stmt_list = | _ -> None let is_block_enumerate_function mei = - mei.Clang_ast_t.omei_selector = CFrontend_config.enumerateObjectsUsingBlock + String.equal mei.Clang_ast_t.omei_selector CFrontend_config.enumerateObjectsUsingBlock (* This takes a variable of type struct or array and returns a list of expressions *) (* for each of its fields (also recursively, such that each field access is of a basic type) *) diff --git a/infer/src/clang/cVar_decl.ml b/infer/src/clang/cVar_decl.ml index 8959148fa..b29ead81f 100644 --- a/infer/src/clang/cVar_decl.ml +++ b/infer/src/clang/cVar_decl.ml @@ -8,6 +8,7 @@ *) open! IStd +open! PVariant (** Process variable declarations by saving them as local or global variables. *) (** Computes the local variables of a function or method to be added to the procdesc *) @@ -95,7 +96,8 @@ let captured_vars_from_block_info context cvl = (match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_type_ptr with | Some name_info, Some type_ptr -> let n = name_info.Clang_ast_t.ni_name in - if n = CFrontend_config.self && not (CContext.is_objc_instance context) then + if String.equal n CFrontend_config.self && + not (CContext.is_objc_instance context) then vars else let pvar = sil_var_of_decl_ref context dr procname in diff --git a/infer/src/eradicate/eradicate.ml b/infer/src/eradicate/eradicate.ml index b1f1bf0a7..fe85c677f 100644 --- a/infer/src/eradicate/eradicate.ml +++ b/infer/src/eradicate/eradicate.ml @@ -189,6 +189,8 @@ struct let module Initializers = struct type init = Procname.t * Procdesc.t + let equal_class_opt = [%compare.equal : string option] + let final_typestates initializers_current_class = (* Get the private methods, from the same class, directly called by the initializers. *) let get_private_called (initializers : init list) : init list = @@ -196,14 +198,14 @@ struct let do_proc (init_pn, init_pd) = let filter callee_pn callee_attributes = let is_private = - callee_attributes.ProcAttributes.access = PredSymb.Private in + PredSymb.equal_access callee_attributes.ProcAttributes.access PredSymb.Private in let same_class = let get_class_opt pn = match pn with | Procname.Java pn_java -> Some (Procname.java_get_class_name pn_java) | _ -> None in - get_class_opt init_pn = get_class_opt callee_pn in + equal_class_opt (get_class_opt init_pn) (get_class_opt callee_pn) in is_private && same_class in let private_called = PatternMatch.proc_calls Specs.proc_resolve_attributes init_pd filter in @@ -280,7 +282,7 @@ struct pname_and_pdescs_with (function (pname, proc_attributes) -> is_initializer proc_attributes && - get_class pname = get_class curr_pname) in + equal_class_opt (get_class pname) (get_class curr_pname)) in final_typestates ((curr_pname, curr_pdesc) :: initializers_current_class) end @@ -292,7 +294,7 @@ struct pname_and_pdescs_with (fun (pname, _) -> Procname.is_constructor pname && - get_class pname = get_class curr_pname) in + equal_class_opt (get_class pname) (get_class curr_pname)) in final_typestates constructors_current_class end diff --git a/infer/src/eradicate/eradicateChecks.ml b/infer/src/eradicate/eradicateChecks.ml index 82fd1bd1d..299223de5 100644 --- a/infer/src/eradicate/eradicateChecks.ml +++ b/infer/src/eradicate/eradicateChecks.ml @@ -56,14 +56,14 @@ let classify_procedure proc_attributes = let is_virtual = function - | (p, _, _):: _ when Mangled.to_string p = "this" -> true + | (p, _, _):: _ when String.equal (Mangled.to_string p) "this" -> true | _ -> false (** Check an access (read or write) to a field. *) let check_field_access tenv find_canonical_duplicate curr_pname node instr_ref exp fname ta loc : unit = - if TypeAnnotation.get_value Annotations.Nullable ta = true then + if TypeAnnotation.get_value Annotations.Nullable ta then let origin_descr = TypeAnnotation.descr_origin tenv ta in report_error tenv find_canonical_duplicate @@ -82,7 +82,7 @@ let check_array_access tenv ta loc indexed = - if TypeAnnotation.get_value Annotations.Nullable ta = true then + if TypeAnnotation.get_value Annotations.Nullable ta then let origin_descr = TypeAnnotation.descr_origin tenv ta in report_error tenv find_canonical_duplicate @@ -99,6 +99,9 @@ type from_call = | From_is_true_on_null (** returns true on null *) | From_optional_isPresent (** x.isPresent *) | From_containsKey (** x.containsKey *) +[@@ deriving compare] + +let equal_from_call = [%compare.equal : from_call] (** Check the normalized "is zero" or "is not zero" condition of a prune instruction. *) let check_condition tenv case_zero find_canonical_duplicate curr_pdesc @@ -141,13 +144,13 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc let is_temp = Idenv.exp_is_temp idenv e in let nonnull = is_fun_nonnull ta in let should_report = - TypeAnnotation.get_value Annotations.Nullable ta = false && + not (TypeAnnotation.get_value Annotations.Nullable ta) && (Config.eradicate_condition_redundant || nonnull) && true_branch && (not is_temp || nonnull) && PatternMatch.type_is_class typ && not (from_try_with_resources ()) && - from_call = From_condition && + equal_from_call from_call From_condition && not (TypeAnnotation.origin_is_fun_library ta) in let is_always_true = not case_zero in let nonnull = is_fun_nonnull ta in @@ -181,15 +184,15 @@ let check_field_assignment tenv Annotations.ia_is_field_injector_readwrite ia | _ -> false in - TypeAnnotation.get_value Annotations.Nullable ta_lhs = false && - TypeAnnotation.get_value Annotations.Nullable ta_rhs = true && + not (TypeAnnotation.get_value Annotations.Nullable ta_lhs) && + TypeAnnotation.get_value Annotations.Nullable ta_rhs && PatternMatch.type_is_class t_lhs && not (Ident.java_fieldname_is_outer_instance fname) && not (field_is_field_injector_readwrite ()) in let should_report_absent = Config.eradicate_optional_present && - TypeAnnotation.get_value Annotations.Present ta_lhs = true && - TypeAnnotation.get_value Annotations.Present ta_rhs = false && + TypeAnnotation.get_value Annotations.Present ta_lhs && + not (TypeAnnotation.get_value Annotations.Present ta_rhs) && not (Ident.java_fieldname_is_outer_instance fname) in let should_report_mutable = let field_is_mutable () = match t_ia_opt with @@ -278,7 +281,7 @@ let check_constructor_initialization tenv final_type_annotation_with true (Lazy.force final_constructor_typestates) - (fun ta -> TypeAnnotation.get_value Annotations.Nullable ta = true) in + (fun ta -> TypeAnnotation.get_value Annotations.Nullable ta) in let should_check_field_initialization = let in_current_class = @@ -442,7 +445,7 @@ let check_call_parameters tenv let tot_param_num = IList.length sig_params - (if has_this then 1 else 0) in let rec check sparams cparams = match sparams, cparams with | (s1, ia1, t1) :: sparams', ((orig_e2, e2), t2) :: cparams' -> - let param_is_this = Mangled.to_string s1 = "this" in + let param_is_this = String.equal (Mangled.to_string s1) "this" in let formal_is_nullable = Annotations.ia_is_nullable ia1 in let formal_is_present = Annotations.ia_is_present ia1 in let (_, ta2, _) = @@ -539,7 +542,7 @@ let check_overridden_annotations let current_params = annotated_signature.Annotations.params and overridden_params = overriden_signature.Annotations.params in let initial_pos = if is_virtual current_params then 0 else 1 in - if (IList.length current_params) = (IList.length overridden_params) then + if Int.equal (IList.length current_params) (IList.length overridden_params) then ignore (IList.fold_left2 compare initial_pos current_params overridden_params) in let check overriden_proc_name = diff --git a/infer/src/eradicate/typeCheck.ml b/infer/src/eradicate/typeCheck.ml index f3ac4a541..01268941f 100644 --- a/infer/src/eradicate/typeCheck.ml +++ b/infer/src/eradicate/typeCheck.ml @@ -385,7 +385,9 @@ let typecheck_instr let constructor_check_calls_this calls_this pn = match curr_pname, pn with | Procname.Java curr_pname_java, Procname.Java pn_java -> - if Procname.java_get_class_name curr_pname_java = Procname.java_get_class_name pn_java + if String.equal + (Procname.java_get_class_name curr_pname_java) + (Procname.java_get_class_name pn_java) then calls_this := true | _ -> () in @@ -402,7 +404,7 @@ let typecheck_instr (* Drop reference parameters to this and outer objects. *) let is_hidden_parameter (n, _) = let n_str = Mangled.to_string n in - n_str = "this" || + String.equal n_str "this" || Str.string_match (Str.regexp "$bcvar[0-9]+") n_str 0 in let rec drop_n_args ntl = match ntl with | fp:: tail when is_hidden_parameter fp -> 1 + drop_n_args tail @@ -573,7 +575,7 @@ let typecheck_instr IList.mapi (fun i (_, typ) -> let arg = - if i = 0 && + if Int.equal i 0 && not (Procname.java_is_static callee_pname) then "this" else Printf.sprintf "arg%d" i in @@ -634,7 +636,7 @@ let typecheck_instr | Some (t, ta, _) -> let should_report = Config.eradicate_condition_redundant && - TypeAnnotation.get_value Annotations.Nullable ta = false && + not (TypeAnnotation.get_value Annotations.Nullable ta) && not (TypeAnnotation.origin_is_fun_library ta) in if checks.eradicate && should_report then begin @@ -824,7 +826,7 @@ let typecheck_instr else typestate1 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 if Models.is_check_not_null callee_pname then @@ -997,7 +999,7 @@ let typecheck_instr begin match from_call with | EradicateChecks.From_optional_isPresent -> - if TypeAnnotation.get_value Annotations.Present ta = false + if not (TypeAnnotation.get_value Annotations.Present ta) then set_flag e' Annotations.Present true typestate2 else typestate2 | EradicateChecks.From_is_true_on_null -> @@ -1084,7 +1086,7 @@ let typecheck_node typestates_exn := typestate :: !typestates_exn | Sil.Store (Exp.Lvar pv, _, _, _) when Pvar.is_return pv && - Procdesc.Node.get_kind node = Procdesc.Node.throw_kind -> + Procdesc.Node.equal_nodekind (Procdesc.Node.get_kind node) Procdesc.Node.throw_kind -> (* throw instruction *) typestates_exn := typestate :: !typestates_exn | _ -> () in @@ -1107,7 +1109,9 @@ let typecheck_node let typestate_succ = IList.fold_left (do_instruction ext) typestate instrs in let dont_propagate = - Procdesc.Node.get_kind node = Procdesc.Node.exn_sink_kind (* don't propagate exceptions *) + Procdesc.Node.equal_nodekind + (Procdesc.Node.get_kind node) + Procdesc.Node.exn_sink_kind (* don't propagate exceptions *) || !noreturn in if dont_propagate diff --git a/infer/src/harness/androidFramework.ml b/infer/src/harness/androidFramework.ml index 18e8b208e..e75b83ec3 100644 --- a/infer/src/harness/androidFramework.ml +++ b/infer/src/harness/androidFramework.ml @@ -91,7 +91,7 @@ let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs = IList.find (fun decl_proc -> match decl_proc with | Procname.Java decl_proc_java -> - lifecycle_proc = Procname.java_get_method decl_proc_java + String.equal lifecycle_proc (Procname.java_get_method decl_proc_java) | _ -> false ) methods in diff --git a/infer/src/harness/inhabit.ml b/infer/src/harness/inhabit.ml index c14ebbbed..18a74cd70 100644 --- a/infer/src/harness/inhabit.ml +++ b/infer/src/harness/inhabit.ml @@ -61,7 +61,7 @@ let create_fresh_local_name () = "dummy_local" ^ string_of_int !local_name_cntr (** more forgiving variation of IList.tl that won't raise an exception on the empty list *) -let tl_or_empty l = if l = [] then l else IList.tl l +let tl_or_empty l = if List.is_empty l then l else IList.tl l let get_non_receiver_formals formals = tl_or_empty formals @@ -173,7 +173,7 @@ and inhabit_constructor tenv constr_name (allocated_obj, obj_type) cfg env = let inhabit_call_with_args procname procdesc args env = let retval = let ret_typ = Procdesc.get_ret_type procdesc in - let is_void = ret_typ = Typ.Tvoid in + let is_void = Typ.equal ret_typ Typ.Tvoid in if is_void then None else Some (Ident.create_fresh Ident.knormal, ret_typ) in let call_instr = let fun_exp = fun_exp_from_name procname in diff --git a/infer/src/integration/Maven.ml b/infer/src/integration/Maven.ml index 3102ab523..99d979cfd 100644 --- a/infer/src/integration/Maven.ml +++ b/infer/src/integration/Maven.ml @@ -56,7 +56,7 @@ let add_infer_profile_to_xml maven_xml infer_xml = | `El_start tag -> Xmlm.output xml_out elt_in; let tag_name = snd (fst tag) in - if tag_name = "profiles" then ( + if String.equal tag_name "profiles" then ( found_profiles_tag := true ); process xml_in xml_out (tag_name::tag_stack) @@ -86,7 +86,7 @@ let add_infer_profile_to_xml maven_xml infer_xml = | `Data data -> Xmlm.output xml_out elt_in; (match tag_stack with - | "id"::"profile"::"profiles"::_ when data = infer_profile_name -> + | "id"::"profile"::"profiles"::_ when String.equal data infer_profile_name -> L.do_out "Found infer profile, not adding one@."; found_infer_profile := true | "module"::"modules"::_ -> diff --git a/infer/src/java/jFrontend.ml b/infer/src/java/jFrontend.ml index b43cd6671..cdf620b95 100644 --- a/infer/src/java/jFrontend.ml +++ b/infer/src/java/jFrontend.ml @@ -9,6 +9,7 @@ *) open! IStd +open! PVariant open Javalib_pack open Sawja_pack @@ -20,7 +21,7 @@ let add_edges (context : JContext.t) start_node exn_node exit_nodes method_body_nodes impl super_call = let pc_nb = Array.length method_body_nodes in let last_pc = pc_nb - 1 in - let is_last pc = (pc = last_pc) in + let is_last pc = Int.equal pc last_pc in let rec get_body_nodes pc = let current_nodes = method_body_nodes.(pc) in match current_nodes with @@ -37,7 +38,7 @@ let add_edges match JContext.get_goto_jump context pc with | JContext.Next -> get_body_nodes (pc + 1) | JContext.Jump goto_pc -> - if pc = goto_pc then [] (* loop in goto *) + if Int.equal pc goto_pc then [] (* loop in goto *) else get_body_nodes goto_pc | JContext.Exit -> exit_nodes in let get_succ_nodes node pc = @@ -105,8 +106,8 @@ let cache_classname cn = let splitted_root_dir = let rec split l p = match p with - | p when p = Filename.current_dir_name -> l - | p when p = Filename.dir_sep -> l + | p when String.equal p Filename.current_dir_name -> l + | p when String.equal p Filename.dir_sep -> l | p -> split ((Filename.basename p):: l) (Filename.dirname p) in split [] (Filename.dirname path) in let rec mkdir l p = @@ -163,8 +164,8 @@ let should_capture classes package_opt source_basename node = let classname = Javalib.get_name node in let match_package pkg cn = match JTransType.package_to_string (JBasics.cn_package cn) with - | None -> pkg = "" - | Some found_pkg -> found_pkg = pkg in + | None -> String.equal pkg "" + | Some found_pkg -> String.equal found_pkg pkg in if JBasics.ClassSet.mem classname classes then begin match Javalib.get_sourcefile node with @@ -172,10 +173,10 @@ let should_capture classes package_opt source_basename node = | Some found_basename -> begin match package_opt with - | None -> found_basename = source_basename + | None -> String.equal found_basename source_basename | Some pkg -> match_package pkg classname - && found_basename = source_basename + && String.equal found_basename source_basename end end else false diff --git a/infer/src/java/jTrans.ml b/infer/src/java/jTrans.ml index 0549f3fae..e1f2d8145 100644 --- a/infer/src/java/jTrans.ml +++ b/infer/src/java/jTrans.ml @@ -81,7 +81,7 @@ let get_undefined_method_call ovt = match ot with | JBasics.TArray _ -> assert false | JBasics.TClass cn -> - if JBasics.cn_name cn = JConfig.string_cl then + if String.equal (JBasics.cn_name cn) JConfig.string_cl then "string_undefined" else if JBasics.cn_equal cn JBasics.java_lang_object then @@ -97,7 +97,7 @@ let get_undefined_method_call ovt = let retrieve_fieldname fieldname = try let subs = Str.split (Str.regexp (Str.quote ".")) (Ident.fieldname_to_string fieldname) in - if IList.length subs = 0 then + if Int.equal (IList.length subs) 0 then assert false else IList.hd (IList.rev subs) @@ -108,7 +108,7 @@ let get_field_name program static tenv cn fs = let { StructTyp.fields; statics; } = JTransType.get_class_struct_typ program tenv cn in match IList.find - (fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs) + (fun (fieldname, _, _) -> String.equal (retrieve_fieldname fieldname) (JBasics.fs_name fs)) (if static then statics else fields) with | fieldname, _, _ -> @@ -226,10 +226,10 @@ let get_test_operator op = | `Ne -> Binop.Ne let is_java_native cm = - (cm.Javalib.cm_implementation = Javalib.Native) + Poly.(=) cm.Javalib.cm_implementation Javalib.Native let is_clone ms = - JBasics.ms_name ms = JConfig.clone_name + String.equal (JBasics.ms_name ms) JConfig.clone_name let get_implementation cm = match cm.Javalib.cm_implementation with @@ -258,7 +258,7 @@ let get_implementation cm = (hacked_bytecode, jbir_code) let update_constr_loc cn ms loc_start = - if (JBasics.ms_name ms) = JConfig.constructor_name then + if String.equal (JBasics.ms_name ms) JConfig.constructor_name then try ignore(JBasics.ClassMap.find cn !constr_loc_map) with Not_found -> constr_loc_map := (JBasics.ClassMap.add cn loc_start !constr_loc_map) @@ -411,7 +411,7 @@ let rec expression (context : JContext.t) pc expr = | JBir.Const c -> begin match c with (* We use the constant internally to mean a variable. *) - | `String s when (JBasics.jstr_pp s) = JConfig.field_cst -> + | `String s when String.equal (JBasics.jstr_pp s) JConfig.field_cst -> let varname = JConfig.field_st in let procname = (Procdesc.get_proc_name context.procdesc) in let pvar = Pvar.mk varname procname in @@ -639,9 +639,9 @@ let detect_loop entry_pc impl = begin let visited_updated = Int.Set.add visited pc in match code.(pc) with - | JBir.Goto goto_pc when goto_pc = entry_pc -> (true, empty) + | JBir.Goto goto_pc when Int.equal goto_pc entry_pc -> (true, empty) | JBir.Goto goto_pc -> loop visited_updated goto_pc - | JBir.Ifd (_, if_pc) when if_pc = entry_pc -> (true, empty) + | JBir.Ifd (_, if_pc) when Int.equal if_pc entry_pc -> (true, empty) | JBir.Ifd (_, if_pc) -> let (loop_detected, visited_after) = loop visited_updated (pc + 1) in if loop_detected then @@ -649,7 +649,7 @@ let detect_loop entry_pc impl = else loop visited_after if_pc | _ -> - if (pc + 1) = entry_pc then + if Int.equal (pc + 1) entry_pc then (true, empty) else loop visited_updated (pc + 1) @@ -680,7 +680,7 @@ let is_this expr = begin match JBir.var_name_debug var with | None -> false - | Some name_opt -> Mangled.to_string JConfig.this = name_opt + | Some name_opt -> String.equal (Mangled.to_string JConfig.this) name_opt end | _ -> false diff --git a/infer/src/java/jTransExn.ml b/infer/src/java/jTransExn.ml index 3dc5c1197..c5a15b6ce 100644 --- a/infer/src/java/jTransExn.ml +++ b/infer/src/java/jTransExn.ml @@ -94,7 +94,7 @@ let translate_exceptions (context : JContext.t) exit_nodes get_body_nodes handle create_node loc node_kind_false instrs_false in Procdesc.node_set_succs_exn procdesc node_true catch_nodes exit_nodes; Procdesc.node_set_succs_exn procdesc node_false succ_nodes exit_nodes; - let is_finally = handler.JBir.e_catch_type = None in + let is_finally = is_none handler.JBir.e_catch_type in if is_finally then [node_true] (* TODO (#4759480): clean up the translation so prune nodes are not created at all *) else [node_true; node_false] in diff --git a/infer/src/java/jTransType.ml b/infer/src/java/jTransType.ml index 7e60e90a8..0a4498ede 100644 --- a/infer/src/java/jTransType.ml +++ b/infer/src/java/jTransType.ml @@ -173,7 +173,7 @@ let method_signature_names ms = let return_type_name = match JBasics.ms_rtype ms with | None -> - if JBasics.ms_name ms = JConfig.constructor_name then + if String.equal (JBasics.ms_name ms) JConfig.constructor_name then None else Some (None, JConfig.void) @@ -384,7 +384,7 @@ let sizeof_of_object_type program tenv ot subtypes = (** return the name and type of a formal parameter, looking up the class name in case of "this" *) let param_type program tenv cn name vt = - if (JBir.var_name_g name) = Mangled.to_string JConfig.this + if String.equal (JBir.var_name_g name) (Mangled.to_string JConfig.this) then get_class_type program tenv cn else value_type program tenv vt diff --git a/infer/src/unit/TraceTests.ml b/infer/src/unit/TraceTests.ml index b00b2bc5f..f48558aef 100644 --- a/infer/src/unit/TraceTests.ml +++ b/infer/src/unit/TraceTests.ml @@ -58,7 +58,7 @@ module MockSource = struct let get_tainted_formals _ = assert false end)) - let equal source1 source2 = compare source1 source2 = 0 + let equal = [%compare.equal : t] end module MockSink = struct @@ -67,7 +67,7 @@ module MockSink = struct let get _ = assert false - let equal sink1 sink2 = compare sink1 sink2 = 0 + let equal = [%compare.equal : t] end @@ -76,7 +76,7 @@ module MockTrace = Trace.Make(struct module Sink = MockSink let should_report source sink = - Source.kind source = Sink.kind sink + [%compare.equal : MockTraceElem.t] (Source.kind source) (Sink.kind sink) end) let tests = diff --git a/infer/src/unit/accessPathTests.ml b/infer/src/unit/accessPathTests.ml index 352f27f2a..f95305ab5 100644 --- a/infer/src/unit/accessPathTests.ml +++ b/infer/src/unit/accessPathTests.ml @@ -140,7 +140,7 @@ let tests = F.fprintf fmt "Expected %s but got %s" expected actual in let assert_eq input_aps expected = let input = F.asprintf "%a" AccessPathDomains.Set.pp input_aps in - assert_equal ~cmp:(=) ~pp_diff input expected in + assert_equal ~cmp:String.equal ~pp_diff input expected in let aps1 = AccessPathDomains.Set.of_list [x_exact; x_abstract] in (* { x*, x } *) let aps2 = AccessPathDomains.Set.add xF_exact aps1 in (* x*, x, x.f *) let aps3 = AccessPathDomains.Set.add yF_exact aps2 in (* x*, x, x.f, y.f *) diff --git a/infer/src/unit/accessTreeTests.ml b/infer/src/unit/accessTreeTests.ml index 09dc5db70..1519206ee 100644 --- a/infer/src/unit/accessTreeTests.ml +++ b/infer/src/unit/accessTreeTests.ml @@ -445,7 +445,7 @@ let tests = (fun (ap, trace) -> AccessPath.equal ap ap_in && MockTraceDomain.equal trace trace_in) ap_traces in - assert_bool "Should have six ap/trace pairs" (IList.length ap_traces = 6); + assert_bool "Should have six ap/trace pairs" (Int.equal (IList.length ap_traces) 6); assert_bool "has x pair" (has_ap_trace_pair x x_trace); assert_bool "has xF pair" (has_ap_trace_pair xF xF_trace); assert_bool "has xFG pair" (has_ap_trace_pair xFG xFG_trace); diff --git a/infer/src/unit/procCfgTests.ml b/infer/src/unit/procCfgTests.ml index a5269e17a..125e3a3d1 100644 --- a/infer/src/unit/procCfgTests.ml +++ b/infer/src/unit/procCfgTests.ml @@ -96,7 +96,9 @@ let tests = end; assert_bool "underlying_node should return node of underlying CFG type" - (Procdesc.Node.get_id (BackwardInstrCfg.underlying_node n1) = BackwardCfg.id n1) in + (Procdesc.Node.equal_id + (Procdesc.Node.get_id (BackwardInstrCfg.underlying_node n1)) + (BackwardCfg.id n1)) in "instr_test">::instr_test_ in let graph_tests = [ diff --git a/infer/src/unit/schedulerTests.ml b/infer/src/unit/schedulerTests.ml index 091711488..b627b3cda 100644 --- a/infer/src/unit/schedulerTests.ml +++ b/infer/src/unit/schedulerTests.ml @@ -35,13 +35,13 @@ module MockProcCfg = struct include (MockNode : module type of MockNode with type t := node) type t = (node * node list) list - let compare_id = Int.compare + let equal_id = Int.equal let succs t n = try let node_id = id n in IList.find - (fun (node, _) -> compare_id (id node) node_id = 0) + (fun (node, _) -> equal_id (id node) node_id) t |> snd with Not_found -> [] @@ -51,7 +51,7 @@ module MockProcCfg = struct let node_id = id n in IList.filter (fun (_, succs) -> - IList.exists (fun node -> compare_id (id node) node_id = 0) succs) + IList.exists (fun node -> equal_id (id node) node_id) succs) t |> IList.map fst with Not_found -> []