From 4e3afbe3298598ed06041678659fce492f7584a3 Mon Sep 17 00:00:00 2001 From: Jules Villard Date: Fri, 4 Jun 2021 08:32:57 -0700 Subject: [PATCH] [caml] 4.12 is fussier about possible name ambiguities Summary: Fix warnings ahead of OCaml upgrade. Reviewed By: ngorogiannis Differential Revision: D28870887 fbshipit-source-id: 6682bbb6e --- infer/src/absint/HilExp.ml | 28 +++++++++++------------ infer/src/backend/preanal.ml | 14 ++++++------ infer/src/biabduction/Abs.ml | 2 +- infer/src/biabduction/Attribute.ml | 18 +++++++-------- infer/src/biabduction/Prover.ml | 17 +++++++------- infer/src/bufferoverrun/absLoc.ml | 9 ++++---- infer/src/checkers/addressTaken.ml | 24 +++++++++---------- infer/src/checkers/functionPointers.ml | 11 +++++---- infer/src/clang/cGeneral_utils.ml | 7 +++--- infer/src/concurrency/RacerDModels.ml | 18 +++++++-------- infer/src/concurrency/starvationDomain.ml | 2 +- infer/src/quandary/ClangTrace.ml | 2 +- infer/src/quandary/TaintAnalysis.ml | 12 ++++------ 13 files changed, 82 insertions(+), 82 deletions(-) diff --git a/infer/src/absint/HilExp.ml b/infer/src/absint/HilExp.ml index e70e41f32..ce3929233 100644 --- a/infer/src/absint/HilExp.ml +++ b/infer/src/absint/HilExp.ml @@ -432,8 +432,8 @@ let rec array_index_of_exp ~include_array_indexes ~f_resolve_id ~add_deref exp t and access_exprs_of_exp ~include_array_indexes ~f_resolve_id ~add_deref exp0 typ0 = let rec of_exp_ exp typ (add_accesses : AccessExpression.t -> AccessExpression.t) acc : AccessExpression.t list = - match exp with - | Exp.Var id -> ( + match (exp : Exp.t) with + | Var id -> ( match f_resolve_id (Var.of_id id) with | Some access_expr -> let access_expr' = @@ -446,7 +446,7 @@ and access_exprs_of_exp ~include_array_indexes ~f_resolve_id ~add_deref exp0 typ if add_deref then AccessExpression.dereference access_expr else access_expr in add_accesses access_expr' :: acc ) - | Exp.Lvar pvar when Pvar.is_ssa_frontend_tmp pvar -> ( + | Lvar pvar when Pvar.is_ssa_frontend_tmp pvar -> ( match f_resolve_id (Var.of_pvar pvar) with | Some access_expr -> (* do not need to add deref here as it was added implicitly in the binding *) @@ -462,18 +462,18 @@ and access_exprs_of_exp ~include_array_indexes ~f_resolve_id ~add_deref exp0 typ if add_deref then AccessExpression.dereference access_expr else access_expr in add_accesses access_expr' :: acc ) - | Exp.Lvar pvar -> + | Lvar pvar -> let access_expr = AccessExpression.of_pvar pvar typ in let access_expr' = if add_deref then AccessExpression.dereference access_expr else access_expr in add_accesses access_expr' :: acc - | Exp.Lfield (root_exp, fld, root_exp_typ) -> + | Lfield (root_exp, fld, root_exp_typ) -> let add_field_access_expr access_expr = add_accesses (AccessExpression.field_offset access_expr fld) in of_exp_ root_exp root_exp_typ add_field_access_expr acc - | Exp.Lindex (root_exp, index_exp) -> + | Lindex (root_exp, index_exp) -> let index = let index_typ = (* TODO: bogus *) StdTyp.void in array_index_of_exp ~include_array_indexes ~f_resolve_id ~add_deref index_exp index_typ @@ -483,28 +483,28 @@ and access_exprs_of_exp ~include_array_indexes ~f_resolve_id ~add_deref exp0 typ in let array_typ = Typ.mk_array typ in of_exp_ root_exp array_typ add_array_access_expr acc - | Exp.Cast (cast_typ, cast_exp) -> + | Cast (cast_typ, cast_exp) -> of_exp_ cast_exp cast_typ Fn.id acc - | Exp.UnOp (_, unop_exp, _) -> + | UnOp (_, unop_exp, _) -> of_exp_ unop_exp typ Fn.id acc - | Exp.Exn exn_exp -> + | Exn exn_exp -> of_exp_ exn_exp typ Fn.id acc - | Exp.BinOp (_, exp1, exp2) -> + | BinOp (_, exp1, exp2) -> of_exp_ exp1 typ Fn.id acc |> of_exp_ exp2 typ Fn.id - | Exp.Const _ | Closure _ | Sizeof _ -> + | Const _ | Closure _ | Sizeof _ -> acc in of_exp_ exp0 typ0 Fn.id [] and access_expr_of_lhs_exp ~include_array_indexes ~f_resolve_id ~add_deref lhs_exp typ = - match lhs_exp with - | Exp.Lfield _ when not add_deref -> ( + match (lhs_exp : Exp.t) with + | Lfield _ when not add_deref -> ( let res = access_exprs_of_exp ~include_array_indexes ~f_resolve_id ~add_deref:true lhs_exp typ in match res with [lhs_ae] -> AccessExpression.address_of lhs_ae | _ -> None ) - | Exp.Lindex _ when not add_deref -> ( + | Lindex _ when not add_deref -> ( let res = let typ' = match typ.Typ.desc with diff --git a/infer/src/backend/preanal.ml b/infer/src/backend/preanal.ml index f79b3bfd1..99e891a46 100644 --- a/infer/src/backend/preanal.ml +++ b/infer/src/backend/preanal.ml @@ -326,12 +326,12 @@ module Liveness = struct let is_last_instr_in_node instr node = phys_equal (last_instr_in_node node) instr - let exec_instr ((active_defs, to_nullify) as astate) extras node _ instr = + let exec_instr ((active_defs, to_nullify) as astate) extras node _ (instr : Sil.instr) = let astate' = match instr with - | Sil.Load {id= lhs_id} -> + | Load {id= lhs_id} -> (VarDomain.add (Var.of_id lhs_id) active_defs, to_nullify) - | Sil.Call ((id, _), _, actuals, _, {CallFlags.cf_assign_last_arg}) -> + | Call ((id, _), _, actuals, _, {CallFlags.cf_assign_last_arg}) -> let active_defs = VarDomain.add (Var.of_id id) active_defs in let active_defs = if cf_assign_last_arg then @@ -343,15 +343,15 @@ module Liveness = struct else active_defs in (active_defs, to_nullify) - | Sil.Store {e1= Exp.Lvar lhs_pvar} -> + | Store {e1= Exp.Lvar lhs_pvar} -> (VarDomain.add (Var.of_pvar lhs_pvar) active_defs, to_nullify) - | Sil.Metadata (VariableLifetimeBegins (pvar, _, _)) -> + | Metadata (VariableLifetimeBegins (pvar, _, _)) -> (VarDomain.add (Var.of_pvar pvar) active_defs, to_nullify) - | Sil.Store _ + | Store _ | Prune _ | Metadata (Abstract _ | CatchEntry _ | ExitScope _ | Skip | TryEntry _ | TryExit _) -> astate - | Sil.Metadata (Nullify _) -> + | Metadata (Nullify _) -> L.(die InternalError) "Should not add nullify instructions before running nullify analysis!" in diff --git a/infer/src/biabduction/Abs.ml b/infer/src/biabduction/Abs.ml index 6a49e4cd2..e784c0e54 100644 --- a/infer/src/biabduction/Abs.ml +++ b/infer/src/biabduction/Abs.ml @@ -935,7 +935,7 @@ let abstract_gc tenv p = let strong_filter = function | Predicates.Aeq (e1, e2) | Predicates.Aneq (e1, e2) -> check (Exp.free_vars e1) && check (Exp.free_vars e2) - | (Predicates.Apred _ | Anpred _) as a -> + | Predicates.(Apred _ | Anpred _) as a -> check (Predicates.atom_free_vars a) in let new_pi = List.filter ~f:strong_filter pi in diff --git a/infer/src/biabduction/Attribute.ml b/infer/src/biabduction/Attribute.ml index c7b3c1735..d2b669791 100644 --- a/infer/src/biabduction/Attribute.ml +++ b/infer/src/biabduction/Attribute.ml @@ -11,7 +11,7 @@ open! IStd (** Attribute manipulation in Propositions (i.e., Symbolic Heaps) *) (** Check whether an atom is used to mark an attribute *) -let is_pred atom = match atom with Predicates.Apred _ | Anpred _ -> true | _ -> false +let is_pred atom = match atom with Predicates.(Apred _ | Anpred _) -> true | _ -> false (** Add an attribute associated to the argument expressions *) let add tenv ?(footprint = false) ?(polarity = true) prop attr args = @@ -27,13 +27,13 @@ let attributes_in_same_category attr1 attr2 = (** Replace an attribute associated to the expression *) let add_or_replace_check_changed tenv prop atom = - match atom with - | Predicates.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) -> + match (atom : Predicates.atom) with + | Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) -> let pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in let _, nexp = List.hd_exn pairs in (* len exps0 > 0 by match *) let atom_map = function - | (Predicates.Apred (att, exp :: _) | Anpred (att, exp :: _)) + | Predicates.(Apred (att, exp :: _) | Anpred (att, exp :: _)) when Exp.equal nexp exp && attributes_in_same_category att att0 -> atom | atom' -> @@ -64,8 +64,8 @@ let get_all (prop : 'a Prop.t) = let get_for_exp tenv (prop : 'a Prop.t) exp = let nexp = Prop.exp_normalize_prop tenv prop exp in let atom_get_attr attributes atom = - match atom with - | (Predicates.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp -> + match (atom : Predicates.atom) with + | (Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp -> atom :: attributes | _ -> attributes @@ -77,7 +77,7 @@ let get tenv prop exp category = let atts = get_for_exp tenv prop exp in List.find ~f:(function - | Predicates.Apred (att, _) | Anpred (att, _) -> + | Predicates.(Apred (att, _) | Anpred (att, _)) -> PredSymb.equal_category (PredSymb.to_category att) category | _ -> false ) @@ -118,7 +118,7 @@ let remove tenv prop atom = (** Remove an attribute from all the atoms in the heap *) let remove_for_attr tenv prop att0 = let f = function - | Predicates.Apred (att, _) | Anpred (att, _) -> + | Predicates.(Apred (att, _) | Anpred (att, _)) -> not (PredSymb.equal att0 att) | _ -> true @@ -196,7 +196,7 @@ let mark_vars_as_undefined tenv prop ~ret_exp ~undefined_actuals_by_ref callee_p path_pos = let mark_var_as_undefined ~annot exp prop = match exp with - | Exp.Var _ | Lvar _ -> + | Exp.(Var _ | Lvar _) -> let att_undef = PredSymb.Aundef (callee_pname, annot, loc, path_pos) in add_or_replace tenv prop (Apred (att_undef, [exp])) | _ -> diff --git a/infer/src/biabduction/Prover.ml b/infer/src/biabduction/Prover.ml index 74388ae37..d604ca9b8 100644 --- a/infer/src/biabduction/Prover.ml +++ b/infer/src/biabduction/Prover.ml @@ -963,16 +963,17 @@ let check_inconsistency_base tenv prop = in List.exists ~f:do_hpred sigma in - let inconsistent_atom = function - | Predicates.Aeq (e1, e2) -> ( + let inconsistent_atom (atom : Predicates.atom) = + match atom with + | Aeq (e1, e2) -> ( match (e1, e2) with | Exp.Const c1, Exp.Const c2 -> not (Const.equal c1 c2) | _ -> check_disequal tenv prop e1 e2 ) - | Predicates.Aneq (e1, e2) -> ( + | Aneq (e1, e2) -> ( match (e1, e2) with Exp.Const c1, Exp.Const c2 -> Const.equal c1 c2 | _ -> Exp.equal e1 e2 ) - | Predicates.Apred _ | Anpred _ -> + | Apred _ | Anpred _ -> false in let inconsistent_inequalities () = @@ -2390,10 +2391,10 @@ let imply_atom tenv calc_missing (sub1, sub2) prop a = (** Check pure implications before looking at the spatial part. Add necessary instantiations for equalities and check that instantiations are possible for disequalities. *) let rec pre_check_pure_implication tenv calc_missing (subs : subst2) pi1 pi2 = - match pi2 with + match (pi2 : Predicates.atom list) with | [] -> subs - | (Predicates.Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) -> ( + | (Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) -> ( let e2, f2 = (Predicates.exp_sub (snd subs) e2_in, Predicates.exp_sub (snd subs) f2_in) in if Exp.equal e2 f2 then pre_check_pure_implication tenv calc_missing subs pi1 pi2' else @@ -2411,14 +2412,14 @@ let rec pre_check_pure_implication tenv calc_missing (subs : subst2) pi1 pi2 = let prop_for_impl = prepare_prop_for_implication tenv subs pi1' [] in imply_atom tenv calc_missing subs prop_for_impl (Predicates.Aeq (e2_in, f2_in)) ; pre_check_pure_implication tenv calc_missing subs pi1 pi2' ) - | (Predicates.Aneq (e, _) | Apred (_, e :: _) | Anpred (_, e :: _)) :: _ + | (Aneq (e, _) | Apred (_, e :: _) | Anpred (_, e :: _)) :: _ when (not calc_missing) && match e with Var v -> not (Ident.is_primed v) | _ -> true -> raise (IMPL_EXC ( "ineq e2=f2 in rhs with e2 not primed var" , (Predicates.sub_empty, Predicates.sub_empty) , EXC_FALSE )) - | (Predicates.Aeq _ | Aneq _ | Apred _ | Anpred _) :: pi2' -> + | (Aeq _ | Aneq _ | Apred _ | Anpred _) :: pi2' -> pre_check_pure_implication tenv calc_missing subs pi1 pi2' diff --git a/infer/src/bufferoverrun/absLoc.ml b/infer/src/bufferoverrun/absLoc.ml index 650ed5f90..cb5ef85f4 100644 --- a/infer/src/bufferoverrun/absLoc.ml +++ b/infer/src/bufferoverrun/absLoc.ml @@ -252,12 +252,13 @@ module Loc = struct false - let rec is_pretty = function - | BoField.Prim (Var _) -> + let rec is_pretty (field : _ BoField.t) = + match field with + | Prim (Var _) -> true - | BoField.Prim (Allocsite a) -> + | Prim (Allocsite a) -> Allocsite.is_pretty a - | BoField.Field {prefix= loc} | StarField {prefix= loc} -> + | Field {prefix= loc} | StarField {prefix= loc} -> is_pretty loc diff --git a/infer/src/checkers/addressTaken.ml b/infer/src/checkers/addressTaken.ml index 9b333fbe2..405d4b22a 100644 --- a/infer/src/checkers/addressTaken.ml +++ b/infer/src/checkers/addressTaken.ml @@ -19,26 +19,24 @@ module TransferFunctions (CFG : ProcCfg.S) = struct type analysis_data = unit - let rec add_address_taken_pvars exp astate = + let rec add_address_taken_pvars (exp : Exp.t) astate = match exp with - | Exp.Lvar pvar -> + | Lvar pvar -> Domain.add pvar astate - | Exp.Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) -> + | Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) -> add_address_taken_pvars e astate - | Exp.BinOp (_, e1, e2) | Lindex (e1, e2) -> + | BinOp (_, e1, e2) | Lindex (e1, e2) -> add_address_taken_pvars e1 astate |> add_address_taken_pvars e2 - | Exp.Exn _ - | Exp.Closure _ - | Exp.Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) - | Exp.Var _ - | Exp.Sizeof _ -> + | Exn _ | Closure _ | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) | Var _ | Sizeof _ + -> astate - let exec_instr astate () _ _ = function - | Sil.Store {typ= {desc= Tptr _}; e2= rhs_exp} -> + let exec_instr astate () _ _ (instr : Sil.instr) = + match instr with + | Store {typ= {desc= Tptr _}; e2= rhs_exp} -> add_address_taken_pvars rhs_exp astate - | Sil.Call (_, _, actuals, _, _) -> + | Call (_, _, actuals, _, _) -> let add_actual_by_ref astate_acc = function | actual_exp, {Typ.desc= Tptr _} -> add_address_taken_pvars actual_exp astate_acc @@ -46,7 +44,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct astate_acc in List.fold ~f:add_actual_by_ref ~init:astate actuals - | Sil.Store _ | Load _ | Prune _ | Metadata _ -> + | Store _ | Load _ | Prune _ | Metadata _ -> astate diff --git a/infer/src/checkers/functionPointers.ml b/infer/src/checkers/functionPointers.ml index fc7632583..c7a770ee5 100644 --- a/infer/src/checkers/functionPointers.ml +++ b/infer/src/checkers/functionPointers.ml @@ -16,19 +16,20 @@ module TransferFunctions (CFG : ProcCfg.S) = struct type analysis_data = unit - let exec_instr astate () _ _ = function - | Sil.Load {id= lhs_id} when Ident.is_none lhs_id -> + let exec_instr astate () _ _ (instr : Sil.instr) = + match instr with + | Load {id= lhs_id} when Ident.is_none lhs_id -> astate - | Sil.Load {id= lhs_id; e= Exp.Lvar rhs_pvar; typ= Typ.{desc= Tptr ({desc= Tfun}, _)}} -> + | Load {id= lhs_id; e= Exp.Lvar rhs_pvar; typ= Typ.{desc= Tptr ({desc= Tfun}, _)}} -> let fun_ptr = try Domain.find (Pvar.to_string rhs_pvar) astate with Caml.Not_found -> ProcnameSet.empty in Domain.add (Ident.to_string lhs_id) fun_ptr astate - | Sil.Store {e1= Lvar lhs_pvar; e2= Exp.Const (Const.Cfun pn)} -> + | Store {e1= Lvar lhs_pvar; e2= Exp.Const (Const.Cfun pn)} -> (* strong update *) Domain.add (Pvar.to_string lhs_pvar) (ProcnameSet.singleton pn) astate - | Sil.Load _ | Store _ | Call _ | Prune _ | Metadata _ -> + | Load _ | Store _ | Call _ | Prune _ | Metadata _ -> astate diff --git a/infer/src/clang/cGeneral_utils.ml b/infer/src/clang/cGeneral_utils.ml index 150e5837b..d78c9cd67 100644 --- a/infer/src/clang/cGeneral_utils.ml +++ b/infer/src/clang/cGeneral_utils.ml @@ -107,9 +107,10 @@ let is_type_pod qt = | _ -> None ) |> Option.value_map ~default:true ~f:(function - | Clang_ast_t.CXXRecordDecl (_, _, _, _, _, _, _, {xrdi_is_pod}) - | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) - | ClassTemplatePartialSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) -> + | Clang_ast_t.( + ( CXXRecordDecl (_, _, _, _, _, _, _, {xrdi_is_pod}) + | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) + | ClassTemplatePartialSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) )) -> xrdi_is_pod | _ -> true ) diff --git a/infer/src/concurrency/RacerDModels.ml b/infer/src/concurrency/RacerDModels.ml index be6a20985..94851bd99 100644 --- a/infer/src/concurrency/RacerDModels.ml +++ b/infer/src/concurrency/RacerDModels.ml @@ -197,29 +197,29 @@ let is_cpp_container_write = let is_container_write tenv pn = - match pn with - | Procname.CSharp _ when is_csharp_container_write tenv pn [] -> + match (pn : Procname.t) with + | CSharp _ when is_csharp_container_write tenv pn [] -> true - | Procname.Java _ when is_java_container_write tenv pn [] -> + | Java _ when is_java_container_write tenv pn [] -> true - | (Procname.ObjC_Cpp _ | C _) when is_cpp_container_write pn -> + | (ObjC_Cpp _ | C _) when is_cpp_container_write pn -> true | _ -> false let is_container_read tenv pn = - match pn with - | Procname.CSharp _ -> + match (pn : Procname.t) with + | CSharp _ -> is_csharp_container_read tenv pn [] - | Procname.Java _ -> + | Java _ -> is_java_container_read tenv pn [] (* The following order matters: we want to check if pname is a container write before we check if pname is a container read. This is due to a different treatment between std::map::operator[] and all other operator[]. *) - | Procname.ObjC_Cpp _ | C _ -> + | ObjC_Cpp _ | C _ -> (not (is_cpp_container_write pn)) && is_cpp_container_read pn - | _ -> + | Erlang _ | Linters_dummy_method | Block _ | WithBlockParameters _ -> false diff --git a/infer/src/concurrency/starvationDomain.ml b/infer/src/concurrency/starvationDomain.ml index eafe314e5..a4f208620 100644 --- a/infer/src/concurrency/starvationDomain.ml +++ b/infer/src/concurrency/starvationDomain.ml @@ -132,7 +132,7 @@ module Lock = struct the default depending on the language, since most Java locks are recursive and most C++ locks are not. *) match get_typ tenv lock with - | Some {Typ.desc= Tptr ({desc= Tstruct name}, _)} | Some {desc= Tstruct name} -> + | Some {Typ.desc= Tptr ({desc= Tstruct name}, _) | Tstruct name} -> ConcurrencyModels.is_recursive_lock_type name | Some typ -> (* weird type passed as a lock, return default *) diff --git a/infer/src/quandary/ClangTrace.ml b/infer/src/quandary/ClangTrace.ml index 72cfd48bb..ae5661e41 100644 --- a/infer/src/quandary/ClangTrace.ml +++ b/infer/src/quandary/ClangTrace.ml @@ -459,7 +459,7 @@ include TaintTrace.Make (struct (not is_escaped) && match typ with - | Some (Typ.Tint _ | Tfloat _ | Tvoid) -> + | Some Typ.(Tint _ | Tfloat _ | Tvoid) -> false | _ -> (* possible a string/object/struct type; assume injection possible *) diff --git a/infer/src/quandary/TaintAnalysis.ml b/infer/src/quandary/TaintAnalysis.ml index bd7338866..ea4db18ff 100644 --- a/infer/src/quandary/TaintAnalysis.ml +++ b/infer/src/quandary/TaintAnalysis.ml @@ -430,15 +430,13 @@ module Make (TaintSpecification : TaintSpec.S) = struct existing machinery for adding function call sinks *) let add_sinks_for_access_path ({analysis_data= {tenv}} as analysis_data) access_expr loc astate = - let rec add_sinks_for_access astate_acc = function - | HilExp.AccessExpression.Base _ -> + let rec add_sinks_for_access astate_acc (access_expr : HilExp.AccessExpression.t) = + match access_expr with + | Base _ -> astate_acc - | HilExp.AccessExpression.FieldOffset (ae, _) - | ArrayOffset (ae, _, None) - | AddressOf ae - | Dereference ae -> + | FieldOffset (ae, _) | ArrayOffset (ae, _, None) | AddressOf ae | Dereference ae -> add_sinks_for_access astate_acc ae - | HilExp.AccessExpression.ArrayOffset (ae, _, Some index) -> + | ArrayOffset (ae, _, Some index) -> let dummy_call_site = CallSite.make BuiltinDecl.__array_access loc in let dummy_actuals = List.map