diff --git a/.ocamlformat b/.ocamlformat index bf589efda..4609ccff9 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,3 +1,3 @@ -margin 100 -sparse true -version 0.5 +break-cases = nested +margin = 100 +version = 0.7 diff --git a/.ocamlformat.hash b/.ocamlformat.hash index 01ae52910..93746c860 100644 --- a/.ocamlformat.hash +++ b/.ocamlformat.hash @@ -1 +1 @@ -19b52cea4dd5ffff8094aaa671ae019a969863f8 +b3ed72b3997cb7712e54f90d47128d6dd8e18f53 diff --git a/Makefile b/Makefile index 53f42a6ef..fe11d662d 100644 --- a/Makefile +++ b/Makefile @@ -638,7 +638,7 @@ endif # This is a magical version number that doesn't reinstall the world when added on top of what we # have in opam.lock. To upgrade this version number, manually try to install several utop versions # until you find one that doesn't recompile the world. TODO(t20828442): get rid of magic -OPAM_DEV_DEPS = ocamlformat.$$(grep version .ocamlformat | cut -d ' ' -f 2) ocp-indent merlin utop.2.2.0 webbrowser +OPAM_DEV_DEPS = ocamlformat.$$(grep version .ocamlformat | cut -d ' ' -f 3) ocp-indent merlin utop.2.2.0 webbrowser ifneq ($(EMACS),no) OPAM_DEV_DEPS += tuareg diff --git a/infer/src/IR/AccessExpression.ml b/infer/src/IR/AccessExpression.ml index ba1cfd60c..6ad981327 100644 --- a/infer/src/IR/AccessExpression.ml +++ b/infer/src/IR/AccessExpression.ml @@ -75,8 +75,7 @@ let rec get_typ t tenv : Typ.t option = match t with | Base (_, typ) -> Some typ - | FieldOffset (ae, fld) - -> ( + | FieldOffset (ae, fld) -> ( let base_typ_opt = get_typ ae tenv in match base_typ_opt with | Some base_typ -> @@ -88,9 +87,9 @@ let rec get_typ t tenv : Typ.t option = | AddressOf ae -> let base_typ_opt = get_typ ae tenv in Option.map base_typ_opt ~f:(fun base_typ -> Typ.mk (Tptr (base_typ, Pk_pointer))) - | Dereference ae -> + | Dereference ae -> ( let base_typ_opt = get_typ ae tenv in - match base_typ_opt with Some {Typ.desc= Tptr (typ, _)} -> Some typ | _ -> None + match base_typ_opt with Some {Typ.desc= Tptr (typ, _)} -> Some typ | _ -> None ) let rec pp fmt = function @@ -110,7 +109,7 @@ let rec pp fmt = function F.fprintf fmt "*(%a)" pp ae -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let base_of_id id typ = (Var.of_id id, typ) @@ -144,8 +143,8 @@ let rec normalize t = (* Adapted from AccessPath.of_exp. *) -let of_exp ~include_array_indexes ~add_deref exp0 typ0 ~(f_resolve_id: Var.t -> t option) = - let rec of_exp_ exp typ (add_accesses: t -> t) acc : t list = +let of_exp ~include_array_indexes ~add_deref exp0 typ0 ~(f_resolve_id : Var.t -> t option) = + let rec of_exp_ exp typ (add_accesses : t -> t) acc : t list = match exp with | Exp.Var id -> ( match f_resolve_id (Var.of_id id) with @@ -200,14 +199,12 @@ let of_exp ~include_array_indexes ~add_deref exp0 typ0 ~(f_resolve_id: Var.t -> IList.map_changed ~f:normalize ~equal (of_exp_ exp0 typ0 Fn.id []) -let of_lhs_exp ~include_array_indexes ~add_deref lhs_exp typ ~(f_resolve_id: Var.t -> t option) = +let of_lhs_exp ~include_array_indexes ~add_deref lhs_exp typ ~(f_resolve_id : Var.t -> t option) = match lhs_exp with - | Exp.Lfield _ when not add_deref - -> ( + | Exp.Lfield _ when not add_deref -> ( let res = of_exp ~include_array_indexes ~add_deref:true lhs_exp typ ~f_resolve_id in match res with [lhs_ae] -> Some (AddressOf lhs_ae) | _ -> None ) - | Exp.Lindex _ when not add_deref - -> ( + | Exp.Lindex _ when not add_deref -> ( let res = let typ' = match typ.Typ.desc with @@ -220,6 +217,6 @@ let of_lhs_exp ~include_array_indexes ~add_deref lhs_exp typ ~(f_resolve_id: Var of_exp ~include_array_indexes ~add_deref:true lhs_exp typ' ~f_resolve_id in match res with [lhs_ae] -> Some (AddressOf lhs_ae) | _ -> None ) - | _ -> + | _ -> ( let res = of_exp ~include_array_indexes ~add_deref lhs_exp typ ~f_resolve_id in - match res with [lhs_ae] -> Some lhs_ae | _ -> None + match res with [lhs_ae] -> Some lhs_ae | _ -> None ) diff --git a/infer/src/IR/AccessExpression.mli b/infer/src/IR/AccessExpression.mli index 3b75b826f..0266d881c 100644 --- a/infer/src/IR/AccessExpression.mli +++ b/infer/src/IR/AccessExpression.mli @@ -39,8 +39,12 @@ val pp : Format.formatter -> t -> unit val equal : t -> t -> bool val of_lhs_exp : - include_array_indexes:bool -> add_deref:bool -> Exp.t -> Typ.t - -> f_resolve_id:(Var.t -> t option) -> t option + include_array_indexes:bool + -> add_deref:bool + -> Exp.t + -> Typ.t + -> f_resolve_id:(Var.t -> t option) + -> t option (** convert [lhs_exp] to an access expression, resolving identifiers using [f_resolve_id] *) val normalize : t -> t diff --git a/infer/src/IR/AccessPath.ml b/infer/src/IR/AccessPath.ml index 6e793bd09..ab920f204 100644 --- a/infer/src/IR/AccessPath.ml +++ b/infer/src/IR/AccessPath.ml @@ -17,13 +17,13 @@ module Raw = struct consistent, and the variable names should already be enough to distinguish the bases. *) type base = Var.t * typ_ [@@deriving compare] - let equal_base = [%compare.equal : base] + let equal_base = [%compare.equal: base] type access = ArrayAccess of Typ.t * t list | FieldAccess of Typ.Fieldname.t - and t = (base * access list) [@@deriving compare] + and t = base * access list [@@deriving compare] - let equal_access = [%compare.equal : access] + let equal_access = [%compare.equal: access] let equal_access_list l1 l2 = Int.equal (List.compare compare_access l1 l2) 0 @@ -50,7 +50,7 @@ module Raw = struct F.fprintf fmt "%a.%a" pp_base base pp_access_list accesses - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let truncate ((base, accesses) as t) = match List.rev accesses with @@ -96,12 +96,12 @@ module Raw = struct (Some base_typ, None) | [last_access] -> (Some base_typ, Some last_access) - | curr_access :: rest -> + | curr_access :: rest -> ( match get_access_type tenv base_typ curr_access with | Some access_typ -> last_access_info_impl tenv access_typ rest | None -> - (None, None) + (None, None) ) in last_access_info_impl tenv base_typ accesses @@ -134,7 +134,7 @@ module Raw = struct let of_id id typ = (base_of_id id typ, []) - let of_exp ~include_array_indexes exp0 typ0 ~(f_resolve_id: Var.t -> t option) = + let of_exp ~include_array_indexes exp0 typ0 ~(f_resolve_id : Var.t -> t option) = (* [typ] is the type of the last element of the access path (e.g., typeof(g) for x.f.g) *) let rec of_exp_ exp typ accesses acc = match exp with @@ -177,7 +177,7 @@ module Raw = struct of_exp_ exp0 typ0 [] [] - let of_lhs_exp ~include_array_indexes lhs_exp typ ~(f_resolve_id: Var.t -> t option) = + let of_lhs_exp ~include_array_indexes lhs_exp typ ~(f_resolve_id : Var.t -> t option) = match of_exp ~include_array_indexes lhs_exp typ ~f_resolve_id with | [lhs_ap] -> Some lhs_ap @@ -208,7 +208,7 @@ module Abs = struct type t = Abstracted of Raw.t | Exact of Raw.t [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let extract = function Exact ap | Abstracted ap -> ap @@ -296,8 +296,7 @@ let inner_class_normalize p = (base, accesses) ) ) (* this$n.f ... -> this.f . ... *) (* happens in ctrs only *) - | Some ((Var.ProgramVar pvar, typ), all_accesses) - when is_synthetic_this pvar -> + | Some ((Var.ProgramVar pvar, typ), all_accesses) when is_synthetic_this pvar -> let varname = Mangled.from_string "this" in mk_pvar_as varname pvar |> Option.map ~f:(fun new_pvar -> (base_of_pvar new_pvar typ, all_accesses)) diff --git a/infer/src/IR/Annot.ml b/infer/src/IR/Annot.ml index a2908f5e8..580df3c73 100644 --- a/infer/src/IR/Annot.ml +++ b/infer/src/IR/Annot.ml @@ -8,6 +8,7 @@ (** The Smallfoot Intermediate Language: Annotations *) open! IStd + module F = Format type parameters = string list [@@deriving compare] @@ -33,6 +34,7 @@ let pp fmt annotation = module Item = struct (* Don't use nonrec due to https://github.com/janestreet/ppx_compare/issues/2 *) (* type nonrec t = list (t, bool) [@@deriving compare]; *) + (** Annotation for one item: a list of annotations with visibility. *) type t_ = (t * bool) list [@@deriving compare] @@ -67,7 +69,7 @@ module Method = struct (** Annotation for a method: return value and list of parameters. *) type t = Item.t * Item.t list [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] (** Pretty print a method annotation. *) let pp s fmt (ia, ial) = F.fprintf fmt "%a %s(%a)" Item.pp ia s (Pp.seq Item.pp) ial diff --git a/infer/src/IR/Annot.mli b/infer/src/IR/Annot.mli index c4ffc153f..bc9e2928e 100644 --- a/infer/src/IR/Annot.mli +++ b/infer/src/IR/Annot.mli @@ -8,6 +8,7 @@ (** The Smallfoot Intermediate Language: Annotations *) open! IStd + module F = Format type parameters = string list diff --git a/infer/src/IR/Attributes.ml b/infer/src/IR/Attributes.ml index 8e6355880..0a15fc17f 100644 --- a/infer/src/IR/Attributes.ml +++ b/infer/src/IR/Attributes.ml @@ -10,7 +10,7 @@ module F = Format type attributes_kind = ProcUndefined | ProcObjCAccessor | ProcDefined [@@deriving compare] -let equal_attributes_kind = [%compare.equal : attributes_kind] +let equal_attributes_kind = [%compare.equal: attributes_kind] let attributes_kind_to_int64 = [(ProcUndefined, Int64.zero); (ProcObjCAccessor, Int64.one); (ProcDefined, Int64.of_int 2)] @@ -23,10 +23,10 @@ let int64_of_attributes_kind a = let deserialize_attributes_kind = let int64_to_attributes_kind = List.Assoc.inverse attributes_kind_to_int64 in function[@warning "-8"] - | Sqlite3.Data.INT n -> List.Assoc.find_exn ~equal:Int64.equal int64_to_attributes_kind n + | Sqlite3.Data.INT n -> List.Assoc.find_exn ~equal:Int64.equal int64_to_attributes_kind n -let proc_kind_of_attr (proc_attributes: ProcAttributes.t) = +let proc_kind_of_attr (proc_attributes : ProcAttributes.t) = if proc_attributes.is_defined then ProcDefined else if Option.is_some proc_attributes.objc_accessor then ProcObjCAccessor else ProcUndefined @@ -124,7 +124,7 @@ let find ~defined pname_blob = let load pname = Typ.Procname.SQLite.serialize pname |> find ~defined:false -let store (attr: ProcAttributes.t) = +let store (attr : ProcAttributes.t) = let pkind = proc_kind_of_attr attr in let key = Typ.Procname.SQLite.serialize attr.proc_name in if should_try_to_update key pkind then diff --git a/infer/src/IR/Binop.ml b/infer/src/IR/Binop.ml index c90c545ef..96baf3772 100644 --- a/infer/src/IR/Binop.ml +++ b/infer/src/IR/Binop.ml @@ -34,7 +34,7 @@ type t = | LOr (** logical or. Does not always evaluate both operands. *) [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] (** This function returns true if the operation is injective wrt. each argument: op(e,-) and op(-, e) is injective for all e. diff --git a/infer/src/IR/CallSite.ml b/infer/src/IR/CallSite.ml index b4556f521..d509f8193 100644 --- a/infer/src/IR/CallSite.ml +++ b/infer/src/IR/CallSite.ml @@ -10,7 +10,7 @@ module F = Format type t = {pname: Typ.Procname.t; loc: Location.t} [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let pname t = t.pname diff --git a/infer/src/IR/Cfg.ml b/infer/src/IR/Cfg.ml index 7225a491d..950a8f8c3 100644 --- a/infer/src/IR/Cfg.ml +++ b/infer/src/IR/Cfg.ml @@ -20,7 +20,8 @@ let iter_over_sorted_procs cfg ~f = Typ.Procname.compare (Procdesc.get_proc_name pdesc1) (Procdesc.get_proc_name pdesc2) in Typ.Procname.Hash.fold (fun _ pdesc acc -> pdesc :: acc) cfg [] - |> List.sort ~compare:compare_proc_desc_by_proc_name |> List.iter ~f + |> List.sort ~compare:compare_proc_desc_by_proc_name + |> List.iter ~f let get_all_proc_names cfg = @@ -30,7 +31,7 @@ let get_all_proc_names cfg = (** Create a new procdesc *) -let create_proc_desc cfg (proc_attributes: ProcAttributes.t) = +let create_proc_desc cfg (proc_attributes : ProcAttributes.t) = let pdesc = Procdesc.from_proc_attributes proc_attributes in Typ.Procname.Hash.add cfg proc_attributes.proc_name pdesc ; pdesc @@ -38,13 +39,14 @@ let create_proc_desc cfg (proc_attributes: ProcAttributes.t) = (** Iterate over all the nodes in the cfg *) let iter_all_nodes ~sorted cfg ~f = - let do_proc_desc _ (pdesc: Procdesc.t) = + let do_proc_desc _ (pdesc : Procdesc.t) = List.iter ~f:(fun node -> f pdesc node) (Procdesc.get_nodes pdesc) in if not sorted then Typ.Procname.Hash.iter do_proc_desc cfg else iter_over_sorted_procs cfg ~f:(fun pdesc -> - Procdesc.get_nodes pdesc |> List.sort ~compare:Procdesc.Node.compare + Procdesc.get_nodes pdesc + |> List.sort ~compare:Procdesc.Node.compare |> List.iter ~f:(fun node -> f pdesc node) ) @@ -58,7 +60,8 @@ end) let load source = ResultsDatabase.with_registered_statement load_statement ~f:(fun db load_stmt -> - SourceFile.SQLite.serialize source |> Sqlite3.bind load_stmt 1 + SourceFile.SQLite.serialize source + |> Sqlite3.bind load_stmt 1 |> SqliteUtils.check_result_code db ~log:"load bind source file" ; SqliteUtils.result_single_column_option ~finalize:false ~log:"Cfg.load" db load_stmt |> Option.map ~f:SQLite.deserialize ) @@ -98,7 +101,8 @@ let inline_synthetic_method ((ret_id, _) as ret) etl pdesc loc_call : Sil.instr | Sil.Store (Exp.Lfield (_, fn, ft), bt, _, _), [(* setter for fields *) (e1, _); (e2, _)] -> let instr' = Sil.Store (Exp.Lfield (e1, fn, ft), bt, e2, loc_call) in found instr instr' - | Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, _, _), [(e1, _)] when Pvar.is_global pvar -> + | Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, _, _), [(e1, _)] when Pvar.is_global pvar + -> (* setter for static fields *) let instr' = Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, e1, loc_call) in found instr instr' @@ -129,7 +133,7 @@ let proc_inline_synthetic_methods cfg pdesc : unit = let instr_inline_synthetic_method instr = match instr with | Sil.Call (ret_id_typ, Exp.Const (Const.Cfun (Typ.Procname.Java java_pn as pn)), etl, loc, _) - -> ( + -> ( match Typ.Procname.Hash.find cfg pn with | pd -> let is_access = Typ.Procname.Java.is_access_method java_pn in diff --git a/infer/src/IR/ClangMethodKind.ml b/infer/src/IR/ClangMethodKind.ml index d9cb80eab..2759c7499 100644 --- a/infer/src/IR/ClangMethodKind.ml +++ b/infer/src/IR/ClangMethodKind.ml @@ -10,7 +10,7 @@ open! IStd type t = CPP_INSTANCE | OBJC_INSTANCE | CPP_CLASS | OBJC_CLASS | BLOCK | C_FUNCTION [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let to_string = function | CPP_INSTANCE -> diff --git a/infer/src/IR/Const.ml b/infer/src/IR/Const.ml index 7808c3663..b0e85ab23 100644 --- a/infer/src/IR/Const.ml +++ b/infer/src/IR/Const.ml @@ -19,7 +19,7 @@ type t = | Cclass of Ident.name (** class constant *) [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let kind_equal c1 c2 = let const_kind_number = function diff --git a/infer/src/IR/DecompiledExp.ml b/infer/src/IR/DecompiledExp.ml index 0827f26e3..0764fac85 100644 --- a/infer/src/IR/DecompiledExp.ml +++ b/infer/src/IR/DecompiledExp.ml @@ -50,7 +50,7 @@ let rec pp fmt = function match builtin_functions_to_string pn with | Some str -> F.pp_print_string fmt str - | None -> + | None -> ( let procname_str = Typ.Procname.to_simplified_string pn in match pn with | Typ.Procname.ObjC_Cpp {kind= ObjCInstanceMethod} @@ -61,7 +61,7 @@ let rec pp fmt = function | None -> F.pp_print_string fmt procname_str ) | _ -> - F.pp_print_string fmt procname_str ) + F.pp_print_string fmt procname_str ) ) | Dconst c -> (Const.pp Pp.text) fmt c | Dderef de -> @@ -148,7 +148,8 @@ let pp_vpath pe fmt vpath = let rec has_tmp_var = function | Dpvar pvar | Dpvaraddr pvar -> Pvar.is_frontend_tmp pvar - | Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _) -> + | Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _) + -> has_tmp_var dexp | Darray (dexp1, dexp2) | Dbinop (_, dexp1, dexp2) -> has_tmp_var dexp1 || has_tmp_var dexp2 diff --git a/infer/src/IR/Errlog.ml b/infer/src/IR/Errlog.ml index 6a4fa1fed..b8b61e820 100644 --- a/infer/src/IR/Errlog.ml +++ b/infer/src/IR/Errlog.ml @@ -109,7 +109,7 @@ module ErrLogHash = struct let equal key1 key2 = - [%compare.equal : Exceptions.severity * bool * IssueType.t] + [%compare.equal: Exceptions.severity * bool * IssueType.t] (key1.severity, key1.in_footprint, key1.err_name) (key2.severity, key2.in_footprint, key2.err_name) && Localise.error_desc_equal key1.err_desc key2.err_desc @@ -130,20 +130,20 @@ let empty () = ErrLogHash.create 13 type iter_fun = err_key -> err_data -> unit (** Apply f to nodes and error names *) -let iter (f: iter_fun) (err_log: t) = +let iter (f : iter_fun) (err_log : t) = ErrLogHash.iter (fun err_key set -> ErrDataSet.iter (fun err_data -> f err_key err_data) set) err_log -let fold (f: err_key -> err_data -> 'a -> 'a) t acc = +let fold (f : err_key -> err_data -> 'a -> 'a) t acc = ErrLogHash.fold (fun err_key set acc -> ErrDataSet.fold (fun err_data acc -> f err_key err_data acc) set acc) t acc (** Return the number of elements in the error log which satisfy [filter] *) -let size filter (err_log: t) = +let size filter (err_log : t) = let count = ref 0 in ErrLogHash.iter (fun key err_datas -> @@ -154,7 +154,7 @@ let size filter (err_log: t) = (** Print errors from error log *) -let pp_errors fmt (errlog: t) = +let pp_errors fmt (errlog : t) = let f key _ = if Exceptions.equal_severity key.severity Exceptions.Error then F.fprintf fmt "%a@ " IssueType.pp key.err_name @@ -163,7 +163,7 @@ let pp_errors fmt (errlog: t) = (** Print warnings from error log *) -let pp_warnings fmt (errlog: t) = +let pp_warnings fmt (errlog : t) = let f key _ = if Exceptions.equal_severity key.severity Exceptions.Warning then F.fprintf fmt "%a %a@ " IssueType.pp key.err_name Localise.pp_error_desc key.err_desc @@ -172,7 +172,7 @@ let pp_warnings fmt (errlog: t) = (** Print an error log in html format *) -let pp_html source path_to_root fmt (errlog: t) = +let pp_html source path_to_root fmt (errlog : t) = let pp_eds fmt err_datas = let pp_nodeid_session_loc fmt err_data = Io_infer.Html.pp_session_link source path_to_root fmt @@ -198,7 +198,7 @@ let pp_html source path_to_root fmt (errlog: t) = (** Add an error description to the error log unless there is one already at the same node + session; return true if added *) -let add_issue tbl err_key (err_datas: ErrDataSet.t) : bool = +let add_issue tbl err_key (err_datas : ErrDataSet.t) : bool = try let current_eds = ErrLogHash.find tbl err_key in if ErrDataSet.subset err_datas current_eds then false @@ -221,7 +221,7 @@ let log_issue procname ~clang_method_kind severity err_log ~loc ~node ~session ~ let severity = Option.value error.severity ~default:severity in let hide_java_loc_zero = (* hide java errors at location zero unless in -developer_mode *) - not Config.developer_mode && Language.curr_language_is Java && Int.equal loc.Location.line 0 + (not Config.developer_mode) && Language.curr_language_is Java && Int.equal loc.Location.line 0 in let hide_memory_error = match Localise.error_desc_get_bucket error.description with @@ -242,26 +242,26 @@ let log_issue procname ~clang_method_kind severity err_log ~loc ~node ~session ~ || (Config.developer_mode && exn_developer) in ( if exn_developer then - let issue = - let lang = Typ.Procname.get_language procname in - let clang_method_kind = - match lang with - | Language.Clang -> - Option.map ~f:ClangMethodKind.to_string clang_method_kind - | _ -> - None - in - EventLogger.AnalysisIssue - { bug_type= error.name.IssueType.unique_id - ; bug_kind= Exceptions.severity_string severity - ; clang_method_kind - ; exception_triggered_location= error.ocaml_pos - ; lang= Language.to_explicit_string lang - ; procedure_name= Typ.Procname.to_string procname - ; source_location= loc } + let issue = + let lang = Typ.Procname.get_language procname in + let clang_method_kind = + match lang with + | Language.Clang -> + Option.map ~f:ClangMethodKind.to_string clang_method_kind + | _ -> + None in - EventLogger.log issue ) ; - if should_report && not hide_java_loc_zero && not hide_memory_error then + EventLogger.AnalysisIssue + { bug_type= error.name.IssueType.unique_id + ; bug_kind= Exceptions.severity_string severity + ; clang_method_kind + ; exception_triggered_location= error.ocaml_pos + ; lang= Language.to_explicit_string lang + ; procedure_name= Typ.Procname.to_string procname + ; source_location= loc } + in + EventLogger.log issue ) ; + if should_report && (not hide_java_loc_zero) && not hide_memory_error then let added = let node_id, node_key = match node with diff --git a/infer/src/IR/Errlog.mli b/infer/src/IR/Errlog.mli index 11af2329d..270c914a7 100644 --- a/infer/src/IR/Errlog.mli +++ b/infer/src/IR/Errlog.mli @@ -75,7 +75,7 @@ val iter : iter_fun -> t -> unit val fold : (err_key -> err_data -> 'a -> 'a) -> t -> 'a -> 'a -val pp_loc_trace_elem : Format.formatter -> loc_trace_elem -> unit [@@warning "-32"] +val pp_loc_trace_elem : Format.formatter -> loc_trace_elem -> unit [@@warning "-32"] val pp_loc_trace : Format.formatter -> loc_trace -> unit @@ -95,6 +95,17 @@ val update : t -> t -> unit (** Update an old error log with a new one *) val log_issue : - Typ.Procname.t -> clang_method_kind:ClangMethodKind.t option -> Exceptions.severity -> t - -> loc:Location.t -> node:node -> session:int -> ltr:loc_trace -> linters_def_file:string option - -> doc_url:string option -> access:string option -> extras:Jsonbug_t.extra option -> exn -> unit + Typ.Procname.t + -> clang_method_kind:ClangMethodKind.t option + -> Exceptions.severity + -> t + -> loc:Location.t + -> node:node + -> session:int + -> ltr:loc_trace + -> linters_def_file:string option + -> doc_url:string option + -> access:string option + -> extras:Jsonbug_t.extra option + -> exn + -> unit diff --git a/infer/src/IR/Exceptions.ml b/infer/src/IR/Exceptions.ml index d401d7d2f..15e0c8c6e 100644 --- a/infer/src/IR/Exceptions.ml +++ b/infer/src/IR/Exceptions.ml @@ -17,7 +17,7 @@ type visibility = | Exn_system (** never add to error log *) [@@deriving compare] -let equal_visibility = [%compare.equal : visibility] +let equal_visibility = [%compare.equal: visibility] let string_of_visibility vis = match vis with Exn_user -> "user" | Exn_developer -> "developer" | Exn_system -> "system" @@ -26,12 +26,12 @@ let string_of_visibility vis = (** class of error/warning *) type err_class = Checker | Prover | Nocat | Linters [@@deriving compare] -let equal_err_class = [%compare.equal : err_class] +let equal_err_class = [%compare.equal: err_class] (** severity of the report *) type severity = Advice | Error | Info | Like | Warning [@@deriving compare] -let equal_severity = [%compare.equal : severity] +let equal_severity = [%compare.equal: severity] exception Abduction_case_not_implemented of L.ocaml_pos diff --git a/infer/src/IR/Exceptions.mli b/infer/src/IR/Exceptions.mli index eee291597..c26a11a2f 100644 --- a/infer/src/IR/Exceptions.mli +++ b/infer/src/IR/Exceptions.mli @@ -152,8 +152,14 @@ val print_exception_html : string -> exn -> unit (** print a description of the exception to the html output *) val pp_err : - Location.t -> severity -> IssueType.t -> Localise.error_desc -> Logging.ocaml_pos option - -> Format.formatter -> unit -> unit + Location.t + -> severity + -> IssueType.t + -> Localise.error_desc + -> Logging.ocaml_pos option + -> Format.formatter + -> unit + -> unit (** pretty print an error *) type t = diff --git a/infer/src/IR/Exp.ml b/infer/src/IR/Exp.ml index 10949286e..bbdec60b0 100644 --- a/infer/src/IR/Exp.ml +++ b/infer/src/IR/Exp.ml @@ -47,7 +47,7 @@ and t = | Sizeof of sizeof_data [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let hash = Hashtbl.hash @@ -268,18 +268,17 @@ let is_objc_block_closure = function let rec gen_free_vars = let open Sequence.Generator in function - | Var id -> - yield id - | Cast (_, e) | Exn e | Lfield (e, _, _) | Sizeof {dynamic_length= Some e} | UnOp (_, e, _) -> - gen_free_vars e - | Closure {captured_vars} -> - ISequence.gen_sequence_list captured_vars ~f:(fun (e, _, _) -> gen_free_vars e) - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) - | Lvar _ - | Sizeof {dynamic_length= None} -> - return () - | BinOp (_, e1, e2) | Lindex (e1, e2) -> - gen_free_vars e1 >>= fun () -> gen_free_vars e2 + | Var id -> + yield id + | Cast (_, e) | Exn e | Lfield (e, _, _) | Sizeof {dynamic_length= Some e} | UnOp (_, e, _) -> + gen_free_vars e + | Closure {captured_vars} -> + ISequence.gen_sequence_list captured_vars ~f:(fun (e, _, _) -> gen_free_vars e) + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) | Lvar _ | Sizeof {dynamic_length= None} + -> + return () + | BinOp (_, e1, e2) | Lindex (e1, e2) -> + gen_free_vars e1 >>= fun () -> gen_free_vars e2 let free_vars e = Sequence.Generator.run (gen_free_vars e) @@ -289,16 +288,16 @@ let ident_mem e id = free_vars e |> Sequence.exists ~f:(Ident.equal id) let rec gen_program_vars = let open Sequence.Generator in function - | Lvar name -> - yield name - | Const _ | Var _ | Sizeof {dynamic_length= None} -> - return () - | Cast (_, e) | Exn e | Lfield (e, _, _) | Sizeof {dynamic_length= Some e} | UnOp (_, e, _) -> - gen_program_vars e - | BinOp (_, e1, e2) | Lindex (e1, e2) -> - gen_program_vars e1 >>= fun () -> gen_program_vars e2 - | Closure {captured_vars} -> - ISequence.gen_sequence_list captured_vars ~f:(fun (e, _, _) -> gen_program_vars e) + | Lvar name -> + yield name + | Const _ | Var _ | Sizeof {dynamic_length= None} -> + return () + | Cast (_, e) | Exn e | Lfield (e, _, _) | Sizeof {dynamic_length= Some e} | UnOp (_, e, _) -> + gen_program_vars e + | BinOp (_, e1, e2) | Lindex (e1, e2) -> + gen_program_vars e1 >>= fun () -> gen_program_vars e2 + | Closure {captured_vars} -> + ISequence.gen_sequence_list captured_vars ~f:(fun (e, _, _) -> gen_program_vars e) let program_vars e = Sequence.Generator.run (gen_program_vars e) diff --git a/infer/src/IR/Filtering.ml b/infer/src/IR/Filtering.ml index 957de5701..89de17fa0 100644 --- a/infer/src/IR/Filtering.ml +++ b/infer/src/IR/Filtering.ml @@ -32,14 +32,14 @@ let mk_procedure_name_filter ~filter = match filter with | None -> (None, None) - | Some filter_string -> + | Some filter_string -> ( match String.lsplit2 ~on:':' filter_string with | Some (source_file_filter, proc_name_filter) -> (Some (Str.regexp source_file_filter), Some (Str.regexp proc_name_filter)) | None -> (* if only one filter is supplied assume it's for procedure names and the source files are a wildcard *) - (None, Some (Str.regexp filter_string)) + (None, Some (Str.regexp filter_string)) ) in let source_file_filter = filter_of_regexp_opt ~to_string:SourceFile.to_string source_file_regexp diff --git a/infer/src/IR/HilExp.ml b/infer/src/IR/HilExp.ml index 3c1349c74..d78e873d7 100644 --- a/infer/src/IR/HilExp.ml +++ b/infer/src/IR/HilExp.ml @@ -57,11 +57,9 @@ let rec get_typ tenv = function | BinaryOperator ((Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr), _, _) -> Some (Typ.mk (Typ.Tint Typ.IBool)) | BinaryOperator (_, e1, e2) -> ( - match - (* TODO: doing this properly will require taking account of language-specific coercion + (* TODO: doing this properly will require taking account of language-specific coercion semantics. Only return a type when the operands have the same type for now *) - (get_typ tenv e1, get_typ tenv e2) - with + match (get_typ tenv e1, get_typ tenv e2) with | Some typ1, Some typ2 when Typ.equal typ1 typ2 -> Some typ1 | _ -> @@ -112,7 +110,7 @@ let get_access_exprs exp0 = produce the same result as evaluating the SIL expression and replacing the temporary variables using [f_resolve_id] *) let of_sil ~include_array_indexes ~f_resolve_id ~add_deref exp typ = - let rec of_sil_ (exp: Exp.t) typ = + let rec of_sil_ (exp : Exp.t) typ = match exp with | Var id -> let ae = @@ -168,7 +166,8 @@ let of_sil ~include_array_indexes ~f_resolve_id ~add_deref exp typ = (Exp.Lfield ( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0) , fld - , root_exp_typ )) typ ) + , root_exp_typ )) + typ ) | Lindex (Const (Cstr s), index_exp) -> (* indexed string literal (e.g., "foo"[1]). represent this by introducing a dummy variable for the string literal. if you actually need to see the value of the string literal in the @@ -186,15 +185,16 @@ let of_sil ~include_array_indexes ~f_resolve_id ~add_deref exp typ = of_sil_ (Exp.Lindex ( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0) - , index_exp )) typ ) - | Lvar _ -> + , index_exp )) + typ ) + | Lvar _ -> ( match AccessExpression.of_lhs_exp ~include_array_indexes ~add_deref exp typ ~f_resolve_id with | Some access_expr -> AccessExpression access_expr | None -> - L.(die InternalError) "Couldn't convert var expression %a to access path" Exp.pp exp + L.(die InternalError) "Couldn't convert var expression %a to access path" Exp.pp exp ) in of_sil_ exp typ diff --git a/infer/src/IR/HilExp.mli b/infer/src/IR/HilExp.mli index de69a24de..a16f3ec1c 100644 --- a/infer/src/IR/HilExp.mli +++ b/infer/src/IR/HilExp.mli @@ -28,8 +28,12 @@ val get_typ : Tenv.t -> t -> Typ.t option (** Get the type of the expression. Warning: not fully implemented *) val of_sil : - include_array_indexes:bool -> f_resolve_id:(Var.t -> AccessExpression.t option) -> add_deref:bool - -> Exp.t -> Typ.t -> t + include_array_indexes:bool + -> f_resolve_id:(Var.t -> AccessExpression.t option) + -> add_deref:bool + -> Exp.t + -> Typ.t + -> t (** Convert SIL expression to HIL expression *) val get_access_exprs : t -> AccessExpression.t list diff --git a/infer/src/IR/HilInstr.ml b/infer/src/IR/HilInstr.ml index e592eff11..dd30bc4f4 100644 --- a/infer/src/IR/HilInstr.ml +++ b/infer/src/IR/HilInstr.ml @@ -45,11 +45,11 @@ type translation = SSA temporary variable to the access path it represents. Evaluating the HIL instruction should produce the same result as evaluating the SIL instruction and replacing the temporary variables using [f_resolve_id]. *) -let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) = - let exp_of_sil ?(add_deref= false) = +let of_sil ~include_array_indexes ~f_resolve_id (instr : Sil.instr) = + let exp_of_sil ?(add_deref = false) = HilExp.of_sil ~include_array_indexes ~f_resolve_id ~add_deref in - let analyze_id_assignment ?(add_deref= false) lhs_id rhs_exp rhs_typ loc = + let analyze_id_assignment ?(add_deref = false) lhs_id rhs_exp rhs_typ loc = let rhs_hil_exp = exp_of_sil ~add_deref rhs_exp rhs_typ in match rhs_hil_exp with | AccessExpression rhs_access_expr -> @@ -77,23 +77,21 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) = | AccessExpression access_expr -> access_expr | BinaryOperator (_, exp0, exp1) -> ( - match - (* pointer arithmetic. somewhere in one of the expressions, there should be at least + (* pointer arithmetic. somewhere in one of the expressions, there should be at least one pointer type represented as an access path. just use that access path and forget about the arithmetic. if you need to model this more precisely, you should be using SIL instead *) - HilExp.get_access_exprs exp0 - with + match HilExp.get_access_exprs exp0 with | ap :: _ -> ap - | [] -> + | [] -> ( match HilExp.get_access_exprs exp1 with | ap :: _ -> ap | [] -> L.(die InternalError) "Invalid pointer arithmetic expression %a used as LHS at %a" Exp.pp lhs_exp - Location.pp_file_pos loc ) + Location.pp_file_pos loc ) ) | Constant (Const.Cint i) -> (* this can happen in intentionally crashing code like *0xdeadbeef = 0 used for debugging. doesn't really matter what we do here, so just create a dummy var *) diff --git a/infer/src/IR/HilInstr.mli b/infer/src/IR/HilInstr.mli index ca8d03480..124434773 100644 --- a/infer/src/IR/HilInstr.mli +++ b/infer/src/IR/HilInstr.mli @@ -30,7 +30,9 @@ type translation = | Ignore (** no-op *) val of_sil : - include_array_indexes:bool -> f_resolve_id:(Var.t -> AccessExpression.t option) -> Sil.instr + include_array_indexes:bool + -> f_resolve_id:(Var.t -> AccessExpression.t option) + -> Sil.instr -> translation (** convert an SIL instruction into an HIL instruction. The [f_resolve_id] function should map an SSA temporary variable to the access path it represents. Evaluating the HIL instruction should diff --git a/infer/src/IR/Ident.ml b/infer/src/IR/Ident.ml index 67d5e244f..14f0ba358 100644 --- a/infer/src/IR/Ident.ml +++ b/infer/src/IR/Ident.ml @@ -42,7 +42,7 @@ type name = Name.t [@@deriving compare] let name_spec = Name.Spec -let equal_name = [%compare.equal : name] +let equal_name = [%compare.equal: name] type kind = | KNone @@ -59,7 +59,7 @@ let knormal = KNormal let kprimed = KPrimed -let equal_kind = [%compare.equal : kind] +let equal_kind = [%compare.equal: kind] (* timestamp for a path identifier *) let path_ident_stamp = -3 @@ -89,7 +89,7 @@ module Hash = Hashtbl.Make (struct let equal = equal - let hash (id: t) = Hashtbl.hash id + let hash (id : t) = Hashtbl.hash id end) let idlist_to_idset ids = List.fold ~f:(fun set id -> Set.add id set) ~init:Set.empty ids @@ -139,9 +139,7 @@ module NameGenerator = struct let stamp = NameHash.find !name_map name in NameHash.replace !name_map name (stamp + 1) ; stamp + 1 - with Caml.Not_found -> - NameHash.add !name_map name 0 ; - 0 + with Caml.Not_found -> NameHash.add !name_map name 0 ; 0 in {kind; name; stamp} @@ -199,15 +197,15 @@ let get_name id = id.name let has_kind id kind = equal_kind id.kind kind -let is_primed (id: t) = has_kind id KPrimed +let is_primed (id : t) = has_kind id KPrimed -let is_normal (id: t) = has_kind id KNormal || has_kind id KNone +let is_normal (id : t) = has_kind id KNormal || has_kind id KNone -let is_footprint (id: t) = has_kind id KFootprint +let is_footprint (id : t) = has_kind id KFootprint -let is_none (id: t) = has_kind id KNone +let is_none (id : t) = has_kind id KNone -let is_path (id: t) = has_kind id KNormal && Int.equal id.stamp path_ident_stamp +let is_path (id : t) = has_kind id KNormal && Int.equal id.stamp path_ident_stamp (** Update the name generator so that the given id's are not generated again *) let update_name_generator ids = @@ -259,4 +257,4 @@ let hashqueue_of_sequence ?init s = q -let set_of_sequence ?(init= Set.empty) s = Sequence.fold s ~init ~f:(fun ids id -> Set.add id ids) +let set_of_sequence ?(init = Set.empty) s = Sequence.fold s ~init ~f:(fun ids id -> Set.add id ids) diff --git a/infer/src/IR/Instrs.ml b/infer/src/IR/Instrs.ml index d798bc0e9..e1b04390f 100644 --- a/infer/src/IR/Instrs.ml +++ b/infer/src/IR/Instrs.ml @@ -45,8 +45,8 @@ type reversed type not_reversed type 'rev t = - | NotReversed: Sil.instr Array.t -> not_reversed t - | Reversed: Sil.instr RevArray.t -> reversed t + | NotReversed : Sil.instr Array.t -> not_reversed t + | Reversed : Sil.instr RevArray.t -> reversed t type not_reversed_t = not_reversed t @@ -70,7 +70,9 @@ let filter_map (NotReversed instrs) ~f = NotReversed (Array.filter_map instrs ~f let map_changed = let aux_changed arr ~f i = - for i = i to Array.length arr - 1 do Array.unsafe_get arr i |> f |> Array.unsafe_set arr i done ; + for i = i to Array.length arr - 1 do + Array.unsafe_get arr i |> f |> Array.unsafe_set arr i + done ; arr in let rec aux_unchanged ~equal arr ~f i = @@ -93,7 +95,7 @@ let reverse_order (NotReversed instrs) = Reversed (RevArray.of_rev_array instrs) (* Functions on both reversed and non-reversed arrays *) -let is_empty (type r) (t: r t) = +let is_empty (type r) (t : r t) = match t with | NotReversed instrs -> Array.is_empty instrs @@ -101,7 +103,7 @@ let is_empty (type r) (t: r t) = RevArray.is_empty rev_instrs -let fold (type r) (t: r t) ~init ~f = +let fold (type r) (t : r t) ~init ~f = match t with | NotReversed instrs -> Array.fold instrs ~init ~f @@ -115,7 +117,7 @@ let exists t ~f = Container.exists ~iter t ~f let for_all t ~f = Container.for_all ~iter t ~f -let count (type r) (t: r t) = +let count (type r) (t : r t) = match t with | NotReversed instrs -> Array.length instrs @@ -125,7 +127,7 @@ let count (type r) (t: r t) = let nth_exists t index = index < count t -let nth_exn (type r) (t: r t) index = +let nth_exn (type r) (t : r t) index = match t with | NotReversed instrs -> instrs.(index) @@ -133,7 +135,7 @@ let nth_exn (type r) (t: r t) index = RevArray.get rev_instrs index -let last (type r) (t: r t) = +let last (type r) (t : r t) = match t with | NotReversed instrs -> if is_empty t then None else Some (Array.last instrs) diff --git a/infer/src/IR/Instrs.mli b/infer/src/IR/Instrs.mli index 64e1f0aff..80cd12c8f 100644 --- a/infer/src/IR/Instrs.mli +++ b/infer/src/IR/Instrs.mli @@ -28,7 +28,9 @@ val of_rev_list : Sil.instr list -> not_reversed_t val filter_map : not_reversed_t -> f:(Sil.instr -> Sil.instr option) -> not_reversed_t val map_changed : - equal:(Sil.instr -> Sil.instr -> bool) -> not_reversed_t -> f:(Sil.instr -> Sil.instr) + equal:(Sil.instr -> Sil.instr -> bool) + -> not_reversed_t + -> f:(Sil.instr -> Sil.instr) -> not_reversed_t val reverse_order : not_reversed_t -> reversed t diff --git a/infer/src/IR/IntLit.ml b/infer/src/IR/IntLit.ml index c143cbc1d..f9e45d4dd 100644 --- a/infer/src/IR/IntLit.ml +++ b/infer/src/IR/IntLit.ml @@ -38,7 +38,7 @@ let compare (unsigned1, i1, _) (unsigned2, i2, _) = let compare_value (unsigned1, i1, _) (unsigned2, i2, _) = - [%compare : int * Int64.t] (area unsigned1 i1, i1) (area unsigned2 i2, i2) + [%compare: int * Int64.t] (area unsigned1 i1, i1) (area unsigned2 i2, i2) let eq i1 i2 = Int.equal (compare_value i1 i2) 0 @@ -81,9 +81,9 @@ let iszero (_, i, _) = Int64.equal i 0L let isnull (_, i, ptr) = Int64.equal i 0L && ptr -let isminusone (unsigned, i, _) = not unsigned && Int64.equal i (-1L) +let isminusone (unsigned, i, _) = (not unsigned) && Int64.equal i (-1L) -let isnegative (unsigned, i, _) = not unsigned && i < 0L +let isnegative (unsigned, i, _) = (not unsigned) && i < 0L let neg (unsigned, i, ptr) = (unsigned, Int64.neg i, ptr) diff --git a/infer/src/IR/IntLit.mli b/infer/src/IR/IntLit.mli index d186e981d..9125632dd 100644 --- a/infer/src/IR/IntLit.mli +++ b/infer/src/IR/IntLit.mli @@ -35,7 +35,7 @@ val of_int64 : int64 -> t val geq : t -> t -> bool -val gt : t -> t -> bool [@@warning "-32"] +val gt : t -> t -> bool [@@warning "-32"] val isminusone : t -> bool diff --git a/infer/src/IR/Io_infer.ml b/infer/src/IR/Io_infer.ml index 71730274e..342dff345 100644 --- a/infer/src/IR/Io_infer.ml +++ b/infer/src/IR/Io_infer.ml @@ -128,7 +128,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e (** Print end color *) let pp_end_color fmt () = F.pp_print_string fmt "" - let pp_link ?(name= None) ?(pos= None) ~path fmt text = + let pp_link ?(name = None) ?(pos = None) ~path fmt text = let link_str = let escaped_path = List.map ~f:Escape.escape_url path in DB.filename_to_string (DB.Results_dir.path_to_filename DB.Results_dir.Rel escaped_path) @@ -165,7 +165,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e (** Print an html link to the given line number of the current source file *) - let pp_line_link ?(with_name= false) ?(text= None) source path_to_root fmt linenum = + let pp_line_link ?(with_name = false) ?(text = None) source path_to_root fmt linenum = let fname = DB.source_file_encoding source in let linenum_str = string_of_int linenum in let name = "LINE" ^ linenum_str in @@ -178,7 +178,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e (** Print an html link given node id and session *) - let pp_session_link ?(with_name= false) ?proc_name source path_to_root fmt + let pp_session_link ?(with_name = false) ?proc_name source path_to_root fmt (node_id, session, linenum) = let node_name = "node" ^ string_of_int node_id in let text, pos = diff --git a/infer/src/IR/Io_infer.mli b/infer/src/IR/Io_infer.mli index 3abf19435..30b5c7680 100644 --- a/infer/src/IR/Io_infer.mli +++ b/infer/src/IR/Io_infer.mli @@ -28,8 +28,13 @@ module Html : sig (** Open an Html file to append data *) val pp_line_link : - ?with_name:bool -> ?text:string option -> SourceFile.t -> DB.Results_dir.path - -> Format.formatter -> int -> unit + ?with_name:bool + -> ?text:string option + -> SourceFile.t + -> DB.Results_dir.path + -> Format.formatter + -> int + -> unit (** Print an html link to the given line number of the current source file *) val pp_hline : Format.formatter -> unit -> unit @@ -39,8 +44,17 @@ module Html : sig (** Print end color *) val pp_node_link : - DB.Results_dir.path -> Typ.Procname.t -> description:string -> preds:int list -> succs:int list - -> exn:int list -> isvisited:bool -> isproof:bool -> Format.formatter -> int -> unit + DB.Results_dir.path + -> Typ.Procname.t + -> description:string + -> preds:int list + -> succs:int list + -> exn:int list + -> isvisited:bool + -> isproof:bool + -> Format.formatter + -> int + -> unit (** Print an html link to the given node. Usage: [pp_node_link path_to_root ... fmt id]. [path_to_root] is the path to the dir for the procedure in the spec db. @@ -50,8 +64,13 @@ module Html : sig (** Print an html link to the given proc *) val pp_session_link : - ?with_name:bool -> ?proc_name:Typ.Procname.t -> SourceFile.t -> string list -> Format.formatter - -> int * int * int -> unit + ?with_name:bool + -> ?proc_name:Typ.Procname.t + -> SourceFile.t + -> string list + -> Format.formatter + -> int * int * int + -> unit (** Print an html link given node id and session *) val pp_start_color : Format.formatter -> Pp.color -> unit diff --git a/infer/src/IR/Localise.ml b/infer/src/IR/Localise.ml index a44f78e8a..77c4b108f 100644 --- a/infer/src/IR/Localise.ml +++ b/infer/src/IR/Localise.ml @@ -122,7 +122,7 @@ let error_desc_hash desc = Hashtbl.hash (desc_get_comparable desc) (** equality for error_desc *) let error_desc_equal desc1 desc2 = - [%compare.equal : string list] (desc_get_comparable desc1) (desc_get_comparable desc2) + [%compare.equal: string list] (desc_get_comparable desc1) (desc_get_comparable desc2) let line_tag_ tags tag loc = @@ -260,7 +260,8 @@ let deref_str_undef (proc_name, loc) = ; value_post= None ; problem_str= "could be assigned by a call to skip function " ^ proc_name_str - ^ at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed" } + ^ at_line_tag tags Tags.call_line loc + ^ " and is dereferenced or freed" } (** dereference strings for a freed pointer dereference *) @@ -447,12 +448,14 @@ let dereference_string proc_name deref_str value_str access_opt loc = "is annotated with " ^ annotation_name ^ " and is dereferenced without a null check" else "is indirectly marked " ^ annotation_name ^ " (source: " - ^ MF.monospaced_to_string nullable_src ^ ") and is dereferenced without a null check" + ^ MF.monospaced_to_string nullable_src + ^ ") and is dereferenced without a null check" | None, Some weak_var_str -> if String.equal weak_var_str value_str then "is a weak pointer captured in the block and is dereferenced without a null check" else - "is equal to the variable " ^ MF.monospaced_to_string weak_var_str + "is equal to the variable " + ^ MF.monospaced_to_string weak_var_str ^ ", a weak pointer captured in the block, and is dereferenced without a null check" | None, None -> deref_str.problem_str @@ -460,10 +463,10 @@ let dereference_string proc_name deref_str value_str access_opt loc = [problem_str ^ " " ^ at_line tags loc] in let access_desc = access_desc access_opt in - {no_desc with descriptions= value_desc :: access_desc @ problem_desc; tags= !tags} + {no_desc with descriptions= (value_desc :: access_desc) @ problem_desc; tags= !tags} -let parameter_field_not_null_checked_desc (desc: error_desc) exp = +let parameter_field_not_null_checked_desc (desc : error_desc) exp = let parameter_not_nullable_desc var = let var_s = Pvar.to_string var in let param_not_null_desc = @@ -502,7 +505,7 @@ let parameter_field_not_null_checked_desc (desc: error_desc) exp = desc -let has_tag (desc: error_desc) tag = +let has_tag (desc : error_desc) tag = List.exists ~f:(fun (tag', _) -> String.equal tag tag') desc.tags @@ -518,8 +521,10 @@ let desc_allocation_mismatch alloc dealloc = else " by call to " ^ MF.monospaced_to_string (Typ.Procname.to_simplified_string called_pname) in - "using " ^ MF.monospaced_to_string (Typ.Procname.to_simplified_string primitive_pname) - ^ by_call ^ " " ^ at_line (Tags.create ()) (* ignore the tag *) loc + "using " + ^ MF.monospaced_to_string (Typ.Procname.to_simplified_string primitive_pname) + ^ by_call ^ " " + ^ at_line (Tags.create ()) (* ignore the tag *) loc in let description = Format.sprintf "%s %s is deallocated %s" mem_dyn_allocated (using alloc) (using dealloc) @@ -631,7 +636,8 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc | None -> ("", "", "") | Some s -> - Tags.update tags Tags.value s ; (MF.monospaced_to_string s, " to ", " on ") + Tags.update tags Tags.value s ; + (MF.monospaced_to_string s, " to ", " on ") in let typ_str = match hpred_type_opt with @@ -672,7 +678,7 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc match bucket_opt with Some bucket when Config.show_buckets -> bucket | _ -> "" in { no_desc with - descriptions= bucket_str :: xxx_allocated_to @ by_call_to @ is_not_rxxx_after; tags= !tags } + descriptions= (bucket_str :: xxx_allocated_to) @ by_call_to @ is_not_rxxx_after; tags= !tags } let desc_buffer_overrun desc = verbatim_desc desc @@ -724,8 +730,8 @@ let desc_registered_observer_being_deallocated pvar loc = let obj_str = MF.monospaced_to_string (Pvar.to_string pvar) in { no_desc with descriptions= - [ registered_observer_being_deallocated_str obj_str ^ at_line tags loc - ^ ". Being still registered as observer of the notification " + [ registered_observer_being_deallocated_str obj_str + ^ at_line tags loc ^ ". Being still registered as observer of the notification " ^ "center, the deallocated object " ^ obj_str ^ " may be notified in the future." ] ; tags= !tags } diff --git a/infer/src/IR/Localise.mli b/infer/src/IR/Localise.mli index f38325e2a..07ea68d00 100644 --- a/infer/src/IR/Localise.mli +++ b/infer/src/IR/Localise.mli @@ -35,7 +35,7 @@ module BucketLevel : sig val b3 : string - val b4 : string [@@warning "-32"] + val b4 : string [@@warning "-32"] val b5 : string (** lowest likelihood *) @@ -113,7 +113,8 @@ val is_parameter_not_null_checked_desc : error_desc -> bool val is_field_not_null_checked_desc : error_desc -> bool val desc_allocation_mismatch : - Typ.Procname.t * Typ.Procname.t * Location.t -> Typ.Procname.t * Typ.Procname.t * Location.t + Typ.Procname.t * Typ.Procname.t * Location.t + -> Typ.Procname.t * Typ.Procname.t * Location.t -> error_desc val desc_class_cast_exception : @@ -136,8 +137,13 @@ val is_empty_vector_access_desc : error_desc -> bool val desc_frontend_warning : string -> string option -> Location.t -> error_desc val desc_leak : - Exp.t option -> string option -> PredSymb.resource option -> PredSymb.res_action option - -> Location.t -> string option -> error_desc + Exp.t option + -> string option + -> PredSymb.resource option + -> PredSymb.res_action option + -> Location.t + -> string option + -> error_desc val desc_buffer_overrun : string -> error_desc diff --git a/infer/src/IR/Mangled.ml b/infer/src/IR/Mangled.ml index fdc1d7162..397fe3308 100644 --- a/infer/src/IR/Mangled.ml +++ b/infer/src/IR/Mangled.ml @@ -13,19 +13,21 @@ module F = Format type t = {plain: string; mangled: string option} [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] (** Convert a string to a mangled name *) -let from_string (s: string) = {plain= s; mangled= None} +let from_string (s : string) = {plain= s; mangled= None} (** Create a mangled name from a plain and mangled string *) -let mangled (plain: string) (mangled: string) = {plain; mangled= Some (plain ^ "{" ^ mangled ^ "}")} +let mangled (plain : string) (mangled : string) = + {plain; mangled= Some (plain ^ "{" ^ mangled ^ "}")} + (** Convert a mangled name to a string *) -let to_string (pn: t) = pn.plain +let to_string (pn : t) = pn.plain (** Convert a full mangled name to a string *) -let to_string_full (pn: t) = +let to_string_full (pn : t) = match pn.mangled with Some mangled -> pn.plain ^ "{" ^ mangled ^ "}" | None -> pn.plain diff --git a/infer/src/IR/PredSymb.ml b/infer/src/IR/PredSymb.ml index 73e8401a1..791a9343b 100644 --- a/infer/src/IR/PredSymb.ml +++ b/infer/src/IR/PredSymb.ml @@ -20,7 +20,7 @@ let pp_func_attribute fmt = function FA_sentinel (i, j) -> F.fprintf fmt "sentin (** Visibility modifiers. *) type access = Default | Public | Private | Protected [@@deriving compare] -let equal_access = [%compare.equal : access] +let equal_access = [%compare.equal: access] let string_of_access = function | Default -> @@ -55,7 +55,7 @@ type resource = Rmemory of mem_kind | Rfile | Rignore | Rlock [@@deriving compar (** kind of resource action *) type res_act_kind = Racquire | Rrelease [@@deriving compare] -let equal_res_act_kind = [%compare.equal : res_act_kind] +let equal_res_act_kind = [%compare.equal: res_act_kind] (** kind of dangling pointers *) type dangling_kind = @@ -69,7 +69,7 @@ type dangling_kind = (** position in a path: proc name, node id *) type path_pos = Typ.Procname.t * int [@@deriving compare] -let equal_path_pos = [%compare.equal : path_pos] +let equal_path_pos = [%compare.equal: path_pos] (** acquire/release action on a resource *) type res_action = @@ -81,7 +81,7 @@ type res_action = (* ignore other values beside resources: arbitrary merging into one *) let compare_res_action {ra_kind= k1; ra_res= r1} {ra_kind= k2; ra_res= r2} = - [%compare : res_act_kind * resource] (k1, r1) (k2, r2) + [%compare: res_act_kind * resource] (k1, r1) (k2, r2) (* type aliases for components of t values that compare should ignore *) @@ -123,7 +123,7 @@ type t = | Awont_leak (** value do not participate in memory leak analysis *) [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] (** name of the allocation function for the given memory kind *) let mem_alloc_pname = function @@ -162,7 +162,7 @@ type category = | ACwontleak [@@deriving compare] -let equal_category = [%compare.equal : category] +let equal_category = [%compare.equal: category] let to_category att = match att with @@ -221,8 +221,11 @@ let to_string pe = function let str_vpath = if Config.trace_error then F.asprintf "%a" (DecompiledExp.pp_vpath pe) ra.ra_vpath else "" in - name ^ Binop.str pe Lt ^ Typ.Procname.to_string ra.ra_pname ^ ":" - ^ string_of_int ra.ra_loc.Location.line ^ Binop.str pe Gt ^ str_vpath + name ^ Binop.str pe Lt + ^ Typ.Procname.to_string ra.ra_pname + ^ ":" + ^ string_of_int ra.ra_loc.Location.line + ^ Binop.str pe Gt ^ str_vpath | Aautorelease -> "AUTORELEASE" | Adangling dk -> @@ -260,4 +263,4 @@ let to_string pe = function let pp pe fmt a = F.pp_print_string fmt (to_string pe a) (** dump an attribute *) -let d_attribute (a: t) = L.add_print_with_pe pp a +let d_attribute (a : t) = L.add_print_with_pe pp a diff --git a/infer/src/IR/ProcAttributes.ml b/infer/src/IR/ProcAttributes.ml index c9558bb0b..efb52585f 100644 --- a/infer/src/IR/ProcAttributes.ml +++ b/infer/src/IR/ProcAttributes.ml @@ -39,7 +39,7 @@ type var_attribute = Modify_in_block [@@deriving compare] let string_of_var_attribute = function Modify_in_block -> "" -let var_attribute_equal = [%compare.equal : var_attribute] +let var_attribute_equal = [%compare.equal: var_attribute] type var_data = {name: Mangled.t; typ: Typ.t; attributes: var_attribute list} [@@deriving compare] @@ -151,24 +151,24 @@ let pp f SourceFile.pp translation_unit ; if not (PredSymb.equal_access default.access access) then F.fprintf f "; access= %a@," (Pp.to_string ~f:PredSymb.string_of_access) access ; - if not ([%compare.equal : (Mangled.t * Typ.t) list] default.captured captured) then + if not ([%compare.equal: (Mangled.t * Typ.t) list] default.captured captured) then F.fprintf f "; captured= [@[%a@]]@," pp_parameters captured ; pp_bool_default ~default:default.did_preanalysis "did_preanalysis" did_preanalysis f () ; - if not ([%compare.equal : string list] default.exceptions exceptions) then + if not ([%compare.equal: string list] default.exceptions exceptions) then F.fprintf f "; exceptions= [@[%a@]]@," (Pp.semicolon_seq ~print_env:Pp.text_break F.pp_print_string) exceptions ; (* always print formals *) F.fprintf f "; formals= [@[%a@]]@," pp_parameters formals ; - if not ([%compare.equal : int list] default.const_formals const_formals) then + if not ([%compare.equal: int list] default.const_formals const_formals) then F.fprintf f "; const_formals= [@[%a@]]@," (Pp.semicolon_seq ~print_env:Pp.text_break F.pp_print_int) const_formals ; - if not ([%compare.equal : int list] default.by_vals by_vals) then + if not ([%compare.equal: int list] default.by_vals by_vals) then F.fprintf f "; by_vals= [@[%a@]]@," (Pp.semicolon_seq ~print_env:Pp.text_break F.pp_print_int) by_vals ; - if not ([%compare.equal : PredSymb.func_attribute list] default.func_attributes func_attributes) + if not ([%compare.equal: PredSymb.func_attribute list] default.func_attributes func_attributes) then F.fprintf f "; func_attributes= [@[%a@]]@," (Pp.semicolon_seq ~print_env:Pp.text_break PredSymb.pp_func_attribute) @@ -191,7 +191,7 @@ let pp f (Pp.to_string ~f:ClangMethodKind.to_string) clang_method_kind ; if not (Location.equal default.loc loc) then F.fprintf f "; loc= %a@," Location.pp loc ; - if not ([%compare.equal : var_data list] default.locals locals) then + if not ([%compare.equal: var_data list] default.locals locals) then F.fprintf f "; locals= [@[%a@]]@," (Pp.semicolon_seq ~print_env:Pp.text_break pp_var_data) locals ; @@ -199,7 +199,7 @@ let pp f has_added_return_param f () ; if not (Annot.Method.equal default.method_annotation method_annotation) then F.fprintf f "; method_annotation= %a@," (Annot.Method.pp "") method_annotation ; - if not ([%compare.equal : objc_accessor_type option] default.objc_accessor objc_accessor) then + if not ([%compare.equal: objc_accessor_type option] default.objc_accessor objc_accessor) then F.fprintf f "; objc_accessor= %a@," (Pp.option pp_objc_accessor_type) objc_accessor ; if (* HACK: this hardcodes the default instead of comparing to [default.proc_flags], and tests diff --git a/infer/src/IR/Procdesc.ml b/infer/src/IR/Procdesc.ml index c2bce4acf..f542cd95a 100644 --- a/infer/src/IR/Procdesc.ml +++ b/infer/src/IR/Procdesc.ml @@ -32,7 +32,7 @@ end module Node = struct type id = int [@@deriving compare] - let equal_id = [%compare.equal : id] + let equal_id = [%compare.equal: id] type stmt_nodekind = | AssertionFailure @@ -84,7 +84,7 @@ module Node = struct | Skip_node of string [@@deriving compare] - let equal_nodekind = [%compare.equal : nodekind] + let equal_nodekind = [%compare.equal: nodekind] (** a node *) type t = @@ -120,7 +120,7 @@ module Node = struct let hash node = Hashtbl.hash node.id - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] (** Get the unique id of the node *) let get_id node = node.id @@ -160,7 +160,8 @@ module Node = struct let get_siblings node = get_preds node |> ISequence.gen_sequence_list ~f:(fun parent -> - get_succs parent |> Sequence.of_list |> Sequence.filter ~f:(fun n -> not (equal node n)) + get_succs parent |> Sequence.of_list + |> Sequence.filter ~f:(fun n -> not (equal node n)) |> Sequence.Generator.of_sequence ) |> Sequence.Generator.run @@ -182,8 +183,7 @@ module Node = struct let find_in_node_or_preds = let rec find ~f visited nodes = match nodes with - | node :: nodes when not (NodeSet.mem node visited) - -> ( + | node :: nodes when not (NodeSet.mem node visited) -> ( let instrs = get_instrs node in match Instrs.find_map ~f:(f node) instrs with | Some res -> @@ -325,7 +325,7 @@ module Node = struct (** Dump extended instructions for the node *) - let d_instrs ~(sub_instrs: bool) (curr_instr: Sil.instr option) (node: t) = + let d_instrs ~(sub_instrs : bool) (curr_instr : Sil.instr option) (node : t) = L.add_print_with_pe ~color:Pp.Green (pp_instrs ~sub_instrs ~instro:curr_instr) node @@ -374,7 +374,8 @@ module Node = struct in Some instr_key in - get_instrs node |> IContainer.rev_filter_map_to_list ~fold:Instrs.fold ~f:add_instr + get_instrs node + |> IContainer.rev_filter_map_to_list ~fold:Instrs.fold ~f:add_instr |> Utils.better_hash @@ -420,7 +421,7 @@ let compute_distance_to_exit_node pdesc = let exit_node = pdesc.exit_node in let rec mark_distance dist nodes = let next_nodes = ref [] in - let do_node (node: Node.t) = + let do_node (node : Node.t) = match node.dist_exit with | Some _ -> () @@ -530,13 +531,13 @@ let append_locals pdesc new_locals = (pdesc.attributes).locals <- pdesc.attributes.locals @ new_locals -let set_succs_exn_only (node: Node.t) exn = node.exn <- exn +let set_succs_exn_only (node : Node.t) exn = node.exn <- exn (** Set the successor nodes and exception nodes, and build predecessor links *) -let set_succs_exn_base (node: Node.t) succs exn = +let set_succs_exn_base (node : Node.t) succs exn = node.succs <- succs ; node.exn <- exn ; - List.iter ~f:(fun (n: Node.t) -> n.preds <- node :: n.preds) succs + List.iter ~f:(fun (n : Node.t) -> n.preds <- node :: n.preds) succs (** Create a new cfg node *) @@ -563,7 +564,7 @@ let create_node pdesc loc kind instrs = create_node_internal pdesc loc kind (Ins (** Set the successor and exception nodes. If this is a join node right before the exit node, add an extra node in the middle, otherwise nullify and abstract instructions cannot be added after a conditional. *) -let node_set_succs_exn pdesc (node: Node.t) succs exn = +let node_set_succs_exn pdesc (node : Node.t) succs exn = match (node.kind, succs) with | Join_node, [({Node.kind= Exit_node _} as exit_node)] -> let kind = Node.Stmt_node BetweenJoinAndExit in @@ -599,7 +600,7 @@ let get_loop_heads pdesc = lh -let is_loop_head pdesc (node: Node.t) = +let is_loop_head pdesc (node : Node.t) = let lh = match pdesc.loop_heads with Some lh -> lh | None -> get_loop_heads pdesc in NodeSet.mem node lh @@ -611,7 +612,7 @@ let pp_var_attributes fmt attrs = if List.is_empty attrs then () else F.fprintf fmt "(%a)" (Pp.seq ~sep:"," pp_attribute) attrs -let pp_local fmt (var_data: ProcAttributes.var_data) = +let pp_local fmt (var_data : ProcAttributes.var_data) = Format.fprintf fmt " %a:%a%a" Mangled.pp var_data.name (Typ.pp_full Pp.text) var_data.typ pp_var_attributes var_data.attributes @@ -665,7 +666,7 @@ let is_specialized pdesc = let is_captured_var procdesc pvar = let procname = get_proc_name procdesc in let pvar_name = Pvar.get_name pvar in - let pvar_local_matches (var_data: ProcAttributes.var_data) = + let pvar_local_matches (var_data : ProcAttributes.var_data) = Mangled.equal var_data.name pvar_name in let pvar_matches (name, _) = Mangled.equal name pvar_name in @@ -689,7 +690,7 @@ let is_captured_var procdesc pvar = let has_modify_in_block_attr procdesc pvar = let pvar_name = Pvar.get_name pvar in - let pvar_local_matches (var_data: ProcAttributes.var_data) = + let pvar_local_matches (var_data : ProcAttributes.var_data) = Mangled.equal var_data.name pvar_name && List.exists var_data.attributes ~f:(fun attr -> ProcAttributes.var_attribute_equal attr ProcAttributes.Modify_in_block ) @@ -769,7 +770,8 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = in subst_map := Ident.Map.add id specialized_typname !subst_map ; Some (Sil.Load (id, convert_exp origin_exp, mk_ptr_typ specialized_typname, loc)) - | Sil.Load (id, (Exp.Var origin_id as origin_exp), ({Typ.desc= Tstruct _} as origin_typ), loc) -> + | Sil.Load (id, (Exp.Var origin_id as origin_exp), ({Typ.desc= Tstruct _} as origin_typ), loc) + -> let updated_typ : Typ.t = try Typ.mk ~default:origin_typ (Tstruct (Ident.Map.find origin_id !subst_map)) with Caml.Not_found -> origin_typ @@ -822,7 +824,7 @@ exception UnmatchedParameters (name, typ) where name is a parameter. The resulting proc desc is isomorphic but all the type of the parameters are replaced in the instructions according to the list. The virtual calls are also replaced to match the parameter types *) -let specialize_types ?(has_clang_model= false) callee_pdesc resolved_pname args = +let specialize_types ?(has_clang_model = false) callee_pdesc resolved_pname args = let callee_attributes = get_attributes callee_pdesc in let resolved_params, substitutions = try @@ -918,7 +920,7 @@ let specialize_with_block_args_instrs resolved_pdesc substitutions = in let closure = Exp.Closure {name= block_name; captured_vars= id_exp_typs} in let instr = Sil.Store (assignee_exp, origin_typ, closure, loc) in - (remove_temps_instr :: instr :: load_instrs @ instrs, id_map) + ((remove_temps_instr :: instr :: load_instrs) @ instrs, id_map) | Sil.Store (assignee_exp, origin_typ, origin_exp, loc) -> let set_instr = Sil.Store (convert_exp assignee_exp, origin_typ, convert_exp origin_exp, loc) @@ -942,7 +944,7 @@ let specialize_with_block_args_instrs resolved_pdesc substitutions = , loc , call_flags ) in - let instrs = remove_temps_instr :: call_instr :: load_instrs @ instrs in + let instrs = (remove_temps_instr :: call_instr :: load_instrs) @ instrs in (instrs, id_map) with Caml.Not_found -> convert_generic_call return_ids (Exp.Var id) origin_args loc call_flags ) @@ -972,10 +974,10 @@ let specialize_with_block_args callee_pdesc pname_with_block_args block_args = (* Substitution from a block parameter to the block name and the new formals that correspond to the captured variables *) let substitutions : (Typ.Procname.t * (Mangled.t * Typ.t) list) Mangled.Map.t = - List.fold2_exn callee_attributes.formals block_args ~init:Mangled.Map.empty ~f: - (fun subts (param_name, _) block_arg_opt -> + List.fold2_exn callee_attributes.formals block_args ~init:Mangled.Map.empty + ~f:(fun subts (param_name, _) block_arg_opt -> match block_arg_opt with - | Some (cl: Exp.closure) -> + | Some (cl : Exp.closure) -> let formals_from_captured = List.map ~f:(fun (_, var, typ) -> @@ -1044,8 +1046,7 @@ let is_connected proc_desc = in let rec is_consecutive_join_nodes n visited = match Node.get_kind n with - | Node.Join_node - -> ( + | Node.Join_node -> ( if NodeSet.mem n visited then false else let succs = Node.get_succs n in @@ -1064,7 +1065,7 @@ let is_connected proc_desc = | Node.Start_node _ -> if List.is_empty succs || not (List.is_empty preds) then Error `Other else Ok () | Node.Exit_node _ -> - if not (List.is_empty succs) || List.is_empty preds then Error `Other else Ok () + if (not (List.is_empty succs)) || List.is_empty preds then Error `Other else Ok () | Node.Stmt_node _ | Node.Prune_node _ | Node.Skip_node _ -> if List.is_empty succs || List.is_empty preds then Error `Other else Ok () | Node.Join_node -> @@ -1075,7 +1076,7 @@ let is_connected proc_desc = introduce a sequence of join nodes *) if (List.is_empty preds && not (is_consecutive_join_nodes n NodeSet.empty)) - || (not (List.is_empty preds) && List.is_empty succs) + || ((not (List.is_empty preds)) && List.is_empty succs) then Error `Join else Ok () in diff --git a/infer/src/IR/ProcnameDispatcher.ml b/infer/src/IR/ProcnameDispatcher.ml index 9f4db8c3d..98af77d53 100644 --- a/infer/src/IR/ProcnameDispatcher.ml +++ b/infer/src/IR/ProcnameDispatcher.ml @@ -78,23 +78,27 @@ type ( 'f_in , 'markers_out , 'list_constraint ) template_arg = { eat_template_arg: - 'f_in * 'captured_types_in capt * Typ.template_arg list + 'f_in * 'captured_types_in capt * Typ.template_arg list -> ('f_out * 'captured_types_out capt * Typ.template_arg list) option ; add_marker: 'markers_in -> 'markers_out } type ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'list_constraint) templ_matcher = { on_objc_cpp: - 'context -> 'f_in -> objc_cpp + 'context + -> 'f_in + -> objc_cpp -> ('f_out * 'captured_types capt * Typ.template_arg list) option ; on_templated_name: - 'context -> 'f_in -> templated_name + 'context + -> 'f_in + -> templated_name -> ('f_out * 'captured_types capt * Typ.template_arg list) option ; get_markers: 'markers_in -> 'markers_out } type ('context, 'f_in, 'f_out, 'captured_types, 'emptyness) path_extra = | PathEmpty : ('context, 'f, 'f, unit, empty) path_extra - | PathNonEmpty: + | PathNonEmpty : { on_objc_cpp: 'context -> 'f_in -> objc_cpp -> ('f_out * 'captured_types capt) option } -> ('context, 'f_in, 'f_out, 'captured_types, non_empty) path_extra @@ -120,10 +124,10 @@ let empty : ('context, 'f, 'f, unit, 'markers, 'markers, empty) path_matcher = {on_templated_name; path_extra= PathEmpty; get_markers} -let name_cons - : ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) path_matcher - -> string - -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher = +let name_cons : + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) path_matcher + -> string + -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher = fun m name -> let {on_templated_name; get_markers} = m in let fuzzy_name_regexp = @@ -136,7 +140,7 @@ let name_cons | _ -> None in - let on_objc_cpp context f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = + let on_objc_cpp context f (objc_cpp : Typ.Procname.ObjC_Cpp.t) = if String.equal name objc_cpp.method_name then on_templated_name context f (templated_name_of_class_name objc_cpp.class_name) else None @@ -144,10 +148,10 @@ let name_cons {on_objc_cpp; on_qual_name; get_markers} -let name_cons_f - : ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) path_matcher - -> ('context -> string -> bool) - -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher = +let name_cons_f : + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) path_matcher + -> ('context -> string -> bool) + -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher = fun m f_name -> let {on_templated_name; get_markers} = m in let on_qual_name context f qual_name = @@ -157,7 +161,7 @@ let name_cons_f | _ -> None in - let on_objc_cpp context f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = + let on_objc_cpp context f (objc_cpp : Typ.Procname.ObjC_Cpp.t) = if f_name context objc_cpp.method_name then on_templated_name context f (templated_name_of_class_name objc_cpp.class_name) else None @@ -165,32 +169,26 @@ let name_cons_f {on_objc_cpp; on_qual_name; get_markers} -let all_names_cons - : ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, non_empty) path_matcher - -> ( 'context - , 'f_in - , 'f_out - , 'captured_tpes - , 'markers_in - , 'markers_out - , non_empty ) - path_matcher = +let all_names_cons : + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, non_empty) path_matcher + -> ('context, 'f_in, 'f_out, 'captured_tpes, 'markers_in, 'markers_out, non_empty) path_matcher + = fun m -> let {on_templated_name; get_markers; path_extra= PathNonEmpty {on_objc_cpp}} = m in let rec on_templated_name_rec context f templated_name = match on_templated_name context f templated_name with | Some _ as some -> some - | None -> + | None -> ( let qual_name, _template_args = templated_name in match QualifiedCppName.extract_last qual_name with | None -> None | Some (_last, rest) -> - on_templated_name_rec context f (rest, []) + on_templated_name_rec context f (rest, []) ) in let on_templated_name = on_templated_name_rec in - let on_objc_cpp context f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = + let on_objc_cpp context f (objc_cpp : Typ.Procname.ObjC_Cpp.t) = match on_objc_cpp context f objc_cpp with | Some _ as some -> some @@ -200,16 +198,16 @@ let all_names_cons {on_templated_name; get_markers; path_extra= PathNonEmpty {on_objc_cpp}} -let templ_begin - : ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher - -> ( 'context - , 'f_in - , 'f_out - , 'captured_types - , 'markers_in - , 'markers_out - , accept_more ) - templ_matcher = +let templ_begin : + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher + -> ( 'context + , 'f_in + , 'f_out + , 'captured_types + , 'markers_in + , 'markers_out + , accept_more ) + templ_matcher = fun m -> let {on_objc_cpp; on_qual_name; get_markers} = m in let on_templated_name context f (qual_name, template_args) = @@ -219,7 +217,7 @@ let templ_begin | Some (f, captured_types) -> Some (f, captured_types, template_args) in - let on_objc_cpp context f (objc_cpp: Typ.Procname.ObjC_Cpp.t) = + let on_objc_cpp context f (objc_cpp : Typ.Procname.ObjC_Cpp.t) = match on_objc_cpp context f objc_cpp with | None -> None @@ -230,31 +228,25 @@ let templ_begin {on_objc_cpp; on_templated_name; get_markers} -let templ_cons - : ( 'context - , 'f_in - , 'f_interm - , 'captured_types_in - , 'markers_interm - , 'markers_out - , accept_more ) - templ_matcher - -> ( 'f_interm - , 'f_out - , 'captured_types_in - , 'captured_types_out - , 'markers_in - , 'markers_interm - , 'lc ) - template_arg - -> ( 'context - , 'f_in - , 'f_out - , 'captured_types_out - , 'markers_in - , 'markers_out - , 'lc ) - templ_matcher = +let templ_cons : + ( 'context + , 'f_in + , 'f_interm + , 'captured_types_in + , 'markers_interm + , 'markers_out + , accept_more ) + templ_matcher + -> ( 'f_interm + , 'f_out + , 'captured_types_in + , 'captured_types_out + , 'markers_in + , 'markers_interm + , 'lc ) + template_arg + -> ('context, 'f_in, 'f_out, 'captured_types_out, 'markers_in, 'markers_out, 'lc) templ_matcher + = fun m template_arg -> let {on_objc_cpp; on_templated_name; get_markers} = m in let {eat_template_arg; add_marker} = template_arg in @@ -268,16 +260,16 @@ let templ_cons {on_objc_cpp; on_templated_name; get_markers} -let templ_end - : ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher - -> ( 'context - , 'f_in - , 'f_out - , 'captured_types - , 'markers_in - , 'markers_out - , non_empty ) - path_matcher = +let templ_end : + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher + -> ( 'context + , 'f_in + , 'f_out + , 'captured_types + , 'markers_in + , 'markers_out + , non_empty ) + path_matcher = let match_empty_templ_args (f, captured_types, template_args) = match template_args with [] -> Some (f, captured_types) | _ -> None in @@ -306,7 +298,7 @@ module type Common = sig (** Eats a type *) val capt_typ : - 'marker + 'marker -> ( 'marker mtyp -> 'f , 'f , 'captured_types @@ -347,14 +339,14 @@ module type Common = sig (** Starts a path with a matching name that satisfies the given function *) val ( &+ ) : - ( 'context - , 'f_in - , 'f_interm - , 'captured_types_in - , 'markers_interm - , 'markers_out - , accept_more ) - templ_matcher + ( 'context + , 'f_in + , 'f_interm + , 'captured_types_in + , 'markers_interm + , 'markers_out + , accept_more ) + templ_matcher -> ( 'f_interm , 'f_out , 'captured_types_in @@ -367,7 +359,7 @@ module type Common = sig (** Separate template arguments *) val ( < ) : - ('context, 'f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out) name_matcher + ('context, 'f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out) name_matcher -> ( 'f_interm , 'f_out , 'captured_types_in @@ -380,29 +372,33 @@ module type Common = sig (** Starts template arguments after a name *) val ( >:: ) : - ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher - -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher + -> string + -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Ends template arguments and starts a name *) val ( &+...>:: ) : - ( 'context - , 'f_in - , 'f_out - , 'captured_types - , 'markers_in - , 'markers_out - , accept_more ) - templ_matcher -> string + ( 'context + , 'f_in + , 'f_out + , 'captured_types + , 'markers_in + , 'markers_out + , accept_more ) + templ_matcher + -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Ends template arguments with eats-ALL and starts a name *) val ( &:: ) : - ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher + -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Separates names (accepts ALL template arguments on the left one) *) val ( <>:: ) : - ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher + -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Separates names (accepts NO template arguments on the left one) *) end @@ -413,15 +409,15 @@ module Common = struct let add_no_marker capture_markers = capture_markers (** Eats all template args *) - let any_template_args - : ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, end_of_list) template_arg = + let any_template_args : + ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, end_of_list) template_arg = let eat_template_arg (f, captured_types, _) = Some (f, captured_types, []) in {eat_template_arg; add_marker= add_no_marker} (** Eats a type *) - let any_typ - : ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, accept_more) template_arg = + let any_typ : + ('f, 'f, 'captured_types, 'captured_types, 'markers, 'markers, accept_more) template_arg = let eat_template_arg (f, captured_types, template_args) = match template_args with Typ.TType _ :: rest -> Some (f, captured_types, rest) | _ -> None in @@ -429,16 +425,16 @@ module Common = struct (** Captures a type than can be back-referenced *) - let capt_typ - : 'marker - -> ( 'marker mtyp -> 'f - , 'f - , 'captured_types - , 'marker mtyp * 'captured_types - , 'markers - , 'marker * 'markers - , accept_more ) - template_arg = + let capt_typ : + 'marker + -> ( 'marker mtyp -> 'f + , 'f + , 'captured_types + , 'marker mtyp * 'captured_types + , 'markers + , 'marker * 'markers + , accept_more ) + template_arg = fun marker -> let eat_template_arg (f, captured_types, template_args) = match template_args with @@ -453,15 +449,15 @@ module Common = struct (** Captures an int *) - let capt_int - : ( Int64.t -> 'f - , 'f - , 'captured_types - , 'captured_types - , 'markers - , 'markers - , accept_more ) - template_arg = + let capt_int : + ( Int64.t -> 'f + , 'f + , 'captured_types + , 'captured_types + , 'markers + , 'markers + , accept_more ) + template_arg = let eat_template_arg (f, captured_types, template_args) = match template_args with Typ.TInt i :: rest -> Some (f i, captured_types, rest) | _ -> None in @@ -469,15 +465,15 @@ module Common = struct (** Captures all template args *) - let capt_all - : ( Typ.template_arg list -> 'f - , 'f - , 'captured_types - , 'captured_types - , 'markers - , 'markers - , end_of_list ) - template_arg = + let capt_all : + ( Typ.template_arg list -> 'f + , 'f + , 'captured_types + , 'captured_types + , 'markers + , 'markers + , end_of_list ) + template_arg = let eat_template_arg (f, captured_types, template_args) = Some (f template_args, captured_types, []) in @@ -580,8 +576,11 @@ module Call = struct let pre_map_opt opt ~f = match opt with None -> DoesNotMatch | Some x -> Matches (f x) type ('context, 'f_in, 'f_out, 'captured_types) func_args_end = - on_args:('context, 'f_in, 'f_out, 'captured_types) on_args -> 'context -> FuncArg.t list - -> 'f_in * 'captured_types -> ('context, 'f_out) pre_result + on_args:('context, 'f_in, 'f_out, 'captured_types) on_args + -> 'context + -> FuncArg.t list + -> 'f_in * 'captured_types + -> ('context, 'f_out) pre_result type ('context, 'f_in, 'f_out) all_args_matcher = { on_objc_cpp: 'context -> 'f_in -> objc_cpp -> FuncArg.t list -> ('context, 'f_out) pre_result @@ -590,19 +589,19 @@ module Call = struct type ('context, 'f) dispatcher = 'context -> Typ.Procname.t -> FuncArg.t list -> 'f option - let args_begin - : ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, non_empty) path_matcher - -> ('context, 'f_in, 'f_out, 'f_out, 'captured_types, 'markers) args_matcher = + let args_begin : + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, non_empty) path_matcher + -> ('context, 'f_in, 'f_out, 'f_out, 'captured_types, 'markers) args_matcher = let on_args _context _capt f_args = Some f_args in fun m -> let {on_templated_name; path_extra= PathNonEmpty {on_objc_cpp}; get_markers} = m in let markers = get_markers () in let get_captures (f, captured_types) = (f, captured_types ()) in - let on_c context f (c: c) = + let on_c context f (c : c) = let template_args = template_args_of_template_spec_info c.template_args in on_templated_name context f (c.name, template_args) |> Option.map ~f:get_captures in - let on_java context f (java: java) = + let on_java context f (java : java) = on_templated_name context f (templated_name_of_java java) |> Option.map ~f:get_captures in let on_objc_cpp context f objc_cpp = @@ -612,10 +611,10 @@ module Call = struct {on_proc; on_args; markers} - let args_cons - : ('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher - -> ('context, 'f_interm, 'f_out, 'captured_types, 'markers) func_arg - -> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher = + let args_cons : + ('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher + -> ('context, 'f_interm, 'f_out, 'captured_types, 'markers) func_arg + -> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher = fun m func_arg -> let {on_proc; on_args; markers} = m in let {marker_static_checker; eat_func_arg} = func_arg in @@ -626,10 +625,10 @@ module Call = struct {on_proc; on_args; markers} - let args_end - : ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher - -> ('context, 'f_proc_out, 'f_out, 'captured_types) func_args_end - -> ('context, 'f_in, 'f_out) all_args_matcher = + let args_end : + ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher + -> ('context, 'f_proc_out, 'f_out, 'captured_types) func_args_end + -> ('context, 'f_in, 'f_out) all_args_matcher = fun m func_args_end -> let {on_proc= {on_c; on_java; on_objc_cpp}; on_args} = m in let on_c context f c args = @@ -644,10 +643,10 @@ module Call = struct {on_c; on_java; on_objc_cpp} - let make_matcher - : ('context, 'f_in, 'f_out) all_args_matcher -> 'f_in -> ('context, 'f_out) matcher = + let make_matcher : + ('context, 'f_in, 'f_out) all_args_matcher -> 'f_in -> ('context, 'f_out) matcher = fun m f -> - let {on_c; on_java; on_objc_cpp} : (_, _, _) all_args_matcher = m in + let ({on_c; on_java; on_objc_cpp} : (_, _, _) all_args_matcher) = m in let on_objc_cpp context objc_cpp args = match on_objc_cpp context f objc_cpp args with | DoesNotMatch -> @@ -682,14 +681,14 @@ module Call = struct let make_dispatcher : ('context, 'f) matcher list -> ('context, 'f) dispatcher = fun matchers -> let on_objc_cpp context objc_cpp args = - List.find_map matchers ~f:(fun (matcher: _ matcher) -> + List.find_map matchers ~f:(fun (matcher : _ matcher) -> matcher.on_objc_cpp context objc_cpp args ) in let on_c context c args = - List.find_map matchers ~f:(fun (matcher: _ matcher) -> matcher.on_c context c args) + List.find_map matchers ~f:(fun (matcher : _ matcher) -> matcher.on_c context c args) in let on_java context java args = - List.find_map matchers ~f:(fun (matcher: _ matcher) -> matcher.on_java context java args) + List.find_map matchers ~f:(fun (matcher : _ matcher) -> matcher.on_java context java args) in fun context procname args -> match procname with @@ -713,9 +712,11 @@ module Call = struct {match_arg; marker_static_checker= no_marker_checker} - let mk_match_typ_nth - : ('markers -> 'marker) -> ('captured_types -> 'marker mtyp) -> 'marker - -> ('context, 'captured_types, 'markers) one_arg_matcher = + let mk_match_typ_nth : + ('markers -> 'marker) + -> ('captured_types -> 'marker mtyp) + -> 'marker + -> ('context, 'captured_types, 'markers) one_arg_matcher = fun get_m get_c marker -> let marker_static_checker markers = Polymorphic_compare.( = ) marker (get_m markers) in let match_arg _context capt arg = Typ.equal (FuncArg.typ arg) (get_c capt) in @@ -729,25 +730,26 @@ module Call = struct (** Matches second captured type *) - let match_typ2 : 'marker -> ('context, _ * ('marker mtyp * _), _ * ('marker * _)) one_arg_matcher = + let match_typ2 : 'marker -> ('context, _ * ('marker mtyp * _), _ * ('marker * _)) one_arg_matcher + = let pos2 (_, (x, _)) = x in fun marker -> mk_match_typ_nth pos2 pos2 marker (** Matches third captured type *) - let match_typ3 - : 'marker - -> ('context, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) one_arg_matcher = + let match_typ3 : + 'marker -> ('context, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) one_arg_matcher + = let pos3 (_, (_, (x, _))) = x in fun marker -> mk_match_typ_nth pos3 pos3 marker (** Matches the type matched by the given path_matcher *) - let match_typ - : ('context, _, _, unit, unit, unit, non_empty) path_matcher - -> ('context, _, _) one_arg_matcher = + let match_typ : + ('context, _, _, unit, unit, unit, non_empty) path_matcher + -> ('context, _, _) one_arg_matcher = fun m -> - let {on_templated_name} : (_, _, _, unit, unit, unit, non_empty) path_matcher = m in + let ({on_templated_name} : (_, _, _, unit, unit, unit, non_empty) path_matcher) = m in let rec match_typ context typ = match typ with | {Typ.desc= Tstruct name} -> @@ -762,6 +764,7 @@ module Call = struct (* Function argument capture *) + (** Do not capture this argument *) let no_capture : (_, _, 'f, 'f) arg_capture = let get_captured_value _arg = () in @@ -802,10 +805,10 @@ module Call = struct {on_empty; wrapper} - let make_arg - : ('arg_in, 'arg_out, 'f_in, 'f_out) arg_preparer - -> ('context, 'arg_in, 'arg_out, 'f_in, 'f_out, _, _) one_arg - -> ('context, 'f_in, 'f_out, _, _) func_arg = + let make_arg : + ('arg_in, 'arg_out, 'f_in, 'f_out) arg_preparer + -> ('context, 'arg_in, 'arg_out, 'f_in, 'f_out, _, _) one_arg + -> ('context, 'f_in, 'f_out, _, _) func_arg = fun arg_preparer one_arg -> let {on_empty; wrapper} = arg_preparer in let {one_arg_matcher; capture} = one_arg in @@ -856,6 +859,7 @@ module Call = struct (* Function args end *) + (** Matches if there is no function arguments left *) let no_args_left : ('context, _, _, _) func_args_end = let match_empty_args = function Some (f, []) -> Matches f | _ -> DoesNotMatch in @@ -868,10 +872,10 @@ module Call = struct (** If [func_args_end1] does not match, use [func_args_end2] *) - let alternative_args_end - : ('context, 'f_in, 'f_out, 'captured_types) func_args_end - -> ('context, 'f_in, 'f_out, 'captured_types) func_args_end - -> ('context, 'f_in, 'f_out, 'captured_types) func_args_end = + let alternative_args_end : + ('context, 'f_in, 'f_out, 'captured_types) func_args_end + -> ('context, 'f_in, 'f_out, 'captured_types) func_args_end + -> ('context, 'f_in, 'f_out, 'captured_types) func_args_end = fun func_args_end1 func_args_end2 ~on_args context args f_capt -> match func_args_end1 ~on_args context args f_capt with | DoesNotMatch -> @@ -952,19 +956,23 @@ module type NameCommon = sig include Common val ( >--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher + -> 'f_in -> ('context, 'f_out) matcher val ( <>--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher val ( &--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher val ( &::.*--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher (** After a name, accepts ALL template arguments, accepts ALL path tails (names, templates), accepts ALL function arguments, binds the function *) @@ -977,12 +985,13 @@ module NameCommon = struct { on_templated_name: 'context -> templated_name -> 'f option ; on_objc_cpp: 'context -> objc_cpp -> 'f option } - let make_matcher - : ('context, 'f_in, 'f_out, _, _, _, non_empty) path_matcher -> 'f_in - -> ('context, 'f_out) matcher = + let make_matcher : + ('context, 'f_in, 'f_out, _, _, _, non_empty) path_matcher + -> 'f_in + -> ('context, 'f_out) matcher = fun m f -> - let {on_templated_name; path_extra= PathNonEmpty {on_objc_cpp}} - : ('context, 'f_in, 'f_out, _, _, _, non_empty) path_matcher = + let ({on_templated_name; path_extra= PathNonEmpty {on_objc_cpp}} + : ('context, 'f_in, 'f_out, _, _, _, non_empty) path_matcher) = m in let on_templated_name context templated_name = @@ -1011,17 +1020,17 @@ module ProcName = struct let make_dispatcher : ('context, 'f) matcher list -> ('context, 'f) dispatcher = fun matchers -> let on_objc_cpp context objc_cpp = - List.find_map matchers ~f:(fun (matcher: _ matcher) -> matcher.on_objc_cpp context objc_cpp) + List.find_map matchers ~f:(fun (matcher : _ matcher) -> matcher.on_objc_cpp context objc_cpp) in let on_templated_name context templated_name = - List.find_map matchers ~f:(fun (matcher: _ matcher) -> + List.find_map matchers ~f:(fun (matcher : _ matcher) -> matcher.on_templated_name context templated_name ) in - let on_java context (java: Typ.Procname.Java.t) = + let on_java context (java : Typ.Procname.Java.t) = let templated_name = templated_name_of_java java in on_templated_name context templated_name in - let on_c context (c: c) = + let on_c context (c : c) = let template_args = template_args_of_template_spec_info c.template_args in let templated_name = (c.name, template_args) in on_templated_name context templated_name @@ -1046,6 +1055,6 @@ module TypName = struct let make_dispatcher : ('context, 'f) matcher list -> ('context, 'f) dispatcher = fun matchers context typname -> let templated_name = templated_name_of_class_name typname in - List.find_map matchers ~f:(fun (matcher: _ matcher) -> + List.find_map matchers ~f:(fun (matcher : _ matcher) -> matcher.on_templated_name context templated_name ) end diff --git a/infer/src/IR/ProcnameDispatcher.mli b/infer/src/IR/ProcnameDispatcher.mli index d9bd3aab6..7c934311c 100644 --- a/infer/src/IR/ProcnameDispatcher.mli +++ b/infer/src/IR/ProcnameDispatcher.mli @@ -67,7 +67,7 @@ module type Common = sig (** Eats a type *) val capt_typ : - 'marker + 'marker -> ( 'marker mtyp -> 'f , 'f , 'captured_types @@ -108,14 +108,14 @@ module type Common = sig (** Starts a path with a matching name that satisfies the given function *) val ( &+ ) : - ( 'context - , 'f_in - , 'f_interm - , 'captured_types_in - , 'markers_interm - , 'markers_out - , accept_more ) - templ_matcher + ( 'context + , 'f_in + , 'f_interm + , 'captured_types_in + , 'markers_interm + , 'markers_out + , accept_more ) + templ_matcher -> ( 'f_interm , 'f_out , 'captured_types_in @@ -128,7 +128,7 @@ module type Common = sig (** Separate template arguments *) val ( < ) : - ('context, 'f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out) name_matcher + ('context, 'f_in, 'f_interm, 'captured_types_in, 'markers_interm, 'markers_out) name_matcher -> ( 'f_interm , 'f_out , 'captured_types_in @@ -141,29 +141,33 @@ module type Common = sig (** Starts template arguments after a name *) val ( >:: ) : - ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher - -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher + -> string + -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Ends template arguments and starts a name *) val ( &+...>:: ) : - ( 'context - , 'f_in - , 'f_out - , 'captured_types - , 'markers_in - , 'markers_out - , accept_more ) - templ_matcher -> string + ( 'context + , 'f_in + , 'f_out + , 'captured_types + , 'markers_in + , 'markers_out + , accept_more ) + templ_matcher + -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Ends template arguments with eats-ALL and starts a name *) val ( &:: ) : - ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher + -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Separates names (accepts ALL template arguments on the left one) *) val ( <>:: ) : - ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher -> string + ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher + -> string -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out) name_matcher (** Separates names (accepts NO template arguments on the left one) *) end @@ -172,19 +176,23 @@ module type NameCommon = sig include Common val ( >--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher + -> 'f_in -> ('context, 'f_out) matcher val ( <>--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher val ( &--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher val ( &::.*--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher (** After a name, accepts ALL template arguments, accepts ALL path tails (names, templates), accepts ALL function arguments, binds the function *) @@ -192,7 +200,8 @@ end (* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *) -include sig +include + sig [@@@warning "-60"] module ProcName : @@ -207,9 +216,9 @@ module Call : sig type t = Exp.t * Typ.t end - include Common - with type ('context, 'f) dispatcher = - 'context -> Typ.Procname.t -> FuncArg.t list -> 'f option + include + Common + with type ('context, 'f) dispatcher = 'context -> Typ.Procname.t -> FuncArg.t list -> 'f option type ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher @@ -227,12 +236,12 @@ module Call : sig (** Captures one arg expression *) val capt_arg_of_typ : - ('context, unit, _, unit, unit, unit) name_matcher + ('context, unit, _, unit, unit, unit) name_matcher -> ('context, FuncArg.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _) one_arg (** Captures one arg of the given type *) val capt_exp_of_typ : - ('context, unit, _, unit, unit, unit) name_matcher + ('context, unit, _, unit, unit, unit) name_matcher -> ('context, Exp.t, 'wrapped_arg, 'wrapped_arg -> 'f, 'f, _, _) one_arg (** Captures one arg expression of the given type *) @@ -247,88 +256,98 @@ module Call : sig (** Matches second captured type *) val typ3 : - 'marker + 'marker -> ('context, unit, _, 'f, 'f, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) one_arg (** Matches third captured type *) val ( $+ ) : - ('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher + ('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher -> ('context, 'arg, 'arg, 'f_interm, 'f_out, 'captured_types, 'markers) one_arg -> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher (** Separate function arguments *) val ( $+? ) : - ('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher + ('context, 'f_in, 'f_proc_out, 'f_interm, 'captured_types, 'markers) args_matcher -> ('context, 'arg, 'arg option, 'f_interm, 'f_out, 'captured_types, 'markers) one_arg -> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher (** Add an optional argument *) val ( >$ ) : - ('context, 'f_in, 'f_proc_out, 'ct, unit, 'cm, _) templ_matcher + ('context, 'f_in, 'f_proc_out, 'ct, unit, 'cm, _) templ_matcher -> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'ct, 'cm) one_arg -> ('context, 'f_in, 'f_proc_out, 'f_out, 'ct, 'cm) args_matcher (** Ends template arguments and starts function arguments *) val ( $--> ) : - ('context, 'f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in + ('context, 'f_in, _, 'f_out, 'captured_types, 'markers) args_matcher + -> 'f_in -> ('context, 'f_out) matcher (** Ends function arguments, binds the function *) val ( $ ) : - ('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher + ('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher -> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'captured_types, 'markers) one_arg -> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher (** Ends a name with accept-ALL template arguments and starts function arguments *) val ( <>$ ) : - ('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher + ('context, 'f_in, 'f_proc_out, 'captured_types, unit, 'markers) name_matcher -> ('context, 'arg, 'arg, 'f_proc_out, 'f_out, 'captured_types, 'markers) one_arg -> ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher (** Ends a name with accept-NO template arguments and starts function arguments *) val ( >--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher + -> 'f_in -> ('context, 'f_out) matcher (** Ends template arguments, accepts ALL function arguments, binds the function *) val ( $+...$--> ) : - ('context, 'f_in, _, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in + ('context, 'f_in, _, 'f_out, 'captured_types, 'markers) args_matcher + -> 'f_in -> ('context, 'f_out) matcher (** Ends function arguments with eats-ALL and binds the function *) val ( >$$--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers, _) templ_matcher + -> 'f_in -> ('context, 'f_out) matcher (** Ends template arguments, accepts NO function arguments, binds the function *) val ( $$--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher (** After a name, accepts ALL template arguments, accepts NO function arguments, binds the function *) val ( <>$$--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher (** After a name, accepts NO template arguments, accepts NO function arguments, binds the function *) val ( &--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher (** After a name, accepts ALL template arguments, accepts ALL function arguments, binds the function *) val ( <>--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher (** After a name, accepts NO template arguments, accepts ALL function arguments, binds the function *) val ( &::.*--> ) : - ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher -> 'f_in + ('context, 'f_in, 'f_out, 'captured_types, unit, 'markers) name_matcher + -> 'f_in -> ('context, 'f_out) matcher (** After a name, accepts ALL template arguments, accepts ALL path tails (names, templates), accepts ALL function arguments, binds the function *) val ( $!--> ) : - ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher -> 'f_in + ('context, 'f_in, 'f_proc_out, 'f_out, 'captured_types, 'markers) args_matcher + -> 'f_in -> ('context, 'f_out) matcher (** Ends function arguments, accepts NO more function arguments. If the args do not match, raise an internal error. diff --git a/infer/src/IR/Pvar.ml b/infer/src/IR/Pvar.ml index 30902d3dc..8c1e183d4 100644 --- a/infer/src/IR/Pvar.ml +++ b/infer/src/IR/Pvar.ml @@ -51,7 +51,7 @@ let compare_modulo_this x y = else compare_pvar_kind x.pv_kind y.pv_kind -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let get_declaring_function pv = match pv.pv_kind with @@ -97,7 +97,7 @@ let pp pe f pv = (** Dump a program variable. *) -let d (pvar: t) = L.add_print_with_pe pp pvar +let d (pvar : t) = L.add_print_with_pe pp pvar let get_name pv = pv.pv_name @@ -198,10 +198,10 @@ let to_callee pname pvar = assert false -let name_hash (name: Mangled.t) = Hashtbl.hash name +let name_hash (name : Mangled.t) = Hashtbl.hash name (** [mk name proc_name] creates a program var with the given function name *) -let mk (name: Mangled.t) (proc_name: Typ.Procname.t) : t = +let mk (name : Mangled.t) (proc_name : Typ.Procname.t) : t = {pv_hash= name_hash name; pv_name= name; pv_kind= Local_var proc_name} @@ -209,13 +209,13 @@ let get_ret_pvar pname = mk Ident.name_return pname (** [mk_callee name proc_name] creates a program var for a callee function with the given function name *) -let mk_callee (name: Mangled.t) (proc_name: Typ.Procname.t) : t = +let mk_callee (name : Mangled.t) (proc_name : Typ.Procname.t) : t = {pv_hash= name_hash name; pv_name= name; pv_kind= Callee_var proc_name} (** create a global variable with the given name *) -let mk_global ?(is_constexpr= false) ?(is_pod= true) ?(is_static_local= false) - ?(is_static_global= false) ?translation_unit (name: Mangled.t) : t = +let mk_global ?(is_constexpr = false) ?(is_pod = true) ?(is_static_local = false) + ?(is_static_global = false) ?translation_unit (name : Mangled.t) : t = { pv_hash= name_hash name ; pv_name= name ; pv_kind= Global_var (translation_unit, is_constexpr, is_pod, is_static_local, is_static_global) @@ -230,12 +230,12 @@ let mk_tmp name pname = (** create an abduced return variable for a call to [proc_name] at [loc] *) -let mk_abduced_ret (proc_name: Typ.Procname.t) (loc: Location.t) : t = +let mk_abduced_ret (proc_name : Typ.Procname.t) (loc : Location.t) : t = let name = Mangled.from_string ("$RET_" ^ Typ.Procname.to_unique_id proc_name) in {pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_retvar (proc_name, loc)} -let mk_abduced_ref_param (proc_name: Typ.Procname.t) (index: int) (loc: Location.t) : t = +let mk_abduced_ref_param (proc_name : Typ.Procname.t) (index : int) (loc : Location.t) : t = let name = Mangled.from_string ("$REF_PARAM_VAL_" ^ Typ.Procname.to_unique_id proc_name) in {pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_ref_param (proc_name, index, loc)} diff --git a/infer/src/IR/Pvar.mli b/infer/src/IR/Pvar.mli index 3d55ea7d1..6e08c2ed1 100644 --- a/infer/src/IR/Pvar.mli +++ b/infer/src/IR/Pvar.mli @@ -93,8 +93,13 @@ val mk_callee : Mangled.t -> Typ.Procname.t -> t for a callee function with the given function name *) val mk_global : - ?is_constexpr:bool -> ?is_pod:bool -> ?is_static_local:bool -> ?is_static_global:bool - -> ?translation_unit:SourceFile.t -> Mangled.t -> t + ?is_constexpr:bool + -> ?is_pod:bool + -> ?is_static_local:bool + -> ?is_static_global:bool + -> ?translation_unit:SourceFile.t + -> Mangled.t + -> t (** create a global variable with the given name *) val mk_tmp : string -> Typ.Procname.t -> t diff --git a/infer/src/IR/QualifiedCppName.ml b/infer/src/IR/QualifiedCppName.ml index 37a3cbb4d..39ce10d16 100644 --- a/infer/src/IR/QualifiedCppName.ml +++ b/infer/src/IR/QualifiedCppName.ml @@ -75,7 +75,7 @@ module Match = struct let matching_separator = "#" - let regexp_string_of_qualifiers ?(prefix= false) quals = + let regexp_string_of_qualifiers ?(prefix = false) quals = Str.quote (to_separated_string ~sep:matching_separator quals) ^ if prefix then "" else "$" @@ -94,7 +94,7 @@ module Match = struct let colon_splits = String.split qual_name ~on:':' in List.iter colon_splits ~f:(fun s -> (* Filter out the '<' in operator< and operator<= *) - if not (String.is_prefix s ~prefix:"operator<") && String.contains s '<' then + if (not (String.is_prefix s ~prefix:"operator<")) && String.contains s '<' then raise (ParseError ("Unexpected template in fuzzy qualified name %s." ^ qual_name)) ) ; of_qual_string qual_name diff --git a/infer/src/IR/Sil.ml b/infer/src/IR/Sil.ml index bc1d1a161..c4f7dd101 100644 --- a/infer/src/IR/Sil.ml +++ b/infer/src/IR/Sil.ml @@ -52,7 +52,7 @@ type instr = | Remove_temps of Ident.t list * Location.t (** remove temporaries *) [@@deriving compare] -let equal_instr = [%compare.equal : instr] +let equal_instr = [%compare.equal: instr] let skip_instr = Remove_temps ([], Location.dummy) @@ -77,7 +77,7 @@ type atom = | Anpred of PredSymb.t * Exp.t list (** negated predicate symbol applied to exps *) [@@deriving compare] -let equal_atom = [%compare.equal : atom] +let equal_atom = [%compare.equal: atom] let atom_has_local_addr a = match a with @@ -93,7 +93,7 @@ type lseg_kind = | Lseg_PE (** possibly empty (possibly circular) listseg *) [@@deriving compare] -let equal_lseg_kind = [%compare.equal : lseg_kind] +let equal_lseg_kind = [%compare.equal: lseg_kind] (** The boolean is true when the pointer was dereferenced without testing for zero. *) type zero_flag = bool option [@@deriving compare] @@ -117,7 +117,7 @@ type inst = | Ireturn_from_call of int [@@deriving compare] -let equal_inst = [%compare.equal : inst] +let equal_inst = [%compare.equal: inst] (** structured expressions represent a value of structured type, such as an array or a struct. *) type 'inst strexp0 = @@ -135,11 +135,11 @@ type 'inst strexp0 = type strexp = inst strexp0 -let compare_strexp ?(inst= false) se1 se2 = +let compare_strexp ?(inst = false) se1 se2 = compare_strexp0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) se1 se2 -let equal_strexp ?(inst= false) se1 se2 = Int.equal (compare_strexp ~inst se1 se2) 0 +let equal_strexp ?(inst = false) se1 se2 = Int.equal (compare_strexp ~inst se1 se2) 0 (** an atomic heap predicate *) type 'inst hpred0 = @@ -180,23 +180,23 @@ and 'inst hpara_dll0 = type hpred = inst hpred0 (** Comparison between heap predicates. Reverse natural order, and order first by anchor exp. *) -let compare_hpred ?(inst= false) hpred1 hpred2 = +let compare_hpred ?(inst = false) hpred1 hpred2 = compare_hpred0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) hpred1 hpred2 -let equal_hpred ?(inst= false) hpred1 hpred2 = Int.equal (compare_hpred ~inst hpred1 hpred2) 0 +let equal_hpred ?(inst = false) hpred1 hpred2 = Int.equal (compare_hpred ~inst hpred1 hpred2) 0 type hpara = inst hpara0 let compare_hpara = compare_hpara0 (fun _ _ -> 0) -let equal_hpara = [%compare.equal : hpara] +let equal_hpara = [%compare.equal: hpara] type hpara_dll = inst hpara_dll0 let compare_hpara_dll = compare_hpara_dll0 (fun _ _ -> 0) -let equal_hpara_dll = [%compare.equal : hpara_dll] +let equal_hpara_dll = [%compare.equal: hpara_dll] (** {2 Comparision and Inspection Functions} *) let is_objc_object = function @@ -273,13 +273,13 @@ let pp_exp_printenv pe0 f e0 = (** dump an expression. *) -let d_exp (e: Exp.t) = L.add_print_with_pe pp_exp_printenv e +let d_exp (e : Exp.t) = L.add_print_with_pe pp_exp_printenv e (** Pretty print a list of expressions. *) let pp_exp_list pe f expl = Pp.seq (pp_exp_printenv pe) f expl (** dump a list of expressions. *) -let d_exp_list (el: Exp.t list) = L.add_print_with_pe pp_exp_list el +let d_exp_list (el : Exp.t list) = L.add_print_with_pe pp_exp_list el let pp_texp pe f = function | Exp.Sizeof {typ; nbytes; dynamic_length; subtype} -> @@ -303,7 +303,7 @@ let pp_texp_full pe f = function (** Dump a type expression with all the details. *) -let d_texp_full (te: Exp.t) = L.add_print_with_pe pp_texp_full te +let d_texp_full (te : Exp.t) = L.add_print_with_pe pp_texp_full te (** Pretty print an offset *) let pp_offset pe f = function @@ -327,7 +327,7 @@ let rec pp_offset_list pe f = function (** Dump a list of offsets *) -let d_offset_list (offl: offset list) = L.add_print_with_pe pp_offset_list offl +let d_offset_list (offl : offset list) = L.add_print_with_pe pp_offset_list offl let pp_exp_typ pe f (e, t) = F.fprintf f "%a:%a" (pp_exp_printenv pe) e (Typ.pp pe) t @@ -423,7 +423,7 @@ let add_with_block_parameters_flag instr = let is_block_pvar pvar = Typ.has_block_prefix (Mangled.to_string (Pvar.get_name pvar)) (** Dump an instruction. *) -let d_instr (i: instr) = L.add_print_with_pe ~color:Pp.Green pp_instr i +let d_instr (i : instr) = L.add_print_with_pe ~color:Pp.Green pp_instr i let pp_atom pe0 f a = let pe, changed = color_pre_wrapper pe0 f a in @@ -442,7 +442,7 @@ let pp_atom pe0 f a = (** dump an atom *) -let d_atom (a: atom) = L.add_print_with_pe pp_atom a +let d_atom (a : atom) = L.add_print_with_pe pp_atom a let pp_lseg_kind f = function Lseg_NE -> F.pp_print_string f "ne" | Lseg_PE -> () @@ -566,21 +566,21 @@ end = struct This can in turn extend the todo list for the nested predicates, which are then visited as well. Can be applied only once, as it destroys the todo list *) - let iter (env: env) f f_dll = + let iter (env : env) f f_dll = while env.todo <> [] || env.todo_dll <> [] do match env.todo with | hpara :: todo' -> env.todo <- todo' ; let n, emitted = HparaHash.find env.hash hpara in if not emitted then f n hpara - | [] -> + | [] -> ( match env.todo_dll with | hpara_dll :: todo_dll' -> env.todo_dll <- todo_dll' ; let n, emitted = HparaDllHash.find env.hash_dll hpara_dll in if not emitted then f_dll n hpara_dll | [] -> - () + () ) done end @@ -874,57 +874,57 @@ let pp_hpara_dll pe f = pp_hpara_dll_env pe None f let pp_hpred pe f = pp_hpred_env pe None f (** dump a strexp. *) -let d_sexp (se: strexp) = L.add_print_with_pe pp_sexp se +let d_sexp (se : strexp) = L.add_print_with_pe pp_sexp se (** dump a hpred. *) -let d_hpred (hpred: hpred) = L.add_print_with_pe pp_hpred hpred +let d_hpred (hpred : hpred) = L.add_print_with_pe pp_hpred hpred (** {2 Functions for traversing SIL data types} *) -let rec strexp_expmap (f: Exp.t * inst option -> Exp.t * inst option) = +let rec strexp_expmap (f : Exp.t * inst option -> Exp.t * inst option) = let fe e = fst (f (e, None)) in let fei (e, inst) = match f (e, Some inst) with e', None -> (e', inst) | e', Some inst' -> (e', inst') in function - | Eexp (e, inst) -> - let e', inst' = fei (e, inst) in - Eexp (e', inst') - | Estruct (fld_se_list, inst) -> - let f_fld_se (fld, se) = (fld, strexp_expmap f se) in - Estruct (List.map ~f:f_fld_se fld_se_list, inst) - | Earray (len, idx_se_list, inst) -> - let len' = fe len in - let f_idx_se (idx, se) = - let idx' = fe idx in - (idx', strexp_expmap f se) - in - Earray (len', List.map ~f:f_idx_se idx_se_list, inst) - - -let hpred_expmap (f: Exp.t * inst option -> Exp.t * inst option) = + | Eexp (e, inst) -> + let e', inst' = fei (e, inst) in + Eexp (e', inst') + | Estruct (fld_se_list, inst) -> + let f_fld_se (fld, se) = (fld, strexp_expmap f se) in + Estruct (List.map ~f:f_fld_se fld_se_list, inst) + | Earray (len, idx_se_list, inst) -> + let len' = fe len in + let f_idx_se (idx, se) = + let idx' = fe idx in + (idx', strexp_expmap f se) + in + Earray (len', List.map ~f:f_idx_se idx_se_list, inst) + + +let hpred_expmap (f : Exp.t * inst option -> Exp.t * inst option) = let fe e = fst (f (e, None)) in function - | Hpointsto (e, se, te) -> - let e' = fe e in - let se' = strexp_expmap f se in - let te' = fe te in - Hpointsto (e', se', te') - | Hlseg (k, hpara, root, next, shared) -> - let root' = fe root in - let next' = fe next in - let shared' = List.map ~f:fe shared in - Hlseg (k, hpara, root', next', shared') - | Hdllseg (k, hpara, iF, oB, oF, iB, shared) -> - let iF' = fe iF in - let oB' = fe oB in - let oF' = fe oF in - let iB' = fe iB in - let shared' = List.map ~f:fe shared in - Hdllseg (k, hpara, iF', oB', oF', iB', shared') - - -let rec strexp_instmap (f: inst -> inst) strexp = + | Hpointsto (e, se, te) -> + let e' = fe e in + let se' = strexp_expmap f se in + let te' = fe te in + Hpointsto (e', se', te') + | Hlseg (k, hpara, root, next, shared) -> + let root' = fe root in + let next' = fe next in + let shared' = List.map ~f:fe shared in + Hlseg (k, hpara, root', next', shared') + | Hdllseg (k, hpara, iF, oB, oF, iB, shared) -> + let iF' = fe iF in + let oB' = fe oB in + let oF' = fe oF in + let iB' = fe iB in + let shared' = List.map ~f:fe shared in + Hdllseg (k, hpara, iF', oB', oF', iB', shared') + + +let rec strexp_instmap (f : inst -> inst) strexp = match strexp with | Eexp (e, inst) -> Eexp (e, f inst) @@ -936,15 +936,15 @@ let rec strexp_instmap (f: inst -> inst) strexp = Earray (len, List.map ~f:f_idx_se idx_se_list, f inst) -let rec hpara_instmap (f: inst -> inst) hpara = +let rec hpara_instmap (f : inst -> inst) hpara = {hpara with body= List.map ~f:(hpred_instmap f) hpara.body} -and hpara_dll_instmap (f: inst -> inst) hpara_dll = +and hpara_dll_instmap (f : inst -> inst) hpara_dll = {hpara_dll with body_dll= List.map ~f:(hpred_instmap f) hpara_dll.body_dll} -and hpred_instmap (fn: inst -> inst) (hpred: hpred) : hpred = +and hpred_instmap (fn : inst -> inst) (hpred : hpred) : hpred = match hpred with | Hpointsto (e, se, te) -> let se' = strexp_instmap fn se in @@ -955,11 +955,11 @@ and hpred_instmap (fn: inst -> inst) (hpred: hpred) : hpred = Hdllseg (k, hpara_dll_instmap fn hpar_dll, e, f, g, h, el) -let hpred_list_expmap (f: Exp.t * inst option -> Exp.t * inst option) (hlist: hpred list) = +let hpred_list_expmap (f : Exp.t * inst option -> Exp.t * inst option) (hlist : hpred list) = List.map ~f:(hpred_expmap f) hlist -let atom_expmap (f: Exp.t -> Exp.t) = function +let atom_expmap (f : Exp.t -> Exp.t) = function | Aeq (e1, e2) -> Aeq (f e1, f e2) | Aneq (e1, e2) -> @@ -981,7 +981,7 @@ let hpred_get_lexp acc = function e1 :: e2 :: acc -let hpred_list_get_lexps (filter: Exp.t -> bool) (hlist: hpred list) : Exp.t list = +let hpred_list_get_lexps (filter : Exp.t -> bool) (hlist : hpred list) : Exp.t list = let lexps = List.fold ~f:hpred_get_lexp ~init:[] hlist in List.filter ~f:filter lexps @@ -993,10 +993,10 @@ let hpred_entries hpred = hpred_get_lexp [] hpred let atom_gen_free_vars = let open Sequence.Generator in function - | Aeq (e1, e2) | Aneq (e1, e2) -> - Exp.gen_free_vars e1 >>= fun () -> Exp.gen_free_vars e2 - | Apred (_, es) | Anpred (_, es) -> - ISequence.gen_sequence_list es ~f:Exp.gen_free_vars + | Aeq (e1, e2) | Aneq (e1, e2) -> + Exp.gen_free_vars e1 >>= fun () -> Exp.gen_free_vars e2 + | Apred (_, es) | Anpred (_, es) -> + ISequence.gen_sequence_list es ~f:Exp.gen_free_vars let atom_free_vars a = Sequence.Generator.run (atom_gen_free_vars a) @@ -1004,35 +1004,35 @@ let atom_free_vars a = Sequence.Generator.run (atom_gen_free_vars a) let rec strexp_gen_free_vars = let open Sequence.Generator in function - | Eexp (e, _) -> - Exp.gen_free_vars e - | Estruct (fld_se_list, _) -> - ISequence.gen_sequence_list fld_se_list ~f:(fun (_, se) -> strexp_gen_free_vars se) - | Earray (len, idx_se_list, _) -> - Exp.gen_free_vars len - >>= fun () -> - ISequence.gen_sequence_list idx_se_list ~f:(fun (e, se) -> - Exp.gen_free_vars e >>= fun () -> strexp_gen_free_vars se ) + | Eexp (e, _) -> + Exp.gen_free_vars e + | Estruct (fld_se_list, _) -> + ISequence.gen_sequence_list fld_se_list ~f:(fun (_, se) -> strexp_gen_free_vars se) + | Earray (len, idx_se_list, _) -> + Exp.gen_free_vars len + >>= fun () -> + ISequence.gen_sequence_list idx_se_list ~f:(fun (e, se) -> + Exp.gen_free_vars e >>= fun () -> strexp_gen_free_vars se ) let hpred_gen_free_vars = let open Sequence.Generator in function - | Hpointsto (base, sexp, te) -> - Exp.gen_free_vars base - >>= fun () -> strexp_gen_free_vars sexp >>= fun () -> Exp.gen_free_vars te - | Hlseg (_, _, e1, e2, elist) -> - Exp.gen_free_vars e1 - >>= fun () -> - Exp.gen_free_vars e2 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars - | Hdllseg (_, _, e1, e2, e3, e4, elist) -> - Exp.gen_free_vars e1 - >>= fun () -> - Exp.gen_free_vars e2 - >>= fun () -> - Exp.gen_free_vars e3 - >>= fun () -> - Exp.gen_free_vars e4 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars + | Hpointsto (base, sexp, te) -> + Exp.gen_free_vars base + >>= fun () -> strexp_gen_free_vars sexp >>= fun () -> Exp.gen_free_vars te + | Hlseg (_, _, e1, e2, elist) -> + Exp.gen_free_vars e1 + >>= fun () -> + Exp.gen_free_vars e2 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars + | Hdllseg (_, _, e1, e2, e3, e4, elist) -> + Exp.gen_free_vars e1 + >>= fun () -> + Exp.gen_free_vars e2 + >>= fun () -> + Exp.gen_free_vars e3 + >>= fun () -> + Exp.gen_free_vars e4 >>= fun () -> ISequence.gen_sequence_list elist ~f:Exp.gen_free_vars let hpred_free_vars h = Sequence.Generator.run (hpred_gen_free_vars h) @@ -1102,7 +1102,7 @@ type subst = [`Exp of exp_subst | `Typ of Typ.type_subst_t] [@@deriving compare] type subst_fun = [`Exp of Ident.t -> Exp.t | `Typ of (Typ.t -> Typ.t) * (Typ.Name.t -> Typ.Name.t)] -let equal_exp_subst = [%compare.equal : exp_subst] +let equal_exp_subst = [%compare.equal: exp_subst] let sub_no_duplicated_ids sub = not (List.contains_dup ~compare:compare_ident_exp_ids sub) @@ -1168,11 +1168,11 @@ let sub_symmetric_difference sub1_in sub2_in = (** [sub_find filter sub] returns the expression associated to the first identifier that satisfies [filter]. Raise [Not_found] if there isn't one. *) -let sub_find filter (sub: exp_subst) = snd (List.find_exn ~f:(fun (i, _) -> filter i) sub) +let sub_find filter (sub : exp_subst) = snd (List.find_exn ~f:(fun (i, _) -> filter i) sub) (** [sub_filter filter sub] restricts the domain of [sub] to the identifiers satisfying [filter]. *) -let sub_filter filter (sub: exp_subst) = List.filter ~f:(fun (i, _) -> filter i) sub +let sub_filter filter (sub : exp_subst) = List.filter ~f:(fun (i, _) -> filter i) sub (** [sub_filter_pair filter sub] restricts the domain of [sub] to the identifiers satisfying [filter(id, sub(id))]. *) @@ -1180,11 +1180,13 @@ let sub_filter_pair = List.filter (** [sub_range_partition filter sub] partitions [sub] according to whether range expressions satisfy [filter]. *) -let sub_range_partition filter (sub: exp_subst) = List.partition_tf ~f:(fun (_, e) -> filter e) sub +let sub_range_partition filter (sub : exp_subst) = + List.partition_tf ~f:(fun (_, e) -> filter e) sub + (** [sub_domain_partition filter sub] partitions [sub] according to whether domain identifiers satisfy [filter]. *) -let sub_domain_partition filter (sub: exp_subst) = +let sub_domain_partition filter (sub : exp_subst) = List.partition_tf ~f:(fun (i, _) -> filter i) sub @@ -1217,7 +1219,7 @@ let exp_subst_gen_free_vars sub = let exp_subst_free_vars sub = Sequence.Generator.run (exp_subst_gen_free_vars sub) -let rec exp_sub_ids (f: subst_fun) exp = +let rec exp_sub_ids (f : subst_fun) exp = let f_typ x = match f with `Exp _ -> x | `Typ (f, _) -> f x in let f_tname x = match f with `Exp _ -> x | `Typ (_, f) -> f x in match (exp : Exp.t) with @@ -1238,8 +1240,7 @@ let rec exp_sub_ids (f: subst_fun) exp = if phys_equal e' e then exp else Exp.Exn e' | Closure c -> let captured_vars = - IList.map_changed - ~equal:[%compare.equal : Exp.t * Pvar.t * Typ.t] + IList.map_changed ~equal:[%compare.equal: Exp.t * Pvar.t * Typ.t] ~f:(fun ((e, pvar, typ) as captured) -> let e' = exp_sub_ids f e in let typ' = f_typ typ in @@ -1301,7 +1302,7 @@ let apply_sub subst : subst_fun = `Typ (Typ.sub_type typ_subst, Typ.sub_tname typ_subst) -let exp_sub (subst: subst) e = exp_sub_ids (apply_sub subst) e +let exp_sub (subst : subst) e = exp_sub_ids (apply_sub subst) e (** apply [f] to id's in [instr]. if [sub_id_binders] is false, [f] is only applied to bound id's *) let instr_sub_ids ~sub_id_binders f instr = @@ -1333,8 +1334,7 @@ let instr_sub_ids ~sub_id_binders f instr = in let fun_exp' = exp_sub_ids f fun_exp in let actuals' = - IList.map_changed - ~equal:[%compare.equal : Exp.t * Typ.t] + IList.map_changed ~equal:[%compare.equal: Exp.t * Typ.t] ~f:(fun ((actual, typ) as actual_pair) -> let actual' = exp_sub_ids f actual in let typ' = sub_typ typ in @@ -1357,7 +1357,7 @@ let instr_sub_ids ~sub_id_binders f instr = (** apply [subst] to all id's in [instr], including binder id's *) -let instr_sub (subst: subst) instr = instr_sub_ids ~sub_id_binders:true (apply_sub subst) instr +let instr_sub (subst : subst) instr = instr_sub_ids ~sub_id_binders:true (apply_sub subst) instr let atom_sub subst = atom_expmap (exp_sub subst) @@ -1375,7 +1375,7 @@ let rec exp_replace_exp epairs e = match List.find ~f:(fun (e1, _) -> Exp.equal e e1) epairs with | Some (_, e2) -> e2 - | None -> + | None -> ( (* If e is a compound expression, we need to check for its subexpressions as well *) match e with | Exp.UnOp (op, e0, ty) -> @@ -1396,7 +1396,7 @@ let rec exp_replace_exp epairs e = let index' = exp_replace_exp epairs index in if phys_equal base base' && phys_equal index index' then e else Exp.Lindex (base', index') | _ -> - e + e ) let atom_replace_exp epairs atom = atom_expmap (fun e -> exp_replace_exp epairs e) atom @@ -1568,7 +1568,7 @@ let hpara_instantiate para e1 e2 elist = in let subst = `Exp - (exp_subst_of_list ((para.root, e1) :: (para.next, e2) :: subst_for_svars @ subst_for_evars)) + (exp_subst_of_list (((para.root, e1) :: (para.next, e2) :: subst_for_svars) @ subst_for_evars)) in (ids_evars, List.map ~f:(hpred_sub subst) para.body) @@ -1578,7 +1578,7 @@ let hpara_instantiate para e1 e2 elist = then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, zs'_/ zs\]] for some fresh [_zs'].*) -let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist = +let hpara_dll_instantiate (para : hpara_dll) cell blink flink elist = let subst_for_svars = let g id e = (id, e) in try List.map2_exn ~f:g para.svars_dll elist with Invalid_argument _ -> assert false @@ -1594,7 +1594,7 @@ let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist = let subst = `Exp (exp_subst_of_list - ( (para.cell, cell) :: (para.blink, blink) :: (para.flink, flink) :: subst_for_svars + ( ((para.cell, cell) :: (para.blink, blink) :: (para.flink, flink) :: subst_for_svars) @ subst_for_evars )) in (ids_evars, List.map ~f:(hpred_sub subst) para.body_dll) diff --git a/infer/src/IR/Sil.mli b/infer/src/IR/Sil.mli index 4cbb5c59f..82c969153 100644 --- a/infer/src/IR/Sil.mli +++ b/infer/src/IR/Sil.mli @@ -8,6 +8,7 @@ (** The Smallfoot Intermediate Language *) open! IStd + module F = Format (** {2 Programs and Types} *) diff --git a/infer/src/IR/SourceFiles.ml b/infer/src/IR/SourceFiles.ml index aaf4761a2..84d8f3933 100644 --- a/infer/src/IR/SourceFiles.ml +++ b/infer/src/IR/SourceFiles.ml @@ -23,7 +23,8 @@ let select_existing_statement = let get_existing_data source_file = ResultsDatabase.with_registered_statement select_existing_statement ~f:(fun db stmt -> - SourceFile.SQLite.serialize source_file |> Sqlite3.bind stmt 1 + SourceFile.SQLite.serialize source_file + |> Sqlite3.bind stmt 1 (* :source *) |> SqliteUtils.check_result_code db ~log:"get_existing_data bind source file" ; SqliteUtils.result_option ~finalize:false db ~log:"looking for pre-existing cfgs" stmt @@ -53,7 +54,8 @@ let add source_file cfg tenv = sure that all attributes were written to disk (but not necessarily flushed) *) Cfg.save_attributes source_file cfg ; ResultsDatabase.with_registered_statement store_statement ~f:(fun db store_stmt -> - SourceFile.SQLite.serialize source_file |> Sqlite3.bind store_stmt 1 + SourceFile.SQLite.serialize source_file + |> Sqlite3.bind store_stmt 1 (* :source *) |> SqliteUtils.check_result_code db ~log:"store bind source file" ; Cfg.SQLite.serialize cfg |> Sqlite3.bind store_stmt 2 @@ -77,8 +79,8 @@ let get_all ~filter () = it inside the function *) Sqlite3.prepare db "SELECT source_file FROM source_files" |> IContainer.rev_filter_map_to_list - ~fold:(SqliteUtils.result_fold_single_column_rows db ~log:"getting all source files") ~f: - (fun column -> + ~fold:(SqliteUtils.result_fold_single_column_rows db ~log:"getting all source files") + ~f:(fun column -> let source_file = SourceFile.SQLite.deserialize column in Option.some_if (filter source_file) source_file ) @@ -90,7 +92,8 @@ let load_proc_names_statement = let proc_names_of_source source = ResultsDatabase.with_registered_statement load_proc_names_statement ~f:(fun db load_stmt -> - SourceFile.SQLite.serialize source |> Sqlite3.bind load_stmt 1 + SourceFile.SQLite.serialize source + |> Sqlite3.bind load_stmt 1 |> SqliteUtils.check_result_code db ~log:"load bind source file" ; SqliteUtils.result_single_column_option ~finalize:false db ~log:"SourceFiles.proc_names_of_source" load_stmt @@ -103,7 +106,8 @@ let exists_source_statement = let is_captured source = ResultsDatabase.with_registered_statement exists_source_statement ~f:(fun db exists_stmt -> - SourceFile.SQLite.serialize source |> Sqlite3.bind exists_stmt 1 + SourceFile.SQLite.serialize source + |> Sqlite3.bind exists_stmt 1 (* :k *) |> SqliteUtils.check_result_code db ~log:"load captured source file" ; SqliteUtils.result_single_column_option ~finalize:false ~log:"SourceFiles.is_captured" db @@ -133,7 +137,8 @@ let deserialize_freshly_captured = function[@warning "-8"] let is_freshly_captured source = ResultsDatabase.with_registered_statement is_freshly_captured_statement ~f:(fun db load_stmt -> - SourceFile.SQLite.serialize source |> Sqlite3.bind load_stmt 1 + SourceFile.SQLite.serialize source + |> Sqlite3.bind load_stmt 1 |> SqliteUtils.check_result_code db ~log:"load bind source file" ; SqliteUtils.result_single_column_option ~finalize:false ~log:"SourceFiles.is_freshly_captured" db load_stmt diff --git a/infer/src/IR/SourceFiles.mli b/infer/src/IR/SourceFiles.mli index 30f7703ca..9f4d2ae20 100644 --- a/infer/src/IR/SourceFiles.mli +++ b/infer/src/IR/SourceFiles.mli @@ -29,5 +29,11 @@ val mark_all_stale : unit -> unit (** mark all source files as stale; do be called at the start of a new capture phase *) val pp_all : - filter:Filtering.source_files_filter -> cfgs:bool -> type_environment:bool - -> procedure_names:bool -> freshly_captured:bool -> Format.formatter -> unit -> unit + filter:Filtering.source_files_filter + -> cfgs:bool + -> type_environment:bool + -> procedure_names:bool + -> freshly_captured:bool + -> Format.formatter + -> unit + -> unit diff --git a/infer/src/IR/Subtype.ml b/infer/src/IR/Subtype.ml index b2ef967ec..c3739cde9 100644 --- a/infer/src/IR/Subtype.ml +++ b/infer/src/IR/Subtype.ml @@ -19,18 +19,18 @@ let list_to_string list = type t' = Exact (** denotes the current type only *) | Subtypes of Typ.Name.t list [@@deriving compare] -let equal_modulo_flag (st1, _) (st2, _) = [%compare.equal : t'] st1 st2 +let equal_modulo_flag (st1, _) (st2, _) = [%compare.equal: t'] st1 st2 (** denotes the current type and a list of types that are not their subtypes *) type kind = CAST | INSTOF | NORMAL [@@deriving compare] -let equal_kind = [%compare.equal : kind] +let equal_kind = [%compare.equal: kind] type t = t' * kind [@@deriving compare] type result = No | Unknown | Yes [@@deriving compare] -let equal_result = [%compare.equal : result] +let equal_result = [%compare.equal: result] let sub_type tname_subst st_pair = let st, kind = st_pair in @@ -44,7 +44,7 @@ let sub_type tname_subst st_pair = let max_result res1 res2 = if compare_result res1 res2 <= 0 then res2 else res1 -let is_interface tenv (class_name: Typ.Name.t) = +let is_interface tenv (class_name : Typ.Name.t) = match (class_name, Tenv.lookup tenv class_name) with | JavaClass _, Some {fields= []; methods= []} -> true @@ -98,7 +98,7 @@ let check_subtype = let is_subt = check_subclass_tenv tenv c1 c2 in subtMap := SubtypesMap.add (c1, c2) is_subt !subtMap ; is_subt - : result ) + : result ) let is_known_subtype tenv c1 c2 : bool = equal_result (check_subtype tenv c1 c2) Yes @@ -227,7 +227,7 @@ let rec add_not_subtype tenv c1 l1 l2 = if should_add then c :: rest' else rest' -let get_subtypes tenv (c1, ((st1, flag1): t)) (c2, ((st2, flag2): t)) = +let get_subtypes tenv (c1, ((st1, flag1) : t)) (c2, ((st2, flag2) : t)) = let is_sub = is_known_subtype tenv c1 c2 in let pos_st, neg_st = match (st1, st2) with diff --git a/infer/src/IR/Subtype.mli b/infer/src/IR/Subtype.mli index 81e0fbb4a..a654c0d34 100644 --- a/infer/src/IR/Subtype.mli +++ b/infer/src/IR/Subtype.mli @@ -44,7 +44,7 @@ val is_known_subtype : Tenv.t -> Typ.Name.t -> Typ.Name.t -> bool val is_cast : t -> bool -val is_instof : t -> bool [@@warning "-32"] +val is_instof : t -> bool [@@warning "-32"] val equal_modulo_flag : t -> t -> bool (** equality ignoring flags in the subtype *) diff --git a/infer/src/IR/Tenv.ml b/infer/src/IR/Tenv.ml index 81d32c9a9..5ade4f195 100644 --- a/infer/src/IR/Tenv.ml +++ b/infer/src/IR/Tenv.ml @@ -22,7 +22,7 @@ end) (** Type for type environment. *) type t = Typ.Struct.t TypenameHash.t -let pp fmt (tenv: t) = +let pp fmt (tenv : t) = TypenameHash.iter (fun name typ -> Format.fprintf fmt "@[<6>NAME: %s@]@," (Typ.Name.to_string name) ; @@ -44,7 +44,7 @@ let mk_struct tenv ?default ?fields ?statics ?methods ?supers ?annots name = (** Look up a name in the global type environment. *) let lookup tenv name : Typ.Struct.t option = - try Some (TypenameHash.find tenv name) with Caml.Not_found -> + try Some (TypenameHash.find tenv name) with Caml.Not_found -> ( (* ToDo: remove the following additional lookups once C/C++ interop is resolved *) match (name : Typ.Name.t) with | CStruct m -> ( @@ -52,7 +52,7 @@ let lookup tenv name : Typ.Struct.t option = | CppClass (m, NoTemplate) -> ( try Some (TypenameHash.find tenv (CStruct m)) with Caml.Not_found -> None ) | _ -> - None + None ) let compare_fields (name1, _, _) (name2, _, _) = Typ.Fieldname.compare name1 name2 @@ -131,7 +131,8 @@ let load_global () : t option = let load source = ResultsDatabase.with_registered_statement load_statement ~f:(fun db load_stmt -> - SourceFile.SQLite.serialize source |> Sqlite3.bind load_stmt 1 + SourceFile.SQLite.serialize source + |> Sqlite3.bind load_stmt 1 |> SqliteUtils.check_result_code db ~log:"load bind source file" ; SqliteUtils.result_single_column_option ~finalize:false ~log:"Tenv.load" db load_stmt |> Option.bind ~f:(fun x -> diff --git a/infer/src/IR/Tenv.mli b/infer/src/IR/Tenv.mli index f224b2727..edff4b6a2 100644 --- a/infer/src/IR/Tenv.mli +++ b/infer/src/IR/Tenv.mli @@ -30,15 +30,21 @@ val lookup : t -> Typ.Name.t -> Typ.Struct.t option (** Look up a name in the global type environment. *) val mk_struct : - t -> ?default:Typ.Struct.t -> ?fields:Typ.Struct.fields -> ?statics:Typ.Struct.fields - -> ?methods:Typ.Procname.t list -> ?supers:Typ.Name.t list -> ?annots:Annot.Item.t -> Typ.Name.t + t + -> ?default:Typ.Struct.t + -> ?fields:Typ.Struct.fields + -> ?statics:Typ.Struct.fields + -> ?methods:Typ.Procname.t list + -> ?supers:Typ.Name.t list + -> ?annots:Annot.Item.t + -> Typ.Name.t -> Typ.Struct.t (** Construct a struct_typ, normalizing field types *) val add_field : t -> Typ.Name.t -> Typ.Struct.field -> unit (** Add a field to a given struct in the global type environment. *) -val pp : Format.formatter -> t -> unit [@@warning "-32"] +val pp : Format.formatter -> t -> unit [@@warning "-32"] (** print a type environment *) val language_is : t -> Language.t -> bool diff --git a/infer/src/IR/Typ.ml b/infer/src/IR/Typ.ml index 3284e3c03..ec64051a4 100644 --- a/infer/src/IR/Typ.ml +++ b/infer/src/IR/Typ.ml @@ -96,7 +96,7 @@ type ptr_kind = | Pk_objc_autoreleasing (** Obj-C __autoreleasing pointer *) [@@deriving compare] -let equal_ptr_kind = [%compare.equal : ptr_kind] +let equal_ptr_kind = [%compare.equal: ptr_kind] let ptr_kind_string = function | Pk_reference -> @@ -146,21 +146,21 @@ module T = struct | Template of {mangled: string option; args: template_arg list} [@@deriving compare] - let equal_desc = [%compare.equal : desc] + let equal_desc = [%compare.equal: desc] - let equal_quals = [%compare.equal : type_quals] + let equal_quals = [%compare.equal: type_quals] - let equal_template_arg = [%compare.equal : template_arg] + let equal_template_arg = [%compare.equal: template_arg] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] end include T let mk_type_quals ?default ?is_const ?is_restrict ?is_volatile () = let default_ = {is_const= false; is_restrict= false; is_volatile= false} in - let mk_aux ?(default= default_) ?(is_const= default.is_const) ?(is_restrict= default.is_restrict) - ?(is_volatile= default.is_volatile) () = + let mk_aux ?(default = default_) ?(is_const = default.is_const) + ?(is_restrict = default.is_restrict) ?(is_volatile = default.is_volatile) () = {is_const; is_restrict; is_volatile} in mk_aux ?default ?is_const ?is_restrict ?is_volatile () @@ -174,7 +174,7 @@ let is_volatile {is_volatile} = is_volatile let mk ?default ?quals desc : t = let default_ = {desc; quals= mk_type_quals ()} in - let mk_aux ?(default= default_) ?(quals= default.quals) desc = {desc; quals} in + let mk_aux ?(default = default_) ?(quals = default.quals) desc = {desc; quals} in mk_aux ?default ?quals desc @@ -317,7 +317,7 @@ and sub_tname subst tname = module Name = struct type t = name [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let qual_name = function | CStruct name | CUnion name | ObjcClass name | ObjcProtocol name -> @@ -490,10 +490,10 @@ module Name = struct end (** dump a type with all the details. *) -let d_full (t: t) = L.add_print_with_pe pp_full t +let d_full (t : t) = L.add_print_with_pe pp_full t (** dump a list of types. *) -let d_list (tl: t list) = +let d_list (tl : t list) = let pp pe = Pp.seq (pp pe) in L.add_print_with_pe pp tl @@ -547,7 +547,7 @@ module Procname = struct (** Level of verbosity of some to_string functions. *) type detail_level = Verbose | Non_verbose | Simple [@@deriving compare] - let equal_detail_level = [%compare.equal : detail_level] + let equal_detail_level = [%compare.equal: detail_level] let is_verbose v = match v with Verbose -> true | _ -> false @@ -625,7 +625,7 @@ module Procname = struct let get_parameters j = j.parameters (** Prints a string of a java procname with the given level of verbosity *) - let to_string ?(withclass= false) j verbosity = + let to_string ?(withclass = false) j verbosity = match verbosity with | Verbose | Non_verbose -> (* if verbose, then package.class.method(params): rtype, @@ -830,7 +830,8 @@ module Procname = struct | CPPMethod {mangled} | CPPDestructor {mangled} -> "(" ^ Option.value ~default:"" mangled ^ ")" | CPPConstructor {mangled; is_constexpr} -> - "{" ^ Option.value ~default:"" mangled ^ (if is_constexpr then "|constexpr" else "") + "{" ^ Option.value ~default:"" mangled + ^ (if is_constexpr then "|constexpr" else "") ^ "}" | ObjCClassMethod -> "class" @@ -849,7 +850,8 @@ module Procname = struct | Verbose -> let m_str = kind_to_verbose_string osig.kind in Name.name osig.class_name ^ "_" ^ osig.method_name - ^ Parameter.parameters_to_string osig.parameters ^ m_str + ^ Parameter.parameters_to_string osig.parameters + ^ m_str let get_parameters osig = osig.parameters @@ -885,12 +887,12 @@ module Procname = struct plain ^ "()" | Non_verbose -> plain - | Verbose -> + | Verbose -> ( match mangled with | None -> plain ^ Parameter.parameters_to_string parameters | Some s -> - plain ^ Parameter.parameters_to_string parameters ^ "{" ^ s ^ "}" + plain ^ Parameter.parameters_to_string parameters ^ "{" ^ s ^ "}" ) let get_parameters c = c.parameters @@ -931,7 +933,7 @@ module Procname = struct | WithBlockParameters of t * Block.block_name list [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let hash = Hashtbl.hash @@ -967,7 +969,7 @@ module Procname = struct (** Replace the class name component of a procedure name. In case of Java, replace package and class name. *) - let rec replace_class t (new_class: Name.t) = + let rec replace_class t (new_class : Name.t) = match t with | Java j -> Java {j with class_name= new_class} @@ -983,7 +985,7 @@ module Procname = struct match t with ObjC_Cpp osig -> Name.is_objc_protocol osig.class_name | _ -> false - let rec objc_cpp_replace_method_name t (new_method_name: string) = + let rec objc_cpp_replace_method_name t (new_method_name : string) = match t with | ObjC_Cpp osig -> ObjC_Cpp {osig with method_name= new_method_name} @@ -1102,7 +1104,7 @@ module Procname = struct (** Convenient representation of a procname for external tools (e.g. eclipse plugin) *) - let rec to_simplified_string ?(withclass= false) p = + let rec to_simplified_string ?(withclass = false) p = match p with | Java j -> Java.to_string ~withclass j Simple @@ -1258,7 +1260,9 @@ module Procname = struct :: Option.to_list mangled |> String.concat ~sep:"#" | ObjC_Cpp objc_cpp -> - get_qual_name_str pname ^ Parameter.parameters_to_string objc_cpp.parameters ^ "#" + get_qual_name_str pname + ^ Parameter.parameters_to_string objc_cpp.parameters + ^ "#" ^ ObjC_Cpp.kind_to_verbose_string objc_cpp.kind | _ -> to_unique_id pname @@ -1304,7 +1308,7 @@ module Fieldname = struct type t = Clang of {class_name: Name.t; field_name: string} | Java of string [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] module T = struct type nonrec t = t @@ -1444,15 +1448,15 @@ module Struct = struct let internal_mk_struct ?default ?fields ?statics ?methods ?supers ?annots () = let default_ = {fields= []; statics= []; methods= []; supers= []; annots= Annot.Item.empty} in - let mk_struct_ ?(default= default_) ?(fields= default.fields) ?(statics= default.statics) - ?(methods= default.methods) ?(supers= default.supers) ?(annots= default.annots) () = + let mk_struct_ ?(default = default_) ?(fields = default.fields) ?(statics = default.statics) + ?(methods = default.methods) ?(supers = default.supers) ?(annots = default.annots) () = {fields; statics; methods; supers; annots} in mk_struct_ ?default ?fields ?statics ?methods ?supers ?annots () (** the element typ of the final extensible array in the given typ, if any *) - let rec get_extensible_array_element_typ ~lookup (typ: T.t) = + let rec get_extensible_array_element_typ ~lookup (typ : T.t) = match typ.desc with | Tarray {elt} -> Some elt @@ -1471,7 +1475,7 @@ module Struct = struct (** If a struct type with field f, return the type of f. If not, return the default *) - let fld_typ ~lookup ~default fn (typ: T.t) = + let fld_typ ~lookup ~default fn (typ : T.t) = match typ.desc with | Tstruct name -> ( match lookup name with @@ -1484,7 +1488,7 @@ module Struct = struct default - let get_field_type_and_annotation ~lookup fn (typ: T.t) = + let get_field_type_and_annotation ~lookup fn (typ : T.t) = match typ.desc with | Tstruct name | Tptr ({desc= Tstruct name}, _) -> ( match lookup name with diff --git a/infer/src/IR/Typ.mli b/infer/src/IR/Typ.mli index aa1d8d274..07fb23676 100644 --- a/infer/src/IR/Typ.mli +++ b/infer/src/IR/Typ.mli @@ -56,7 +56,11 @@ val equal_ptr_kind : ptr_kind -> ptr_kind -> bool type type_quals [@@deriving compare] val mk_type_quals : - ?default:type_quals -> ?is_const:bool -> ?is_restrict:bool -> ?is_volatile:bool -> unit + ?default:type_quals + -> ?is_const:bool + -> ?is_restrict:bool + -> ?is_volatile:bool + -> unit -> type_quals val is_const : type_quals -> bool @@ -643,8 +647,14 @@ module Struct : sig (** Pretty print a struct type. *) val internal_mk_struct : - ?default:t -> ?fields:fields -> ?statics:fields -> ?methods:Procname.t list - -> ?supers:Name.t list -> ?annots:Annot.Item.t -> unit -> t + ?default:t + -> ?fields:fields + -> ?statics:fields + -> ?methods:Procname.t list + -> ?supers:Name.t list + -> ?annots:Annot.Item.t + -> unit + -> t (** Construct a struct_typ, normalizing field types *) val get_extensible_array_element_typ : lookup:lookup -> typ -> typ option diff --git a/infer/src/IR/Unop.ml b/infer/src/IR/Unop.ml index de1c900f9..dab59d17f 100644 --- a/infer/src/IR/Unop.ml +++ b/infer/src/IR/Unop.ml @@ -17,7 +17,7 @@ type t = | LNot (** Logical Not (!) *) [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] (** String representation of unary operator. *) let to_string = function Neg -> "-" | BNot -> "~" | LNot -> "!" diff --git a/infer/src/IR/Var.ml b/infer/src/IR/Var.ml index 741b80fa2..bb079034c 100644 --- a/infer/src/IR/Var.ml +++ b/infer/src/IR/Var.ml @@ -12,7 +12,7 @@ module F = Format type t = LogicalVar of Ident.t | ProgramVar of Pvar.t [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let compare_modulo_this x y = match (x, y) with diff --git a/infer/src/IR/dune.in b/infer/src/IR/dune.in index eb2d93df1..7e5e65752 100644 --- a/infer/src/IR/dune.in +++ b/infer/src/IR/dune.in @@ -1,7 +1,9 @@ (* -*- tuareg -*- *) (* NOTE: prepend dune.common to this file! *) -;; Format.sprintf - {| + +;; +Format.sprintf + {| (library (name InferIR) (public_name InferIR) @@ -16,7 +18,7 @@ (mld_files index) ) |} - (String.concat " " common_cflags) - (String.concat " " common_optflags) - (String.concat " " ("InferBase" :: common_libraries)) - |> Jbuild_plugin.V1.send + (String.concat " " common_cflags) + (String.concat " " common_optflags) + (String.concat " " ("InferBase" :: common_libraries)) +|> Jbuild_plugin.V1.send diff --git a/infer/src/absint/AbstractDomain.ml b/infer/src/absint/AbstractDomain.ml index 6b1627bf7..94d50a8ba 100644 --- a/infer/src/absint/AbstractDomain.ml +++ b/infer/src/absint/AbstractDomain.ml @@ -297,7 +297,7 @@ module BooleanOr = struct let is_empty astate = not astate - let ( <= ) ~lhs ~rhs = not lhs || rhs + let ( <= ) ~lhs ~rhs = (not lhs) || rhs let join = ( || ) diff --git a/infer/src/absint/AbstractDomain.mli b/infer/src/absint/AbstractDomain.mli index d626c742e..077cf6cb9 100644 --- a/infer/src/absint/AbstractDomain.mli +++ b/infer/src/absint/AbstractDomain.mli @@ -59,7 +59,8 @@ module BottomLifted (Domain : S) : sig end (** Create a domain with Top element from a pre-domain *) -include sig +include + sig (* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *) [@@@warning "-60"] @@ -124,7 +125,8 @@ end (** Boolean domain ordered by p || ~q. Useful when you want a boolean that's true only when it's true in both conditional branches. *) -include sig +include + sig (* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *) [@@@warning "-60"] @@ -146,10 +148,10 @@ end module CountDomain (MaxCount : MaxCount) : sig include WithBottom with type astate = private int - val top : astate [@@warning "-32"] + val top : astate [@@warning "-32"] (** maximum value *) - val is_top : astate -> bool [@@warning "-32"] + val is_top : astate -> bool [@@warning "-32"] (** return true if this is the maximum value *) val increment : astate -> astate diff --git a/infer/src/absint/AbstractInterpreter.ml b/infer/src/absint/AbstractInterpreter.ml index fa0d30d62..53bf21384 100644 --- a/infer/src/absint/AbstractInterpreter.ml +++ b/infer/src/absint/AbstractInterpreter.ml @@ -19,12 +19,17 @@ module type S = sig type invariant_map = TransferFunctions.Domain.astate state InvariantMap.t val compute_post : - ?debug:bool -> TransferFunctions.extras ProcData.t -> initial:TransferFunctions.Domain.astate + ?debug:bool + -> TransferFunctions.extras ProcData.t + -> initial:TransferFunctions.Domain.astate -> TransferFunctions.Domain.astate option val exec_cfg : - TransferFunctions.CFG.t -> TransferFunctions.extras ProcData.t - -> initial:TransferFunctions.Domain.astate -> debug:bool -> invariant_map + TransferFunctions.CFG.t + -> TransferFunctions.extras ProcData.t + -> initial:TransferFunctions.Domain.astate + -> debug:bool + -> invariant_map val exec_pdesc : TransferFunctions.extras ProcData.t -> initial:TransferFunctions.Domain.astate -> invariant_map @@ -139,14 +144,14 @@ struct match extract_post_ pred with | None -> joined_post_opt - | Some post as some_post -> + | Some post as some_post -> ( match joined_post_opt with | None -> some_post | Some joined_post -> let res = Domain.join joined_post post in if debug then debug_absint_operation (`Join (joined_post, post, res)) node ; - Some res ) + Some res ) ) in match Scheduler.pop work_queue with | Some (_, [], work_queue') -> @@ -179,7 +184,7 @@ struct (* compute and return the postcondition of [pdesc] *) - let compute_post ?(debug= Config.write_html) ({ProcData.pdesc} as proc_data) ~initial = + let compute_post ?(debug = Config.write_html) ({ProcData.pdesc} as proc_data) ~initial = let cfg = CFG.from_pdesc pdesc in let inv_map = exec_cfg cfg proc_data ~initial ~debug in extract_post (Node.id (CFG.exit_node cfg)) inv_map diff --git a/infer/src/absint/AbstractInterpreter.mli b/infer/src/absint/AbstractInterpreter.mli index 596f0fff5..7c83386c5 100644 --- a/infer/src/absint/AbstractInterpreter.mli +++ b/infer/src/absint/AbstractInterpreter.mli @@ -19,14 +19,19 @@ module type S = sig type invariant_map = TransferFunctions.Domain.astate state InvariantMap.t val compute_post : - ?debug:bool -> TransferFunctions.extras ProcData.t -> initial:TransferFunctions.Domain.astate + ?debug:bool + -> TransferFunctions.extras ProcData.t + -> initial:TransferFunctions.Domain.astate -> TransferFunctions.Domain.astate option (** compute and return the postcondition for the given procedure starting from [initial]. If [debug] is true, print html debugging output. *) val exec_cfg : - TransferFunctions.CFG.t -> TransferFunctions.extras ProcData.t - -> initial:TransferFunctions.Domain.astate -> debug:bool -> invariant_map + TransferFunctions.CFG.t + -> TransferFunctions.extras ProcData.t + -> initial:TransferFunctions.Domain.astate + -> debug:bool + -> invariant_map (** compute and return invariant map for the given CFG/procedure starting from [initial]. if [debug] is true, print html debugging output. *) diff --git a/infer/src/absint/FormalMap.mli b/infer/src/absint/FormalMap.mli index 738345545..65d866522 100644 --- a/infer/src/absint/FormalMap.mli +++ b/infer/src/absint/FormalMap.mli @@ -30,4 +30,4 @@ val get_formal_base : int -> t -> AccessPath.base option val get_formals_indexes : t -> (AccessPath.base * int) list (** Get a list of (base * index) pairs. Note: these are sorted by base, not index *) -val pp : F.formatter -> t -> unit [@@warning "-32"] +val pp : F.formatter -> t -> unit [@@warning "-32"] diff --git a/infer/src/absint/LowerHil.ml b/infer/src/absint/LowerHil.ml index aa55153b9..008a82671 100644 --- a/infer/src/absint/LowerHil.ml +++ b/infer/src/absint/LowerHil.ml @@ -42,7 +42,7 @@ struct let is_java_unlock pname actuals = (* would check is_java, but we want to include builtins too *) - not (Typ.Procname.is_c_method pname) + (not (Typ.Procname.is_c_method pname)) && match RacerDConfig.Models.get_lock pname actuals with Unlock -> true | _ -> false diff --git a/infer/src/absint/LowerHil.mli b/infer/src/absint/LowerHil.mli index 65f56e153..ad839074f 100644 --- a/infer/src/absint/LowerHil.mli +++ b/infer/src/absint/LowerHil.mli @@ -42,7 +42,7 @@ module MakeAbstractInterpreterWithConfig module type of AbstractInterpreter.Make (CFG) (Make (MakeTransferFunctions) (HilConfig)) val compute_post : - Interpreter.TransferFunctions.extras ProcData.t + Interpreter.TransferFunctions.extras ProcData.t -> initial:MakeTransferFunctions(CFG).Domain.astate -> MakeTransferFunctions(CFG).Domain.astate option (** compute and return the postcondition for the given procedure starting from [initial]. If diff --git a/infer/src/absint/PatternMatch.ml b/infer/src/absint/PatternMatch.ml index 455e475cd..fe0b2099f 100644 --- a/infer/src/absint/PatternMatch.ml +++ b/infer/src/absint/PatternMatch.ml @@ -63,7 +63,7 @@ let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals with (_, t) :: _ -> Some t | _ -> None -let type_get_direct_supertypes tenv (typ: Typ.t) = +let type_get_direct_supertypes tenv (typ : Typ.t) = match typ.desc with | Tptr ({desc= Tstruct name}, _) | Tstruct name -> ( match Tenv.lookup tenv name with Some {supers} -> supers | None -> [] ) @@ -75,7 +75,7 @@ let type_get_class_name {Typ.desc} = match desc with Typ.Tptr (typ, _) -> Typ.name typ | _ -> None -let type_get_annotation tenv (typ: Typ.t) : Annot.Item.t option = +let type_get_annotation tenv (typ : Typ.t) : Annot.Item.t option = match typ.desc with | Tptr ({desc= Tstruct name}, _) | Tstruct name -> ( match Tenv.lookup tenv name with Some {annots} -> Some annots | None -> None ) @@ -93,7 +93,7 @@ let rec get_type_name {Typ.desc} = "_" -let get_field_type_name tenv (typ: Typ.t) (fieldname: Typ.Fieldname.t) : string option = +let get_field_type_name tenv (typ : Typ.t) (fieldname : Typ.Fieldname.t) : string option = match typ.desc with | Tstruct name | Tptr ({desc= Tstruct name}, _) -> ( match Tenv.lookup tenv name with @@ -109,7 +109,7 @@ let get_field_type_name tenv (typ: Typ.t) (fieldname: Typ.Fieldname.t) : string None -let java_get_const_type_name (const: Const.t) : string = +let java_get_const_type_name (const : Const.t) : string = match const with | Const.Cstr _ -> "java.lang.String" @@ -121,7 +121,7 @@ let java_get_const_type_name (const: Const.t) : string = "_" -let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : string list = +let get_vararg_type_names tenv (call_node : Procdesc.Node.t) (ivar : Pvar.t) : string list = (* Is this the node creating ivar? *) let initializes_array instrs = instrs @@ -224,7 +224,7 @@ let initializer_classes = let initializer_methods = ["onActivityCreated"; "onAttach"; "onCreate"; "onCreateView"; "setUp"] (** Check if the type has in its supertypes from the initializer_classes list. *) -let type_has_initializer (tenv: Tenv.t) (t: Typ.t) : bool = +let type_has_initializer (tenv : Tenv.t) (t : Typ.t) : bool = let is_initializer_class typename _ = List.mem ~equal:Typ.Name.equal initializer_classes typename in @@ -236,7 +236,7 @@ let type_has_initializer (tenv: Tenv.t) (t: Typ.t) : bool = (** Check if the method is one of the known initializer methods. *) -let method_is_initializer (tenv: Tenv.t) (proc_attributes: ProcAttributes.t) : bool = +let method_is_initializer (tenv : Tenv.t) (proc_attributes : ProcAttributes.t) : bool = match get_this_type proc_attributes with | Some this_type -> if type_has_initializer tenv this_type then @@ -289,11 +289,10 @@ let proc_calls resolve_attributes pdesc filter : (Typ.Procname.t * ProcAttribute Instrs.iter ~f:(do_instruction node) instrs in let nodes = Procdesc.get_nodes pdesc in - List.iter ~f:do_node nodes ; - List.rev !res + List.iter ~f:do_node nodes ; List.rev !res -let override_find ?(check_current_type= true) f tenv proc_name = +let override_find ?(check_current_type = true) f tenv proc_name = let method_name = Typ.Procname.get_method proc_name in let is_override pname = (* Note: very coarse! TODO: match parameter names/types to get an exact match *) @@ -325,7 +324,7 @@ let override_find ?(check_current_type= true) f tenv proc_name = None -let override_exists ?(check_current_type= true) f tenv proc_name = +let override_exists ?(check_current_type = true) f tenv proc_name = override_find ~check_current_type f tenv proc_name |> Option.is_some diff --git a/infer/src/absint/PatternMatch.mli b/infer/src/absint/PatternMatch.mli index 71ddc4bb9..f1baf2ff2 100644 --- a/infer/src/absint/PatternMatch.mli +++ b/infer/src/absint/PatternMatch.mli @@ -50,12 +50,17 @@ val java_get_vararg_values : Procdesc.Node.t -> Pvar.t -> Idenv.t -> Exp.t list (** Get the values of a vararg parameter given the pvar used to assign the elements. *) val proc_calls : - (Typ.Procname.t -> ProcAttributes.t option) -> Procdesc.t - -> (Typ.Procname.t -> ProcAttributes.t -> bool) -> (Typ.Procname.t * ProcAttributes.t) list + (Typ.Procname.t -> ProcAttributes.t option) + -> Procdesc.t + -> (Typ.Procname.t -> ProcAttributes.t -> bool) + -> (Typ.Procname.t * ProcAttributes.t) list (** Return the callees that satisfy [filter]. *) val override_find : - ?check_current_type:bool -> (Typ.Procname.t -> bool) -> Tenv.t -> Typ.Procname.t + ?check_current_type:bool + -> (Typ.Procname.t -> bool) + -> Tenv.t + -> Typ.Procname.t -> Typ.Procname.t option (** Return a method which overrides [procname] and satisfies [f] (including [procname] itself when [check_current_type] is true, which it is by default). *) diff --git a/infer/src/absint/ProcCfg.ml b/infer/src/absint/ProcCfg.ml index 24e7287c1..1407eaec7 100644 --- a/infer/src/absint/ProcCfg.ml +++ b/infer/src/absint/ProcCfg.ml @@ -74,9 +74,8 @@ end module InstrNode : sig type instr_index = int - include Node - with type t = Procdesc.Node.t * instr_index - and type id = Procdesc.Node.id * instr_index + include + Node with type t = Procdesc.Node.t * instr_index and type id = Procdesc.Node.id * instr_index end = struct type instr_index = int [@@deriving compare] @@ -297,10 +296,8 @@ module Backward (Base : S with type instrs_dir = Instrs.not_reversed) = struct end module OneInstrPerNode (Base : S with module Node = DefaultNode) : sig - include S - with type t = Base.t - and module Node = InstrNode - and type instrs_dir = Instrs.not_reversed + include + S with type t = Base.t and module Node = InstrNode and type instrs_dir = Instrs.not_reversed val last_of_underlying_node : Procdesc.Node.t -> Node.t end = struct @@ -383,7 +380,7 @@ module MakeOcamlGraph (Base : S) = struct let compare n1 n2 = Base.Node.compare_id (Base.Node.id n1) (Base.Node.id n2) - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let hash = Base.Node.hash end diff --git a/infer/src/absint/ProcCfg.mli b/infer/src/absint/ProcCfg.mli index fefc7ad01..8f3e4851f 100644 --- a/infer/src/absint/ProcCfg.mli +++ b/infer/src/absint/ProcCfg.mli @@ -83,9 +83,8 @@ module DefaultNode : Node with type t = Procdesc.Node.t and type id = Procdesc.N module InstrNode : sig type instr_index - include Node - with type t = Procdesc.Node.t * instr_index - and type id = Procdesc.Node.id * instr_index + include + Node with type t = Procdesc.Node.t * instr_index and type id = Procdesc.Node.id * instr_index end (** Forward CFG with no exceptional control-flow *) @@ -107,10 +106,8 @@ module Backward (Base : S with type instrs_dir = Instrs.not_reversed) : S with type t = Base.t and module Node = Base.Node and type instrs_dir = Instrs.reversed module OneInstrPerNode (Base : S with module Node = DefaultNode) : sig - include S - with type t = Base.t - and module Node = InstrNode - and type instrs_dir = Instrs.not_reversed + include + S with type t = Base.t and module Node = InstrNode and type instrs_dir = Instrs.not_reversed val last_of_underlying_node : Procdesc.Node.t -> Node.t end diff --git a/infer/src/absint/Scheduler.ml b/infer/src/absint/Scheduler.ml index 4a3654ea8..f7e457b49 100644 --- a/infer/src/absint/Scheduler.ml +++ b/infer/src/absint/Scheduler.ml @@ -85,6 +85,7 @@ module ReversePostorder (CFG : ProcCfg.S) = struct (* TODO: could do this slightly more efficiently by keeping a list of priority zero nodes for quick popping, and do a linear search only when this list is empty *) + (** remove and return the node with the highest priority (note that smaller integers have higher priority), the ids of its visited predecessors, and new schedule *) let pop t = diff --git a/infer/src/absint/SummaryPayload.ml b/infer/src/absint/SummaryPayload.ml index 7589e3f28..1c05b52ca 100644 --- a/infer/src/absint/SummaryPayload.ml +++ b/infer/src/absint/SummaryPayload.ml @@ -28,11 +28,11 @@ end module Make (P : Payload) : S with type t = P.t = struct type t = P.t - let update_summary p (summary: Summary.t) = + let update_summary p (summary : Summary.t) = {summary with payloads= P.update_payloads p summary.payloads} - let of_summary (summary: Summary.t) = P.of_payloads summary.payloads + let of_summary (summary : Summary.t) = P.of_payloads summary.payloads let read caller_pdesc callee_pname = Ondemand.analyze_proc_name ~caller_pdesc callee_pname |> Option.bind ~f:of_summary diff --git a/infer/src/atd/InferCommand.ml b/infer/src/atd/InferCommand.ml index 14003d56e..b8297cc99 100644 --- a/infer/src/atd/InferCommand.ml +++ b/infer/src/atd/InferCommand.ml @@ -10,7 +10,7 @@ open Core type t = Analyze | Capture | Compile | Diff | Events | Explore | Report | ReportDiff | Run [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let command_to_string = [ (Analyze, "analyze") diff --git a/infer/src/atd/dune.in b/infer/src/atd/dune.in index 676387b95..bf7c4bdf7 100644 --- a/infer/src/atd/dune.in +++ b/infer/src/atd/dune.in @@ -3,8 +3,9 @@ let cflags = common_cflags @ ["-w"; "-27-32-34-35-39"] -;; Format.sprintf - {| +;; +Format.sprintf + {| (library (name InferGenerated) (public_name InferGenerated) @@ -19,6 +20,6 @@ let cflags = common_cflags @ ["-w"; "-27-32-34-35-39"] (mld_files index) ) |} - (String.concat " " cflags) - (String.concat " " common_optflags) - |> Jbuild_plugin.V1.send + (String.concat " " cflags) + (String.concat " " common_optflags) +|> Jbuild_plugin.V1.send diff --git a/infer/src/backend/Differential.ml b/infer/src/backend/Differential.ml index b05fb0ee5..b80ae1243 100644 --- a/infer/src/backend/Differential.ml +++ b/infer/src/backend/Differential.ml @@ -13,7 +13,7 @@ module LocListSet = struct type t = Location.t list [@@deriving compare] end) - let mem s xs = not (List.is_empty xs) && mem (List.sort ~compare:Location.compare xs) s + let mem s xs = (not (List.is_empty xs)) && mem (List.sort ~compare:Location.compare xs) s let add s xs = if List.is_empty xs then s else add (List.sort ~compare:Location.compare xs) s end @@ -23,7 +23,7 @@ let is_duplicate_report end_locs reported_ends = let sort_by_decreasing_preference_to_report issues = - let compare (x: Jsonbug_t.jsonbug) (y: Jsonbug_t.jsonbug) = + let compare (x : Jsonbug_t.jsonbug) (y : Jsonbug_t.jsonbug) = let n = Int.compare (List.length x.bug_trace) (List.length y.bug_trace) in if n <> 0 then n else @@ -34,15 +34,15 @@ let sort_by_decreasing_preference_to_report issues = let sort_by_location issues = - let compare (x: Jsonbug_t.jsonbug) (y: Jsonbug_t.jsonbug) = - [%compare : string * int * int] (x.file, x.line, x.column) (y.file, y.line, y.column) + let compare (x : Jsonbug_t.jsonbug) (y : Jsonbug_t.jsonbug) = + [%compare: string * int * int] (x.file, x.line, x.column) (y.file, y.line, y.column) in List.sort ~compare issues -let dedup (issues: Jsonbug_t.jsonbug list) = - List.fold (sort_by_decreasing_preference_to_report issues) ~init:(LocListSet.empty, []) ~f: - (fun (reported_ends, nondup_issues) (issue: Jsonbug_t.jsonbug) -> +let dedup (issues : Jsonbug_t.jsonbug list) = + List.fold (sort_by_decreasing_preference_to_report issues) ~init:(LocListSet.empty, []) + ~f:(fun (reported_ends, nondup_issues) (issue : Jsonbug_t.jsonbug) -> match issue.access with | Some encoded -> let _, _, end_locs = IssueAuxData.decode encoded in @@ -72,7 +72,7 @@ end = struct let count report = - let count_aux t (e: Jsonbug_t.extra) = + let count_aux t (e : Jsonbug_t.extra) = match e with | {cost_polynomial= Some cp} when String.equal cp zero_token_str -> {t with zero= t.zero + 1} @@ -133,7 +133,7 @@ type t = ; costs_summary: Yojson.Basic.json } (** Set operations should keep duplicated issues with identical hashes *) -let of_reports ~(current_report: Jsonbug_t.report) ~(previous_report: Jsonbug_t.report) : t = +let of_reports ~(current_report : Jsonbug_t.report) ~(previous_report : Jsonbug_t.report) : t = let to_map report = List.fold_left ~f:(fun map issue -> Map.add_multi map ~key:issue.Jsonbug_t.hash ~data:issue) diff --git a/infer/src/backend/DifferentialFilters.ml b/infer/src/backend/DifferentialFilters.ml index 6550db0dd..bf604ec6f 100644 --- a/infer/src/backend/DifferentialFilters.ml +++ b/infer/src/backend/DifferentialFilters.ml @@ -13,7 +13,7 @@ module FileRenamings = struct type t = renaming list [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let empty = [] @@ -26,8 +26,7 @@ module FileRenamings = struct let renaming_of_assoc assoc : renaming = try match assoc with - | `Assoc l - -> ( + | `Assoc l -> ( let current_opt = List.Assoc.find ~equal:String.equal l "current" in let previous_opt = List.Assoc.find ~equal:String.equal l "previous" in match (current_opt, previous_opt) with @@ -59,7 +58,7 @@ module FileRenamings = struct let from_json_file file : t = from_json (In_channel.read_all file) - let find_previous (t: t) current = + let find_previous (t : t) current = let r = List.find ~f:(fun r -> String.equal current r.current) t in Option.map ~f:(fun r -> r.previous) r @@ -83,7 +82,7 @@ end (** Returns a triple [(l1', dups, l2')] where [dups] is the set of elements of that are in the intersection of [l1] and [l2] according to [cmd] and additionally satisfy [pred], and [lN'] is [lN] minus [dups]. [dups] contains only one witness for each removed issue, taken from [l1]. *) -let relative_complements ~compare ?(pred= fun _ -> true) l1 l2 = +let relative_complements ~compare ?(pred = fun _ -> true) l1 l2 = let rec aux ((out_l1, dups, out_l2) as out) in_l1 in_l2 = let is_last_seen_dup v = match dups with ld :: _ -> Int.equal (compare ld v) 0 | [] -> false @@ -115,7 +114,7 @@ let relative_complements ~compare ?(pred= fun _ -> true) l1 l2 = type issue_file_with_renaming = Jsonbug_t.jsonbug * string option -let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differential.t = +let skip_duplicated_types_on_filenames renamings (diff : Differential.t) : Differential.t = let compare_issue_file_with_renaming (issue1, previous_file1) (issue2, previous_file2) = let f1, f2 = ( Option.value previous_file1 ~default:issue1.Jsonbug_t.file @@ -123,8 +122,9 @@ let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differ in String.compare f1 f2 in - let compare ((issue1, _) as issue_with_previous_file1) ((issue2, _) as issue_with_previous_file2) = - [%compare : Caml.Digest.t * string * issue_file_with_renaming] + let compare ((issue1, _) as issue_with_previous_file1) ((issue2, _) as issue_with_previous_file2) + = + [%compare: Caml.Digest.t * string * issue_file_with_renaming] (issue1.Jsonbug_t.node_key, issue1.Jsonbug_t.bug_type, issue_with_previous_file1) (issue2.Jsonbug_t.node_key, issue2.Jsonbug_t.bug_type, issue_with_previous_file2) in @@ -153,13 +153,13 @@ type file_extension = string [@@deriving compare] type weak_hash = string * string * string * Caml.Digest.t [@@deriving compare] (* Strip issues whose paths are not among those we're interested in *) -let interesting_paths_filter (interesting_paths: SourceFile.t list option) = +let interesting_paths_filter (interesting_paths : SourceFile.t list option) = match interesting_paths with - | Some (paths: SourceFile.t list) -> + | Some (paths : SourceFile.t list) -> let interesting_paths_set = paths |> List.filter_map ~f:(fun p -> - if not (SourceFile.is_invalid p) && SourceFile.is_under_project_root p then + if (not (SourceFile.is_invalid p)) && SourceFile.is_under_project_root p then Some (SourceFile.to_string p) else None ) |> String.Set.of_list @@ -172,8 +172,8 @@ let interesting_paths_filter (interesting_paths: SourceFile.t list option) = Fn.id -let do_filter (diff: Differential.t) (renamings: FileRenamings.t) ~(skip_duplicated_types: bool) - ~(interesting_paths: SourceFile.t list option) : Differential.t = +let do_filter (diff : Differential.t) (renamings : FileRenamings.t) ~(skip_duplicated_types : bool) + ~(interesting_paths : SourceFile.t list option) : Differential.t = let paths_filter = interesting_paths_filter interesting_paths in let apply_paths_filter_if_needed label issues = if List.exists ~f:(PolyVariantEqual.( = ) label) Config.differential_filter_set then diff --git a/infer/src/backend/DifferentialFilters.mli b/infer/src/backend/DifferentialFilters.mli index 6c9b9f664..f96fb8eb4 100644 --- a/infer/src/backend/DifferentialFilters.mli +++ b/infer/src/backend/DifferentialFilters.mli @@ -30,12 +30,18 @@ module FileRenamings : sig end val do_filter : - Differential.t -> FileRenamings.t -> skip_duplicated_types:bool - -> interesting_paths:SourceFile.t list option -> Differential.t + Differential.t + -> FileRenamings.t + -> skip_duplicated_types:bool + -> interesting_paths:SourceFile.t list option + -> Differential.t module VISIBLE_FOR_TESTING_DO_NOT_USE_DIRECTLY : sig val relative_complements : - compare:('a -> 'a -> int) -> ?pred:('a -> bool) -> 'a list -> 'a list + compare:('a -> 'a -> int) + -> ?pred:('a -> bool) + -> 'a list + -> 'a list -> 'a list * 'a list * 'a list val skip_duplicated_types_on_filenames : FileRenamings.t -> Differential.t -> Differential.t diff --git a/infer/src/backend/InferAnalyze.ml b/infer/src/backend/InferAnalyze.ml index aa0b49663..caa51804a 100644 --- a/infer/src/backend/InferAnalyze.ml +++ b/infer/src/backend/InferAnalyze.ml @@ -8,6 +8,7 @@ (** Main module for the analysis after the capture phase *) open! IStd + module L = Logging let clear_caches () = @@ -84,7 +85,7 @@ let main ~changed_files = let n_source_files = List.length source_files_to_analyze in L.progress "Found %d%s source file%s to analyze in %s@." n_source_files ( if Config.reactive_mode || Option.is_some changed_files then - " (out of " ^ string_of_int (List.length all_source_files) ^ ")" + " (out of " ^ string_of_int (List.length all_source_files) ^ ")" else "" ) (if Int.equal n_source_files 1 then "" else "s") Config.results_dir ; diff --git a/infer/src/backend/InferPrint.ml b/infer/src/backend/InferPrint.ml index a0d61a0a9..b632efafb 100644 --- a/infer/src/backend/InferPrint.ml +++ b/infer/src/backend/InferPrint.ml @@ -43,14 +43,14 @@ let error_desc_to_plain_string error_desc = let error_desc_to_dotty_string error_desc = Localise.error_desc_get_dotty error_desc -let compute_key (bug_type: string) (proc_name: Typ.Procname.t) (filename: string) = +let compute_key (bug_type : string) (proc_name : Typ.Procname.t) (filename : string) = let base_filename = Filename.basename filename and simple_procedure_name = Typ.Procname.get_method proc_name in String.concat ~sep:"|" [base_filename; simple_procedure_name; bug_type] -let compute_hash (severity: string) (bug_type: string) (proc_name: Typ.Procname.t) - (filename: string) (qualifier: string) = +let compute_hash (severity : string) (bug_type : string) (proc_name : Typ.Procname.t) + (filename : string) (qualifier : string) = let base_filename = Filename.basename filename in let hashable_procedure_name = Typ.Procname.hashable_name proc_name in let location_independent_qualifier = @@ -161,8 +161,8 @@ module ProcsCsv = struct pp "%s@\n" sv.vproof_trace end -let should_report (issue_kind: Exceptions.severity) issue_type error_desc eclass = - if not Config.filtering || Exceptions.equal_err_class eclass Exceptions.Linters then true +let should_report (issue_kind : Exceptions.severity) issue_type error_desc eclass = + if (not Config.filtering) || Exceptions.equal_err_class eclass Exceptions.Linters then true else let issue_kind_is_blacklisted = match issue_kind with Info -> true | Advice | Error | Like | Warning -> false @@ -187,12 +187,13 @@ let should_report (issue_kind: Exceptions.severity) issue_type error_desc eclass (* The reason an issue should be censored (that is, not reported). The empty string (that is "no reason") means that the issue should be reported. *) -let censored_reason (issue_type: IssueType.t) source_file = +let censored_reason (issue_type : IssueType.t) source_file = let filename = SourceFile.to_rel_path source_file in - let rejected_by ((issue_type_polarity, issue_type_re), (filename_polarity, filename_re), reason) = + let rejected_by ((issue_type_polarity, issue_type_re), (filename_polarity, filename_re), reason) + = let accepted = (* matches issue_type_re implies matches filename_re *) - not (Bool.equal issue_type_polarity (Str.string_match issue_type_re issue_type.unique_id 0)) + (not (Bool.equal issue_type_polarity (Str.string_match issue_type_re issue_type.unique_id 0))) || Bool.equal filename_polarity (Str.string_match filename_re filename 0) in Option.some_if (not accepted) reason @@ -216,9 +217,7 @@ module MakeJsonListPrinter (P : sig type elt val to_string : elt -> string option -end) : - Printer with type elt = P.elt = -struct +end) : Printer with type elt = P.elt = struct include P let is_first_item = ref true @@ -249,7 +248,7 @@ type json_issue_printer_typ = module JsonIssuePrinter = MakeJsonListPrinter (struct type elt = json_issue_printer_typ - let to_string ({error_filter; proc_name; proc_loc_opt; err_key; err_data}: elt) = + let to_string ({error_filter; proc_name; proc_loc_opt; err_key; err_data} : elt) = let source_file, procedure_start_line = match proc_loc_opt with | Some proc_loc -> @@ -262,10 +261,11 @@ module JsonIssuePrinter = MakeJsonListPrinter (struct "Invalid source file for %a %a@.Trace: %a@." IssueType.pp err_key.err_name Localise.pp_error_desc err_key.err_desc Errlog.pp_loc_trace err_data.loc_trace ; let should_report_source_file = - not (SourceFile.is_infer_model source_file) || Config.debug_mode || Config.debug_exceptions + (not (SourceFile.is_infer_model source_file)) || Config.debug_mode || Config.debug_exceptions in if - err_key.in_footprint && error_filter source_file err_key.err_name + err_key.in_footprint + && error_filter source_file err_key.err_name && should_report_source_file && should_report err_key.severity err_key.err_name err_key.err_desc err_data.err_class then @@ -364,7 +364,7 @@ module JsonCostsPrinter = MakeJsonListPrinter (struct end) let pp_custom_of_report fmt report fields = - let pp_custom_of_issue fmt (issue: Jsonbug_t.jsonbug) = + let pp_custom_of_issue fmt (issue : Jsonbug_t.jsonbug) = let open Jsonbug_t in let comma_separator index = if index > 0 then ", " else "" in let pp_trace fmt trace comma = @@ -383,7 +383,8 @@ let pp_custom_of_report fmt report fields = | `Issue_field_bucket -> let bucket = match - String.lsplit2 issue.qualifier ~on:']' |> Option.map ~f:fst + String.lsplit2 issue.qualifier ~on:']' + |> Option.map ~f:fst |> Option.bind ~f:(String.chop_prefix ~prefix:"[") with | Some bucket -> @@ -428,13 +429,13 @@ let pp_custom_of_report fmt report fields = let tests_jsonbug_compare bug1 bug2 = let open Jsonbug_t in - [%compare : string * string * int * string * Caml.Digest.t] + [%compare: string * string * int * string * Caml.Digest.t] (bug1.file, bug1.procedure, bug1.line - bug1.procedure_start_line, bug1.bug_type, bug1.hash) (bug2.file, bug2.procedure, bug2.line - bug2.procedure_start_line, bug2.bug_type, bug2.hash) module IssuesTxt = struct - let pp_issue fmt error_filter proc_loc_opt (key: Errlog.err_key) (err_data: Errlog.err_data) = + let pp_issue fmt error_filter proc_loc_opt (key : Errlog.err_key) (err_data : Errlog.err_data) = let source_file = match proc_loc_opt with | Some proc_loc -> @@ -443,8 +444,9 @@ module IssuesTxt = struct err_data.loc.Location.file in if - key.in_footprint && error_filter source_file key.err_name - && (not Config.filtering || String.is_empty (censored_reason key.err_name source_file)) + key.in_footprint + && error_filter source_file key.err_name + && ((not Config.filtering) || String.is_empty (censored_reason key.err_name source_file)) then Exceptions.pp_err err_data.loc key.severity key.err_name key.err_desc None fmt () @@ -503,7 +505,9 @@ module Stats = struct let res = ref [] in let indent_string n = let s = ref "" in - for _ = 1 to n do s := " " ^ !s done ; + for _ = 1 to n do + s := " " ^ !s + done ; !s in let num = ref 0 in @@ -525,13 +529,12 @@ module Stats = struct in res := line :: "" :: !res in - List.iter ~f:loc_to_string ltr ; - List.rev !res + List.iter ~f:loc_to_string ltr ; List.rev !res let process_err_log error_filter linereader err_log stats = let found_errors = ref false in - let process_row (key: Errlog.err_key) (err_data: Errlog.err_data) = + let process_row (key : Errlog.err_key) (err_data : Errlog.err_data) = let type_str = key.err_name.IssueType.unique_id in if key.in_footprint && error_filter key.err_name then match key.severity with @@ -604,7 +607,7 @@ module Stats = struct end module StatsLogs = struct - let process _ (summary: Summary.t) _ _ = + let process _ (summary : Summary.t) _ _ = let num_preposts = match summary.payloads.biabduction with Some {preposts} -> List.length preposts | None -> 0 in @@ -681,7 +684,7 @@ module Issue = struct type err_data_ = Errlog.err_data (* no derived compare for err_data; just compare the locations *) - let compare_err_data_ (err_data1: Errlog.err_data) (err_data2: Errlog.err_data) = + let compare_err_data_ (err_data1 : Errlog.err_data) (err_data2 : Errlog.err_data) = Location.compare err_data1.loc err_data2.loc @@ -701,15 +704,16 @@ module Issue = struct let sort_filter_issues issues = let issues' = List.dedup_and_sort ~compare issues in ( if Config.developer_mode then - let num_pruned_issues = List.length issues - List.length issues' in - if num_pruned_issues > 0 then - L.user_warning "Note: pruned %d duplicate issues@\n" num_pruned_issues ) ; + let num_pruned_issues = List.length issues - List.length issues' in + if num_pruned_issues > 0 then + L.user_warning "Note: pruned %d duplicate issues@\n" num_pruned_issues ) ; issues' end let error_filter filters proc_name file error_name = (Config.write_html || not (IssueType.(equal skip_function) error_name)) - && filters.Inferconfig.path_filter file && filters.Inferconfig.error_filter error_name + && filters.Inferconfig.path_filter file + && filters.Inferconfig.error_filter error_name && filters.Inferconfig.proc_filter proc_name @@ -751,7 +755,7 @@ let get_outfile outfile = L.(die InternalError) "An outfile is require for this format." -let pp_issue_in_format (format_kind, (outfile_opt: Utils.outfile option)) error_filter +let pp_issue_in_format (format_kind, (outfile_opt : Utils.outfile option)) error_filter {Issue.proc_name; proc_location; err_key; err_data} = match format_kind with | Json -> @@ -769,7 +773,7 @@ let pp_issue_in_format (format_kind, (outfile_opt: Utils.outfile option)) error_ IssuesTxt.pp_issue outf.fmt error_filter (Some proc_location) err_key err_data -let pp_issues_in_format (format_kind, (outfile_opt: Utils.outfile option)) = +let pp_issues_in_format (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Json -> let outf = get_outfile outfile_opt in @@ -785,7 +789,7 @@ let pp_issues_in_format (format_kind, (outfile_opt: Utils.outfile option)) = IssuesTxt.pp_issues_of_error_log outf.fmt -let pp_procs_in_format (format_kind, (outfile_opt: Utils.outfile option)) = +let pp_procs_in_format (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Csv -> let outf = get_outfile outfile_opt in @@ -841,7 +845,7 @@ let pp_summary summary = summary -let pp_costs_in_format (format_kind, (outfile_opt: Utils.outfile option)) = +let pp_costs_in_format (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Json -> let outf = get_outfile outfile_opt in @@ -883,7 +887,7 @@ let pp_json_report_by_report_kind formats_by_report_kind fname = match Utils.read_file fname with | Ok report_lines -> let pp_json_issues format_list report = - let pp_json_issue (format_kind, (outfile_opt: Utils.outfile option)) = + let pp_json_issue (format_kind, (outfile_opt : Utils.outfile option)) = match format_kind with | Tests -> let outf = get_outfile outfile_opt in @@ -916,7 +920,8 @@ let pp_json_report_by_report_kind formats_by_report_kind fname = L.(die UserError) "Error reading '%s': %s" fname error -let pp_lint_issues_by_report_kind formats_by_report_kind error_filter linereader procname error_log = +let pp_lint_issues_by_report_kind formats_by_report_kind error_filter linereader procname error_log + = let pp_summary_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with | Issues, _ :: _ -> @@ -955,7 +960,7 @@ let spec_files_from_cmdline () = files may be generated between init and report time. *) List.iter ~f:(fun arg -> - if not (Filename.check_suffix arg Config.specs_files_suffix) && arg <> "." then + if (not (Filename.check_suffix arg Config.specs_files_suffix)) && arg <> "." then print_usage_exit ("file " ^ arg ^ ": arguments must be .specs files") ) Config.anon_args ; if Config.test_filtering then ( Inferconfig.test () ; L.exit 0 ) ; @@ -1002,7 +1007,7 @@ let init_stats_format_list () = let init_files format_list_by_kind = let init_files_of_report_kind (report_kind, format_list) = - let init_files_of_format (format_kind, (outfile_opt: Utils.outfile option)) = + let init_files_of_format (format_kind, (outfile_opt : Utils.outfile option)) = match (format_kind, report_kind) with | Csv, Issues -> L.(die InternalError) "Printing issues in a CSV format is not implemented" @@ -1032,9 +1037,9 @@ let init_files format_list_by_kind = List.iter ~f:init_files_of_report_kind format_list_by_kind -let finalize_and_close_files format_list_by_kind (stats: Stats.t) = +let finalize_and_close_files format_list_by_kind (stats : Stats.t) = let close_files_of_report_kind (report_kind, format_list) = - let close_files_of_format (format_kind, (outfile_opt: Utils.outfile option)) = + let close_files_of_format (format_kind, (outfile_opt : Utils.outfile option)) = ( match (format_kind, report_kind) with | Logs, (Issues | Procs | Summary) -> L.(die InternalError) "Logging these reports is not implemented" diff --git a/infer/src/backend/OndemandCapture.ml b/infer/src/backend/OndemandCapture.ml index 4df09d9ff..78829b3d6 100644 --- a/infer/src/backend/OndemandCapture.ml +++ b/infer/src/backend/OndemandCapture.ml @@ -12,40 +12,39 @@ let compilation_db = lazy (CompilationDatabase.from_json_files !Config.clang_com (** Given proc_attributes try to produce proc_attributes' where proc_attributes'.is_defined = true It may trigger capture of extra files to do so and when it does, it waits for frontend to finish before returning *) -let try_capture (attributes: ProcAttributes.t) : ProcAttributes.t option = - let lazy cdb = compilation_db in +let try_capture (attributes : ProcAttributes.t) : ProcAttributes.t option = + let (lazy cdb) = compilation_db in ( if Option.is_none (Attributes.load_defined attributes.proc_name) then - let decl_file = attributes.loc.file in - let definition_file_opt = SourceFile.of_header decl_file in - let try_compile definition_file = - (* Use the cfg as a proxy to find out whether definition_file was already captured. If it + let decl_file = attributes.loc.file in + let definition_file_opt = SourceFile.of_header decl_file in + let try_compile definition_file = + (* Use the cfg as a proxy to find out whether definition_file was already captured. If it was, there is no point in trying to capture it again. Treat existance of the cfg as a barrier - if it exists it means that all attributes files have been created - write logic is defined in Cfg.store *) - if not (SourceFiles.is_captured decl_file) then ( - L.(debug Capture Verbose) "Started capture of %a...@\n" SourceFile.pp definition_file ; - Timeout.suspend_existing_timeout ~keep_symop_total:true ; - protect - ~f:(fun () -> CaptureCompilationDatabase.capture_file_in_database cdb definition_file) - ~finally:Timeout.resume_previous_timeout ; - if Config.debug_mode && Option.is_none (Attributes.load_defined attributes.proc_name) - then - (* peek at the results to know if capture succeeded, but only in debug mode *) - L.(debug Capture Verbose) - "Captured file %a to get procedure %a but it wasn't found there@\n" SourceFile.pp - definition_file Typ.Procname.pp attributes.proc_name ) - else + if not (SourceFiles.is_captured decl_file) then ( + L.(debug Capture Verbose) "Started capture of %a...@\n" SourceFile.pp definition_file ; + Timeout.suspend_existing_timeout ~keep_symop_total:true ; + protect + ~f:(fun () -> CaptureCompilationDatabase.capture_file_in_database cdb definition_file) + ~finally:Timeout.resume_previous_timeout ; + if Config.debug_mode && Option.is_none (Attributes.load_defined attributes.proc_name) then + (* peek at the results to know if capture succeeded, but only in debug mode *) L.(debug Capture Verbose) - "Wanted to capture file %a to get procedure %a but file was already captured@\n" - SourceFile.pp definition_file Typ.Procname.pp attributes.proc_name - in - match definition_file_opt with - | None -> - L.(debug Capture Medium) - "Couldn't find source file for %a (declared in %a)@\n" Typ.Procname.pp - attributes.proc_name SourceFile.pp decl_file - | Some file -> - try_compile file ) ; + "Captured file %a to get procedure %a but it wasn't found there@\n" SourceFile.pp + definition_file Typ.Procname.pp attributes.proc_name ) + else + L.(debug Capture Verbose) + "Wanted to capture file %a to get procedure %a but file was already captured@\n" + SourceFile.pp definition_file Typ.Procname.pp attributes.proc_name + in + match definition_file_opt with + | None -> + L.(debug Capture Medium) + "Couldn't find source file for %a (declared in %a)@\n" Typ.Procname.pp + attributes.proc_name SourceFile.pp decl_file + | Some file -> + try_compile file ) ; (* It's important to call load_defined_attributes again in all cases to make sure we try reading from disk again no matter which condition happened. If previous call to load_defined_attributes is None, it may mean couple of things: diff --git a/infer/src/backend/PerfStats.ml b/infer/src/backend/PerfStats.ml index a0f9b88dc..a8d4afbb0 100644 --- a/infer/src/backend/PerfStats.ml +++ b/infer/src/backend/PerfStats.ml @@ -266,7 +266,7 @@ let compute_mem_stats () = (stats, mem) -let compute_time_stats ?rtime_counter (initial_times: Unix.process_times) = +let compute_time_stats ?rtime_counter (initial_times : Unix.process_times) = let exit_times = Unix.times () in let rtime_span = Mtime_clock.elapsed () in let rtime = diff --git a/infer/src/backend/Procedures.ml b/infer/src/backend/Procedures.ml index 0b7f70b0b..135a1ea71 100644 --- a/infer/src/backend/Procedures.ml +++ b/infer/src/backend/Procedures.ml @@ -10,8 +10,8 @@ module F = Format let get_all ~filter () = let db = ResultsDatabase.get_database () in let stmt = Sqlite3.prepare db "SELECT source_file, proc_name FROM procedures" in - SqliteUtils.result_fold_rows db ~log:"reading all procedure names" stmt ~init:[] ~f: - (fun rev_results stmt -> + SqliteUtils.result_fold_rows db ~log:"reading all procedure names" stmt ~init:[] + ~f:(fun rev_results stmt -> let source_file = Sqlite3.column stmt 0 |> SourceFile.SQLite.deserialize in let proc_name = Sqlite3.column stmt 1 |> Typ.Procname.SQLite.deserialize in if filter source_file proc_name then proc_name :: rev_results else rev_results ) @@ -20,7 +20,7 @@ let get_all ~filter () = let pp_all ~filter ~proc_name:proc_name_cond ~attr_kind ~source_file:source_file_cond ~proc_attributes fmt () = let db = ResultsDatabase.get_database () in - let pp_if ?(new_line= false) condition title pp fmt x = + let pp_if ?(new_line = false) condition title pp fmt x = if condition then ( if new_line then F.fprintf fmt "@[" else F.fprintf fmt "@[" ; F.fprintf fmt "%s:@ %a@]@;" title pp x ) @@ -31,7 +31,7 @@ let pp_all ~filter ~proc_name:proc_name_cond ~attr_kind ~source_file:source_file pp_if ?new_line condition title pp fmt (Sqlite3.column stmt column |> deserialize) in let pp_row stmt fmt source_file proc_name = - let[@warning "-8"] Sqlite3.Data.TEXT proc_name_hum = Sqlite3.column stmt 1 in + let[@warning "-8"] (Sqlite3.Data.TEXT proc_name_hum) = Sqlite3.column stmt 1 in Format.fprintf fmt "@[%s@,%a%a%a%a@]@\n" proc_name_hum (pp_if source_file_cond "source_file" SourceFile.pp) source_file @@ -47,8 +47,8 @@ let pp_all ~filter ~proc_name:proc_name_cond ~attr_kind ~source_file:source_file (* we could also register this statement but it's typically used only once per run so just prepare it inside the function *) Sqlite3.prepare db "SELECT * FROM procedures" - |> Container.iter ~fold:(SqliteUtils.result_fold_rows db ~log:"print all procedures") ~f: - (fun stmt -> + |> Container.iter ~fold:(SqliteUtils.result_fold_rows db ~log:"print all procedures") + ~f:(fun stmt -> let proc_name = Sqlite3.column stmt 0 |> Typ.Procname.SQLite.deserialize in let source_file = Sqlite3.column stmt 3 |> SourceFile.SQLite.deserialize in if filter source_file proc_name then pp_row stmt fmt source_file proc_name ) diff --git a/infer/src/backend/Procedures.mli b/infer/src/backend/Procedures.mli index 9c2914cc0..224b1849e 100644 --- a/infer/src/backend/Procedures.mli +++ b/infer/src/backend/Procedures.mli @@ -10,5 +10,11 @@ open! IStd val get_all : filter:Filtering.procedures_filter -> unit -> Typ.Procname.t list val pp_all : - filter:Filtering.procedures_filter -> proc_name:bool -> attr_kind:bool -> source_file:bool - -> proc_attributes:bool -> Format.formatter -> unit -> unit + filter:Filtering.procedures_filter + -> proc_name:bool + -> attr_kind:bool + -> source_file:bool + -> proc_attributes:bool + -> Format.formatter + -> unit + -> unit diff --git a/infer/src/backend/StatsAggregator.ml b/infer/src/backend/StatsAggregator.ml index 22b1c81a4..d21a036e6 100644 --- a/infer/src/backend/StatsAggregator.ml +++ b/infer/src/backend/StatsAggregator.ml @@ -14,8 +14,11 @@ let aggregated_stats_by_target_filename = "aggregated_stats_by_target.json" let json_files_to_ignore_regex = Str.regexp - ( ".*\\(" ^ Str.quote aggregated_stats_filename ^ "\\|" - ^ Str.quote aggregated_stats_by_target_filename ^ "\\)$" ) + ( ".*\\(" + ^ Str.quote aggregated_stats_filename + ^ "\\|" + ^ Str.quote aggregated_stats_by_target_filename + ^ "\\)$" ) let dir_exists dir = Sys.is_directory dir = `Yes @@ -24,7 +27,8 @@ let find_json_files_in_dir dir = let is_valid_json_file path = let s = Unix.lstat path in let json_regex = Str.regexp_case_fold ".*\\.json$" in - not (Str.string_match json_files_to_ignore_regex path 0) && Str.string_match json_regex path 0 + (not (Str.string_match json_files_to_ignore_regex path 0)) + && Str.string_match json_regex path 0 && Polymorphic_compare.( = ) s.st_kind Unix.S_REG in match dir_exists dir with @@ -63,7 +67,8 @@ let load_data_from_infer_deps file = Error (error "malformed input") in let parse_lines lines = List.map lines ~f:extract_target_and_path |> Result.all in - Utils.read_file file |> Result.map_error ~f:(fun msg -> error "%s" msg) + Utils.read_file file + |> Result.map_error ~f:(fun msg -> error "%s" msg) |> Result.bind ~f:parse_lines diff --git a/infer/src/backend/Summary.ml b/infer/src/backend/Summary.ml index a2f0793be..6a17cc763 100644 --- a/infer/src/backend/Summary.ml +++ b/infer/src/backend/Summary.ml @@ -36,7 +36,7 @@ module Stats = struct let nb_visited_re {nodes_visited_re} = IntSet.cardinal nodes_visited_re - let update ?(add_symops= 0) ?failure_kind stats = + let update ?(add_symops = 0) ?failure_kind stats = let symops = stats.symops + add_symops in let failure_kind = match failure_kind with None -> stats.failure_kind | some -> some in {stats with symops; failure_kind} @@ -139,7 +139,7 @@ let pp_html source color fmt summary = (** Add the summary to the table for the given function *) -let add (proc_name: Typ.Procname.t) (summary: t) : unit = +let add (proc_name : Typ.Procname.t) (summary : t) : unit = Typ.Procname.Hash.replace cache proc_name summary @@ -228,7 +228,7 @@ let proc_resolve_attributes proc_name = (** Save summary for the procedure into the spec database *) -let store (summ: t) = +let store (summ : t) = let final_summary = {summ with status= Status.Analyzed} in let proc_name = get_proc_name final_summary in (* Make sure the summary in memory is identical to the saved one *) diff --git a/infer/src/backend/Tasks.ml b/infer/src/backend/Tasks.ml index de2cdd7b4..679677978 100644 --- a/infer/src/backend/Tasks.ml +++ b/infer/src/backend/Tasks.ml @@ -10,7 +10,7 @@ module L = Logging type 'a doer = 'a -> unit -let run_sequentially ~(f: 'a doer) (tasks: 'a list) : unit = +let run_sequentially ~(f : 'a doer) (tasks : 'a list) : unit = let task_bar = TaskBar.create ~jobs:1 in (ProcessPoolState.update_status := fun t status -> diff --git a/infer/src/backend/callbacks.ml b/infer/src/backend/callbacks.ml index d4c3db470..28438f049 100644 --- a/infer/src/backend/callbacks.ml +++ b/infer/src/backend/callbacks.ml @@ -32,11 +32,11 @@ let procedure_callbacks = ref [] let cluster_callbacks = ref [] -let register_procedure_callback ?(dynamic_dispatch= false) language (callback: proc_callback_t) = +let register_procedure_callback ?(dynamic_dispatch = false) language (callback : proc_callback_t) = procedure_callbacks := {dynamic_dispatch; language; callback} :: !procedure_callbacks -let register_cluster_callback language (callback: cluster_callback_t) = +let register_cluster_callback language (callback : cluster_callback_t) = cluster_callbacks := {language; callback} :: !cluster_callbacks @@ -88,7 +88,7 @@ let iterate_cluster_callbacks all_procs exe_env source_file = !cluster_callbacks -let dump_duplicate_procs (exe_env: Exe_env.t) source_file procs = +let dump_duplicate_procs (exe_env : Exe_env.t) source_file procs = let duplicate_procs = List.filter_map procs ~f:(fun pname -> match Exe_env.get_proc_desc exe_env pname with @@ -96,7 +96,7 @@ let dump_duplicate_procs (exe_env: Exe_env.t) source_file procs = match Attributes.load pname with | Some {translation_unit; loc} when (* defined in another file *) - not (SourceFile.equal source_file translation_unit) + (not (SourceFile.equal source_file translation_unit)) && (* really defined in the current file and not in an include *) SourceFile.equal source_file loc.file -> Some (pname, translation_unit) @@ -122,7 +122,7 @@ let create_perf_stats_report source_file = (** Invoke all procedure and cluster callbacks on a given environment. *) -let analyze_file (exe_env: Exe_env.t) source_file = +let analyze_file (exe_env : Exe_env.t) source_file = let saved_language = !Language.curr_language in let analyze_ondemand summary proc_desc = iterate_procedure_callbacks exe_env summary proc_desc in (* Invoke procedure callbacks using on-demand analysis schedulling *) diff --git a/infer/src/backend/callbacks.mli b/infer/src/backend/callbacks.mli index b450ad71e..37aa0c992 100644 --- a/infer/src/backend/callbacks.mli +++ b/infer/src/backend/callbacks.mli @@ -24,9 +24,7 @@ type proc_callback_args = type proc_callback_t = proc_callback_args -> Summary.t type cluster_callback_args = - { procedures: (Tenv.t * Procdesc.t) list - ; source_file: SourceFile.t - ; exe_env: Exe_env.t } + {procedures: (Tenv.t * Procdesc.t) list; source_file: SourceFile.t; exe_env: Exe_env.t} type cluster_callback_t = cluster_callback_args -> unit diff --git a/infer/src/backend/crashcontext.ml b/infer/src/backend/crashcontext.ml index 6c075f814..90077f0e1 100644 --- a/infer/src/backend/crashcontext.ml +++ b/infer/src/backend/crashcontext.ml @@ -74,7 +74,8 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = (fun summaries path -> (* check if the file is a JSON file under the crashcontext dir *) if - Sys.is_directory path <> `Yes && Filename.check_suffix path "json" + Sys.is_directory path <> `Yes + && Filename.check_suffix path "json" && String.is_suffix ~suffix:"crashcontext" (Filename.dirname path) then path :: summaries else summaries ) @@ -86,14 +87,15 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = None | Some file -> let crashcontext_dir = Config.results_dir ^/ "crashcontext" in - Utils.create_dir crashcontext_dir ; Some (file, crashcontext_dir ^/ "crashcontext.json") + Utils.create_dir crashcontext_dir ; + Some (file, crashcontext_dir ^/ "crashcontext.json") in let trace_file_regexp = Str.regexp "\\(.*\\)\\.json" in let pairs_for_stactrace_dir = match stacktraces_dir with | None -> [] - | Some s -> + | Some s -> ( let dir = DB.filename_from_string s in let trace_file_matcher path = let path_str = DB.filename_to_string path in @@ -110,7 +112,7 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = DB.fold_paths_matching statement below, so we don't need to call Str.string_match again. *) | Caml.Not_found - -> assert false + -> assert false ) in let input_output_file_pairs = match pair_for_stacktrace_file with diff --git a/infer/src/backend/dotty.ml b/infer/src/backend/dotty.ml index 8a213df70..4baa7184e 100644 --- a/infer/src/backend/dotty.ml +++ b/infer/src/backend/dotty.ml @@ -45,7 +45,7 @@ type link = {kind: kind_of_links; src: coordinate; src_fld: string; trg: coordinate; trg_fld: string} [@@deriving compare] -let equal_link = [%compare.equal : link] +let equal_link = [%compare.equal: link] (* type of the visualized boxes/nodes in the graph*) type dotty_node = @@ -247,7 +247,7 @@ let reset_proposition_counter () = proposition_counter := 0 let reset_dotty_spec_counter () = spec_counter := 0 -let color_to_str (c: Pp.color) = +let color_to_str (c : Pp.color) = match c with | Black -> "black" @@ -261,8 +261,8 @@ let color_to_str (c: Pp.color) = "red" -let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list) = - let exp_color hpred (exp: Exp.t) = +let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) list) = + let exp_color hpred (exp : Exp.t) = if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red else pe.Pp.cmap_norm (Obj.repr exp) in @@ -271,7 +271,8 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list incr dotty_state_count ; let coo = mk_coordinate n lambda in match hpred with - | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when not (Exp.equal e Exp.zero) && !print_full_prop -> + | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop + -> let e_color_str = color_to_str (exp_color hpred e) in [Dotdangling (coo, e, e_color_str)] | Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) -> @@ -370,7 +371,7 @@ let rec dotty_mk_node pe sigma = | [] -> [] | (hpred, lambda) :: sigma' -> - let exp_color (exp: Exp.t) = + let exp_color (exp : Exp.t) = if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red else pe.Pp.cmap_norm (Obj.repr exp) in @@ -474,8 +475,7 @@ let node_in_cycle cycle node = let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = let find_target_one_fld (fn, se) = match se with - | Sil.Eexp (e, _) - -> ( + | Sil.Eexp (e, _) -> ( if is_nil e p then let n' = make_nil_node lambda in if !print_full_prop then [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] else [] @@ -520,8 +520,7 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = let rec compute_target_array_elements dotnodes list_elements p f lambda = let find_target_one_element (idx, se) = match se with - | Sil.Eexp (e, _) - -> ( + | Sil.Eexp (e, _) -> ( if is_nil e p then let n' = make_nil_node lambda in [(LinkArrayToExp, Exp.to_string idx, n', "")] @@ -598,15 +597,14 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = let lnk = mk_link LinkToArray (mk_coordinate n lambda) "" (mk_coordinate (n + 1) lambda) trg_label in - lnk :: links_from_elements @ dotty_mk_set_links dotnodes sigma' p f cycle + (lnk :: links_from_elements) @ dotty_mk_set_links dotnodes sigma' p f cycle in match sigma with | [] -> [] | (Sil.Hpointsto (e, Sil.Earray (_, lie, _), _), lambda) :: sigma' -> make_links_for_arrays e lie lambda sigma' - | (Sil.Hpointsto (e, Sil.Estruct (lfld, _), _), lambda) :: sigma' - -> ( + | (Sil.Hpointsto (e, Sil.Estruct (lfld, _), _), lambda) :: sigma' -> ( let src = look_up dotnodes e lambda in match src with | [] -> @@ -639,8 +637,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = in lnk_from_address_struct @ links_from_fields @ dotty_mk_set_links dotnodes sigma' p f cycle ) - | (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda) :: sigma' - -> ( + | (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda) :: sigma' -> ( let src = look_up dotnodes e lambda in match src with | [] -> @@ -658,8 +655,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = let ll = List.concat_map ~f:ff nl in ll @ dotty_mk_set_links dotnodes sigma' p f cycle else dotty_mk_set_links dotnodes sigma' p f cycle ) - | (Sil.Hlseg (_, _, e1, e2, _), lambda) :: sigma' - -> ( + | (Sil.Hlseg (_, _, e1, e2, _), lambda) :: sigma' -> ( let src = look_up dotnodes e1 lambda in match src with | [] -> @@ -670,7 +666,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in lnk :: dotty_mk_set_links dotnodes sigma' p f cycle ) - | (Sil.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' -> + | (Sil.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' -> ( let src = look_up dotnodes e1 lambda in match src with | [] -> @@ -693,7 +689,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = | m :: _ -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""] in - target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f cycle + target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f cycle ) let print_kind f kind = @@ -709,7 +705,7 @@ let print_kind f kind = F.fprintf f "@\n POST%iL0 [label=\"POST %i \", style=filled, color= yellow]@\n" !dotty_state_count !post_counter ; print_stack_info := true - | Lambda_pred (no, lev, array) -> + | Lambda_pred (no, lev, array) -> ( match array with | false -> F.fprintf f "%s @\n state%iL%i [label=\"INTERNAL STRUCTURE %i \", %s]@\n" @@ -723,7 +719,7 @@ let print_kind f kind = "style=filled, color= lightblue" ; (* F.fprintf f "state%iL%i -> struct%iL%i:%s [color=\"lightblue \" arrowhead=none] @\n" !dotty_state_count !lambda_counter no lev lab;*) - incr dotty_state_count + incr dotty_state_count ) (* print a link between two nodes in the graph *) @@ -764,7 +760,7 @@ let dotty_pp_link f link = (* given the list of nodes and links get rid of spec nodes that are not pointed to by anybody*) -let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) = +let filter_useless_spec_dollar_box (nodes : dotty_node list) (links : link list) = let tmp_nodes = ref nodes in let tmp_links = ref links in let remove_links_from ln = @@ -825,8 +821,7 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) = let rec print_struct f pe e te l coo c = let print_type = match te with - | Exp.Sizeof {typ} - -> ( + | Exp.Sizeof {typ} -> ( let str_t = Typ.to_string typ in match Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) str_t with | [_; _] -> @@ -887,7 +882,8 @@ and print_sll f pe nesting k e1 coo = F.fprintf f "state%iL%i [label=\" \"] @\n" (n + 1) lambda ; F.fprintf f "state%iL%i -> state%iL%i [label=\" \"] }" n' lambda (n + 1) lambda ; incr lambda_counter ; - pp_dotty f (Lambda_pred (n + 1, lambda, false)) + pp_dotty f + (Lambda_pred (n + 1, lambda, false)) (Prop.normalize (Tenv.create ()) (Prop.from_sigma nesting)) None @@ -914,7 +910,8 @@ and print_dll f pe nesting k e1 e4 coo = F.fprintf f "state%iL%i -> state%iL%i [label=\" \"]@\n" (n + 1) lambda n' lambda ; F.fprintf f "state%iL%i -> state%iL%i [label=\" \"]}@\n" n' lambda (n + 1) lambda ; incr lambda_counter ; - pp_dotty f (Lambda_pred (n', lambda, false)) + pp_dotty f + (Lambda_pred (n', lambda, false)) (Prop.normalize (Tenv.create ()) (Prop.from_sigma nesting)) None @@ -997,7 +994,7 @@ and display_pure_info f pe prop = (** Pretty print a proposition in dotty format. *) -and pp_dotty f kind (prop_: Prop.normal Prop.t) cycle = +and pp_dotty f kind (prop_ : Prop.normal Prop.t) cycle = incr proposition_counter ; let pe, prop = match kind with @@ -1068,7 +1065,7 @@ let pp_dotty_one_spec f pre posts = (********** Print control flow graph (in dot form) for fundec to channel. You have to compute an interprocedural cfg first. *) -let pp_cfgnodename pname fmt (n: Procdesc.Node.t) = +let pp_cfgnodename pname fmt (n : Procdesc.Node.t) = F.fprintf fmt "\"%s_%d\"" (Escape.escape_dotty (Typ.Procname.to_filename pname)) (Procdesc.Node.get_id n :> int) @@ -1092,7 +1089,7 @@ let pp_var_list fmt etl = let pp_local_list fmt etl = List.iter ~f:(Procdesc.pp_local fmt) etl -let pp_cfgnodelabel pdesc fmt (n: Procdesc.Node.t) = +let pp_cfgnodelabel pdesc fmt (n : Procdesc.Node.t) = let pp_label fmt n = match Procdesc.Node.get_kind n with | Procdesc.Node.Start_node pname -> @@ -1129,7 +1126,7 @@ let pp_cfgnodelabel pdesc fmt (n: Procdesc.Node.t) = F.fprintf fmt "%d: %a \\n %a" (Procdesc.Node.get_id n :> int) pp_label n pp_instrs instrs -let pp_cfgnodeshape fmt (n: Procdesc.Node.t) = +let pp_cfgnodeshape fmt (n : Procdesc.Node.t) = match Procdesc.Node.get_kind n with | Procdesc.Node.Start_node _ | Procdesc.Node.Exit_node _ -> F.pp_print_string fmt "color=yellow style=filled" @@ -1143,7 +1140,7 @@ let pp_cfgnodeshape fmt (n: Procdesc.Node.t) = () -let pp_cfgnode pdesc fmt (n: Procdesc.Node.t) = +let pp_cfgnode pdesc fmt (n : Procdesc.Node.t) = let pname = Procdesc.get_proc_name pdesc in F.fprintf fmt "%a [label=\"%a\" %a]@\n\t@\n" (pp_cfgnodename pname) n (pp_cfgnodelabel pdesc) n pp_cfgnodeshape n ; @@ -1207,7 +1204,7 @@ let print_icfg_dotty source cfg = (********** END of Printing dotty files ***********) (** Dotty printing for specs *) -let pp_speclist_dotty f (splist: Prop.normal BiabductionSummary.spec list) = +let pp_speclist_dotty f (splist : Prop.normal BiabductionSummary.spec list) = let pp_simple_saved = !Config.pp_simple in Config.pp_simple := true ; reset_proposition_counter () ; @@ -1225,7 +1222,7 @@ let pp_speclist_dotty f (splist: Prop.normal BiabductionSummary.spec list) = Config.pp_simple := pp_simple_saved -let pp_speclist_to_file (filename: DB.filename) spec_list = +let pp_speclist_to_file (filename : DB.filename) spec_list = let pp_simple_saved = !Config.pp_simple in Config.pp_simple := true ; let outc = Out_channel.create (DB.filename_to_string (DB.filename_add_suffix filename ".dot")) in @@ -1235,5 +1232,5 @@ let pp_speclist_to_file (filename: DB.filename) spec_list = Config.pp_simple := pp_simple_saved -let pp_speclist_dotty_file (filename: DB.filename) spec_list = +let pp_speclist_dotty_file (filename : DB.filename) spec_list = try pp_speclist_to_file filename spec_list with exn when SymOp.exn_not_failure exn -> () diff --git a/infer/src/backend/errdesc.ml b/infer/src/backend/errdesc.ml index 5a05351aa..35802a3fd 100644 --- a/infer/src/backend/errdesc.ml +++ b/infer/src/backend/errdesc.ml @@ -73,8 +73,8 @@ let verbose = Config.trace_error (** Find the function call instruction used to initialize normal variable [id], and return the function name and arguments *) -let find_normal_variable_funcall (node: Procdesc.Node.t) (id: Ident.t) - : (Exp.t * Exp.t list * Location.t * CallFlags.t) option = +let find_normal_variable_funcall (node : Procdesc.Node.t) (id : Ident.t) : + (Exp.t * Exp.t list * Location.t * CallFlags.t) option = let find_declaration _ = function | Sil.Call ((id0, _), fun_exp, args, loc, call_flags) when Ident.equal id id0 -> Some (fun_exp, List.map ~f:fst args, loc, call_flags) @@ -93,7 +93,8 @@ let find_normal_variable_funcall (node: Procdesc.Node.t) (id: Ident.t) (** Find a program variable assignment in the current node or predecessors. *) let find_program_variable_assignment node pvar : (Procdesc.Node.t * Ident.t) option = let find_instr node = function - | Sil.Store (Exp.Lvar pvar_, _, Exp.Var id, _) when Pvar.equal pvar pvar_ && Ident.is_normal id -> + | Sil.Store (Exp.Lvar pvar_, _, Exp.Var id, _) when Pvar.equal pvar pvar_ && Ident.is_normal id + -> Some (node, id) | _ -> None @@ -155,7 +156,7 @@ let rec find_boolean_assignment node pvar true_branch : Procdesc.Node.t option = (** Find the Load instruction used to declare normal variable [id], and return the expression dereferenced to initialize [id] *) -let rec find_normal_variable_load_ tenv (seen: Exp.Set.t) node id : DExp.t option = +let rec find_normal_variable_load_ tenv (seen : Exp.Set.t) node id : DExp.t option = let find_declaration node = function | Sil.Load (id0, e, _, _) when Ident.equal id id0 -> if verbose then ( @@ -206,7 +207,7 @@ let rec find_normal_variable_load_ tenv (seen: Exp.Set.t) node id : DExp.t optio (** describe lvalue [e] as a dexp *) -and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = +and exp_lv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option = if Exp.Set.mem e seen_ then ( L.d_str "exp_lv_dexp: cycle detected" ; Sil.d_exp e ; @@ -218,8 +219,7 @@ and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = | Exp.Const c -> if verbose then ( L.d_str "exp_lv_dexp: constant " ; Sil.d_exp e ; L.d_ln () ) ; Some (DExp.Dderef (DExp.Dconst c)) - | Exp.BinOp (Binop.PlusPI, e1, e2) - -> ( + | Exp.BinOp (Binop.PlusPI, e1, e2) -> ( if verbose then ( L.d_str "exp_lv_dexp: (e1 +PI e2) " ; Sil.d_exp e ; @@ -229,8 +229,7 @@ and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = Some (DExp.Dbinop (Binop.PlusPI, de1, de2)) | _ -> None ) - | Exp.Var id when Ident.is_normal id - -> ( + | Exp.Var id when Ident.is_normal id -> ( if verbose then ( L.d_str "exp_lv_dexp: normal var " ; Sil.d_exp e ; @@ -253,7 +252,7 @@ and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = Some (DExp.Dfcall (DExp.Dconst (Cfun pname), [], loc, call_flags)) | None -> None ) - | Some (node', id) -> + | Some (node', id) -> ( match find_normal_variable_funcall node' id with | Some (fun_exp, eargs, loc, call_flags) -> let fun_dexpo = exp_rv_dexp_ tenv seen node' fun_exp in @@ -264,10 +263,9 @@ and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = let args = List.map ~f:unNone blame_args in Some (DExp.Dfcall (unNone fun_dexpo, args, loc, call_flags)) | None -> - exp_rv_dexp_ tenv seen node' (Exp.Var id) + exp_rv_dexp_ tenv seen node' (Exp.Var id) ) else Some (DExp.Dpvar pvar) - | Exp.Lfield (Exp.Var id, f, _) when Ident.is_normal id - -> ( + | Exp.Lfield (Exp.Var id, f, _) when Ident.is_normal id -> ( if verbose then ( L.d_str "exp_lv_dexp: Lfield with var " ; Sil.d_exp (Exp.Var id) ; @@ -278,8 +276,7 @@ and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = None | Some de -> Some (DExp.Darrow (de, f)) ) - | Exp.Lfield (e1, f, _) - -> ( + | Exp.Lfield (e1, f, _) -> ( if verbose then ( L.d_str "exp_lv_dexp: Lfield " ; Sil.d_exp e1 ; @@ -290,8 +287,7 @@ and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = None | Some de -> Some (DExp.Ddot (de, f)) ) - | Exp.Lindex (e1, e2) - -> ( + | Exp.Lindex (e1, e2) -> ( if verbose then ( L.d_str "exp_lv_dexp: Lindex " ; Sil.d_exp e1 ; L.d_str " " ; Sil.d_exp e2 ; L.d_ln () ) ; match (exp_lv_dexp_ tenv seen node e1, exp_rv_dexp_ tenv seen node e2) with @@ -311,7 +307,7 @@ and exp_lv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = (** describe rvalue [e] as a dexp *) -and exp_rv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = +and exp_rv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option = if Exp.Set.mem e seen_ then ( L.d_str "exp_rv_dexp: cycle detected" ; Sil.d_exp e ; @@ -337,8 +333,7 @@ and exp_rv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = Sil.d_exp e ; L.d_ln () ) ; find_normal_variable_load_ tenv seen node id - | Exp.Lfield (e1, f, _) - -> ( + | Exp.Lfield (e1, f, _) -> ( if verbose then ( L.d_str "exp_rv_dexp: Lfield " ; Sil.d_exp e1 ; @@ -349,8 +344,7 @@ and exp_rv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = None | Some de -> Some (DExp.Ddot (de, f)) ) - | Exp.Lindex (e1, e2) - -> ( + | Exp.Lindex (e1, e2) -> ( if verbose then ( L.d_str "exp_rv_dexp: Lindex " ; Sil.d_exp e1 ; L.d_str " " ; Sil.d_exp e2 ; L.d_ln () ) ; match (exp_rv_dexp_ tenv seen node e1, exp_rv_dexp_ tenv seen node e2) with @@ -358,16 +352,14 @@ and exp_rv_dexp_ tenv (seen_: Exp.Set.t) node e : DExp.t option = None | Some de1, Some de2 -> Some (DExp.Darray (de1, de2)) ) - | Exp.BinOp (op, e1, e2) - -> ( + | Exp.BinOp (op, e1, e2) -> ( if verbose then ( L.d_str "exp_rv_dexp: BinOp " ; Sil.d_exp e ; L.d_ln () ) ; match (exp_rv_dexp_ tenv seen node e1, exp_rv_dexp_ tenv seen node e2) with | None, _ | _, None -> None | Some de1, Some de2 -> Some (DExp.Dbinop (op, de1, de2)) ) - | Exp.UnOp (op, e1, _) - -> ( + | Exp.UnOp (op, e1, _) -> ( if verbose then ( L.d_str "exp_rv_dexp: UnOp " ; Sil.d_exp e ; L.d_ln () ) ; match exp_rv_dexp_ tenv seen node e1 with | None -> @@ -496,7 +488,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = let is_file = match resource_opt with Some PredSymb.Rfile -> true | _ -> false in let check_pvar pvar = (* check that pvar is local or global and has the same type as the leaked hpred *) - (Pvar.is_local pvar || Pvar.is_global pvar) && not (Pvar.is_frontend_tmp pvar) + (Pvar.is_local pvar || Pvar.is_global pvar) + && (not (Pvar.is_frontend_tmp pvar)) && match (hpred_typ_opt, find_typ_without_ptr prop pvar) with | Some (Exp.Sizeof {typ= t1}), Some (Exp.Sizeof {typ= {Typ.desc= Tptr (t2, _)}}) -> @@ -515,8 +508,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = L.d_str "explain_leak: no current instruction" ; L.d_ln () ) ; value_str_from_pvars_vpath [] vpath - | Some (Sil.Nullify (pvar, _)) when check_pvar pvar - -> ( + | Some (Sil.Nullify (pvar, _)) when check_pvar pvar -> ( if verbose then ( L.d_str "explain_leak: current instruction is Nullify for pvar " ; Pvar.d pvar ; @@ -547,8 +539,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = List.rev_filter ~f:(fun pvar -> not (Pvar.is_frontend_tmp pvar)) rev_nullify_pvars in value_str_from_pvars_vpath nullify_pvars_notmp vpath - | Some (Sil.Store (lexp, _, _, _)) when is_none vpath - -> ( + | Some (Sil.Store (lexp, _, _, _)) when is_none vpath -> ( if verbose then ( L.d_str "explain_leak: current instruction Set for " ; Sil.d_exp lexp ; @@ -588,8 +579,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = let rec find sigma_acc sigma_todo exp = let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) = match se with - | Sil.Eexp (e, _) when Exp.equal exp e - -> ( + | Sil.Eexp (e, _) when Exp.equal exp e -> ( let sigma' = List.rev_append sigma_acc' sigma_todo' in match lexp with | Exp.Lvar pv -> @@ -622,8 +612,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = in let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with - | Sil.Eexp (e, _) when Exp.equal exp e - -> ( + | Sil.Eexp (e, _) when Exp.equal exp e -> ( let sigma' = List.rev_append sigma_acc' sigma_todo' in match lexp with | Exp.Lvar pv when not (Pvar.is_frontend_tmp pv) -> @@ -659,41 +648,41 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = List.exists ~f:filter (Sil.sub_to_list prop.Prop.sub) in function - | Sil.Hpointsto (Exp.Lvar pv, sexp, texp) - when Pvar.is_local pv || Pvar.is_global pv || Pvar.is_seed pv -> - do_sexp sigma_acc' sigma_todo' (Exp.Lvar pv) sexp texp - | Sil.Hpointsto (Exp.Var id, sexp, texp) - when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) -> - do_sexp sigma_acc' sigma_todo' (Exp.Var id) sexp texp - | _ -> - (None, None) + | Sil.Hpointsto (Exp.Lvar pv, sexp, texp) + when Pvar.is_local pv || Pvar.is_global pv || Pvar.is_seed pv -> + do_sexp sigma_acc' sigma_todo' (Exp.Lvar pv) sexp texp + | Sil.Hpointsto (Exp.Var id, sexp, texp) + when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) -> + do_sexp sigma_acc' sigma_todo' (Exp.Var id) sexp texp + | _ -> + (None, None) in match sigma_todo with | [] -> (None, None) - | hpred :: sigma_todo' -> + | hpred :: sigma_todo' -> ( match do_hpred sigma_acc sigma_todo' hpred with | Some de, typo -> (Some de, typo) | None, _ -> - find (hpred :: sigma_acc) sigma_todo' exp + find (hpred :: sigma_acc) sigma_todo' exp ) in let res = find [] prop.Prop.sigma exp_ in ( if verbose then - match res with - | None, _ -> - L.d_str "vpath_find: cannot find " ; - Sil.d_exp exp_ ; - L.d_ln () - | Some de, typo -> - L.d_str "vpath_find: found " ; - L.d_str (DExp.to_string de) ; - L.d_str " : " ; - match typo with None -> L.d_str " No type" | Some typ -> Typ.d_full typ ; L.d_ln () ) ; + match res with + | None, _ -> + L.d_str "vpath_find: cannot find " ; + Sil.d_exp exp_ ; + L.d_ln () + | Some de, typo -> ( + L.d_str "vpath_find: found " ; + L.d_str (DExp.to_string de) ; + L.d_str " : " ; + match typo with None -> L.d_str " No type" | Some typ -> Typ.d_full typ ; L.d_ln () ) ) ; res -let access_opt ?(is_nullable= false) inst = +let access_opt ?(is_nullable = false) inst = match inst with | Sil.Iupdate (_, ncf, n, _) -> Some (Localise.Last_assigned (n, ncf)) @@ -724,7 +713,7 @@ let explain_dexp_access prop dexp is_nullable = L.d_ln () ) ; None in - let find_ptsto (e: Exp.t) : Sil.strexp option = + let find_ptsto (e : Exp.t) : Sil.strexp option = let res = ref None in let do_hpred = function | Sil.Hpointsto (e', se, _) when Exp.equal e e' -> @@ -813,8 +802,7 @@ let explain_dexp_access prop dexp is_nullable = | DExp.Dbinop (Binop.PlusPI, DExp.Dpvar _, DExp.Dconst _) as de -> if verbose then L.d_strln ("lookup: case )pvar + constant) " ^ DExp.to_string de) ; None - | DExp.Dfcall (DExp.Dconst c, _, loc, _) - -> ( + | DExp.Dfcall (DExp.Dconst c, _, loc, _) -> ( if verbose then L.d_strln "lookup: found Dfcall " ; match c with | Const.Cfun _ -> @@ -873,8 +861,8 @@ let explain_dereference_access outermost_array is_nullable de_opt_ prop = (** Create a description of a dereference operation *) -let create_dereference_desc proc_name tenv ?(use_buckets= false) ?(outermost_array= false) - ?(is_nullable= false) ?(is_premature_nil= false) de_opt deref_str prop loc = +let create_dereference_desc proc_name tenv ?(use_buckets = false) ?(outermost_array = false) + ?(is_nullable = false) ?(is_premature_nil = false) de_opt deref_str prop loc = let value_str, access_opt = explain_dereference_access outermost_array is_nullable de_opt prop in let access_opt' = match access_opt with @@ -967,9 +955,9 @@ let rec find_outermost_dereference tenv node e = if outermost_array is true, the outermost array access is removed if outermost_dereference is true, stop at the outermost dereference (skipping e.g. outermost field access) *) -let explain_access_ proc_name tenv ?(use_buckets= false) ?(outermost_array= false) - ?(outermost_dereference= false) ?(is_nullable= false) ?(is_premature_nil= false) deref_str prop - loc = +let explain_access_ proc_name tenv ?(use_buckets = false) ?(outermost_array = false) + ?(outermost_dereference = false) ?(is_nullable = false) ?(is_premature_nil = false) deref_str + prop loc = let find_exp_dereferenced () = match State.get_instr () with | Some (Sil.Store (e, _, _, _)) -> @@ -1018,8 +1006,8 @@ let explain_access_ proc_name tenv ?(use_buckets= false) ?(outermost_array= fals (** Produce a description of which expression is dereferenced in the current instruction, if any. The subexpression to focus on is obtained by removing field and index accesses. *) -let explain_dereference proc_name tenv ?(use_buckets= false) ?(is_nullable= false) - ?(is_premature_nil= false) deref_str prop loc = +let explain_dereference proc_name tenv ?(use_buckets = false) ?(is_nullable = false) + ?(is_premature_nil = false) deref_str prop loc = explain_access_ proc_name tenv ~use_buckets ~outermost_array:false ~outermost_dereference:true ~is_nullable ~is_premature_nil deref_str prop loc @@ -1073,7 +1061,7 @@ let explain_nth_function_parameter proc_name tenv use_buckets deref_str prop n p let find_with_exp prop exp = let res = ref None in let found_in_pvar pv = - if not (Pvar.is_abduced pv) && not (Pvar.is_this pv) then res := Some (pv, Fpvar) + if (not (Pvar.is_abduced pv)) && not (Pvar.is_this pv) then res := Some (pv, Fpvar) in let found_in_struct pv fld_lst = (* found_in_pvar has priority *) @@ -1106,7 +1094,7 @@ let find_with_exp prop exp = (** return a description explaining value [exp] in [prop] in terms of a source expression using the formal parameters of the call *) -let explain_dereference_as_caller_expression proc_name tenv ?(use_buckets= false) deref_str +let explain_dereference_as_caller_expression proc_name tenv ?(use_buckets = false) deref_str actual_pre spec_pre exp node loc formal_params = let find_formal_param_number name = let rec find n = function diff --git a/infer/src/backend/errdesc.mli b/infer/src/backend/errdesc.mli index 0fc8eb359..4d2e61032 100644 --- a/infer/src/backend/errdesc.mli +++ b/infer/src/backend/errdesc.mli @@ -44,7 +44,13 @@ val explain_array_access : (** Produce a description of the array access performed in the current instruction, if any. *) val explain_class_cast_exception : - Tenv.t -> Typ.Procname.t option -> Exp.t -> Exp.t -> Exp.t -> Procdesc.Node.t -> Location.t + Tenv.t + -> Typ.Procname.t option + -> Exp.t + -> Exp.t + -> Exp.t + -> Procdesc.Node.t + -> Location.t -> Localise.error_desc (** explain a class cast exception *) @@ -55,13 +61,29 @@ val explain_deallocate_constant_string : string -> PredSymb.res_action -> Locali (** Explain a deallocate constant string error *) val explain_dereference : - Typ.Procname.t -> Tenv.t -> ?use_buckets:bool -> ?is_nullable:bool -> ?is_premature_nil:bool - -> Localise.deref_str -> 'a Prop.t -> Location.t -> Localise.error_desc + Typ.Procname.t + -> Tenv.t + -> ?use_buckets:bool + -> ?is_nullable:bool + -> ?is_premature_nil:bool + -> Localise.deref_str + -> 'a Prop.t + -> Location.t + -> Localise.error_desc (** Produce a description of which expression is dereferenced in the current instruction, if any. *) val explain_dereference_as_caller_expression : - Typ.Procname.t -> Tenv.t -> ?use_buckets:bool -> Localise.deref_str -> 'a Prop.t -> 'b Prop.t - -> Exp.t -> Procdesc.Node.t -> Location.t -> Pvar.t list -> Localise.error_desc + Typ.Procname.t + -> Tenv.t + -> ?use_buckets:bool + -> Localise.deref_str + -> 'a Prop.t + -> 'b Prop.t + -> Exp.t + -> Procdesc.Node.t + -> Location.t + -> Pvar.t list + -> Localise.error_desc (** return a description explaining value [exp] in [prop] in terms of a source expression using the formal parameters of the call *) @@ -87,7 +109,11 @@ val explain_unary_minus_applied_to_unsigned_expression : (** explain unary minus applied to unsigned expression *) val explain_leak : - Tenv.t -> Sil.hpred -> 'a Prop.t -> PredSymb.t option -> string option + Tenv.t + -> Sil.hpred + -> 'a Prop.t + -> PredSymb.t option + -> string option -> Exceptions.visibility * Localise.error_desc (** Produce a description of a leak by looking at the current state. If the current instruction is a variable nullify, blame the variable. diff --git a/infer/src/backend/exe_env.ml b/infer/src/backend/exe_env.ml index 4e810db5a..96cc48b24 100644 --- a/infer/src/backend/exe_env.ml +++ b/infer/src/backend/exe_env.ml @@ -84,7 +84,7 @@ let get_tenv exe_env proc_name = match proc_name with | Typ.Procname.Java _ -> Lazy.force java_global_tenv - | _ -> + | _ -> ( match get_file_data exe_env proc_name with | Some file_data -> ( match file_data_to_tenv file_data with @@ -99,7 +99,7 @@ let get_tenv exe_env proc_name = let loc = State.get_loc () in L.(die InternalError) "get_tenv: file_data not found for %a in file '%a' at %a" Typ.Procname.pp proc_name - SourceFile.pp loc.Location.file Location.pp loc + SourceFile.pp loc.Location.file Location.pp loc ) (** return the cfg associated to the procedure *) diff --git a/infer/src/backend/inferconfig.ml b/infer/src/backend/inferconfig.ml index 50c70aedb..2607ee8ab 100644 --- a/infer/src/backend/inferconfig.ml +++ b/infer/src/backend/inferconfig.ml @@ -45,7 +45,7 @@ let is_matching patterns source_file = (** Check if a proc name is matching the name given as string. *) let match_method language proc_name method_name = - not (BuiltinDecl.is_declared proc_name) + (not (BuiltinDecl.is_declared proc_name)) && Language.equal (Typ.Procname.get_language proc_name) language && String.equal (Typ.Procname.get_method proc_name) method_name @@ -73,14 +73,14 @@ module FileContainsStringMatcher = struct let source_map = ref SourceFile.Map.empty in let regexp = Str.regexp (String.concat ~sep:"\\|" s_patterns) in fun source_file -> - try SourceFile.Map.find source_file !source_map with Caml.Not_found -> + try SourceFile.Map.find source_file !source_map with Caml.Not_found -> ( try let file_in = In_channel.create (SourceFile.to_abs_path source_file) in let pattern_found = file_contains regexp file_in in In_channel.close file_in ; source_map := SourceFile.Map.add source_file pattern_found !source_map ; pattern_found - with Sys_error _ -> false + with Sys_error _ -> false ) end type method_pattern = {class_name: string; method_name: string option} @@ -220,7 +220,7 @@ let patterns_of_json_with_key (json_key, json) = error in (* Translate a JSON entry into a matching pattern *) - let create_pattern (assoc: (string * Yojson.Basic.json) list) = + let create_pattern (assoc : (string * Yojson.Basic.json) list) = let create_method_pattern assoc = let loop mp = function | key, `String s when String.equal key "class" -> @@ -308,9 +308,10 @@ let filters_from_inferconfig inferconfig : filters = FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing in function - | source_file -> - whitelist_filter source_file && not (blacklist_filter source_file) - && not (blacklist_files_containing_filter source_file) + | source_file -> + whitelist_filter source_file + && (not (blacklist_filter source_file)) + && not (blacklist_files_containing_filter source_file) in let error_filter = function | error_name -> diff --git a/infer/src/backend/mergeCapture.ml b/infer/src/backend/mergeCapture.ml index e00201b07..458db6244 100644 --- a/infer/src/backend/mergeCapture.ml +++ b/infer/src/backend/mergeCapture.ml @@ -89,7 +89,7 @@ let should_link ~target ~target_results_dir ~stats infer_out_src infer_out_dst = ~f:(fun file -> let file_path = Filename.concat captured_file file in Sys.file_exists file_path = `Yes - && (not check_timestamp_of_symlinks || symlink_up_to_date file_path) ) + && ((not check_timestamp_of_symlinks) || symlink_up_to_date file_path) ) contents else true in diff --git a/infer/src/backend/ondemand.ml b/infer/src/backend/ondemand.ml index 2664708cc..987bebf0e 100644 --- a/infer/src/backend/ondemand.ml +++ b/infer/src/backend/ondemand.ml @@ -20,7 +20,7 @@ let callbacks_ref = ref None let cached_results = lazy (Typ.Procname.Hash.create 128) -let set_callbacks (callbacks: callbacks) = callbacks_ref := Some callbacks +let set_callbacks (callbacks : callbacks) = callbacks_ref := Some callbacks let unset_callbacks () = callbacks_ref := None @@ -60,7 +60,8 @@ let should_be_analyzed proc_name proc_attributes = | None -> false in - should_create_summary proc_name proc_attributes && not (is_active proc_name) + should_create_summary proc_name proc_attributes + && (not (is_active proc_name)) && (* avoid infinite loops *) not (already_analyzed proc_name) @@ -148,7 +149,7 @@ let run_proc_analysis analyze_proc ~caller_pdesc callee_pdesc = log_elapsed_time () ; summary in - let log_error_and_continue exn (summary: Summary.t) kind = + let log_error_and_continue exn (summary : Summary.t) kind = let loc = State.get_loc () in Reporting.log_error summary ~loc exn ; let stats = Summary.Stats.update summary.stats ~failure_kind:kind in @@ -172,7 +173,7 @@ let run_proc_analysis analyze_proc ~caller_pdesc callee_pdesc = in let final_summary = postprocess summary in restore_global_state old_state ; final_summary - with exn -> + with exn -> ( IExn.reraise_if exn ~f:(fun () -> restore_global_state old_state ; not Config.keep_going) ; L.internal_error "@\nERROR RUNNING BACKEND: %a %s@\n@\nBACK TRACE@\n%s@?" Typ.Procname.pp callee_pname (Exn.to_string exn) (Printexc.get_backtrace ()) ; @@ -183,7 +184,7 @@ let run_proc_analysis analyze_proc ~caller_pdesc callee_pdesc = log_error_and_continue exn initial_summary kind | _ -> (* this happens with assert false or some other unrecognized exception *) - log_error_and_continue exn initial_summary (FKcrash (Exn.to_string exn)) + log_error_and_continue exn initial_summary (FKcrash (Exn.to_string exn)) ) let analyze_proc ?caller_pdesc callee_pdesc = diff --git a/infer/src/backend/preanal.ml b/infer/src/backend/preanal.ml index 8b58f15c5..c1833ece6 100644 --- a/infer/src/backend/preanal.ml +++ b/infer/src/backend/preanal.ml @@ -144,8 +144,7 @@ let add_nullify_instrs pdesc tenv liveness_inv_map = (fun var (pvars_acc, ids_acc) -> match Var.to_exp var with (* we nullify all address taken variables at the end of the procedure *) - | Exp.Lvar pvar - when not (AddressTaken.Domain.mem pvar address_taken_vars) -> + | Exp.Lvar pvar when not (AddressTaken.Domain.mem pvar address_taken_vars) -> (pvar :: pvars_acc, ids_acc) | Exp.Var id -> (pvars_acc, id :: ids_acc) diff --git a/infer/src/backend/printer.ml b/infer/src/backend/printer.ml index b328aa685..89072e53b 100644 --- a/infer/src/backend/printer.ml +++ b/infer/src/backend/printer.ml @@ -36,19 +36,18 @@ module LineReader = struct in lines := line :: !lines done ; - assert false - (* execution never reaches here *) + assert false (* execution never reaches here *) with End_of_file -> In_channel.close cin ; Array.of_list (List.rev !lines) - let file_data (hash: t) fname = - try Some (Hashtbl.find hash fname) with Caml.Not_found -> + let file_data (hash : t) fname = + try Some (Hashtbl.find hash fname) with Caml.Not_found -> ( try let lines_arr = read_file (SourceFile.to_abs_path fname) in Hashtbl.add hash fname lines_arr ; Some lines_arr - with exn when SymOp.exn_not_failure exn -> None + with exn when SymOp.exn_not_failure exn -> None ) let from_file_linenum_original hash fname linenum = @@ -114,8 +113,14 @@ let pp_node_link path_to_root ?proof_cover ~description fmt node = when starting and finishing the processing of a node *) module NodesHtml : sig val start_node : - int -> Location.t -> Typ.Procname.t -> Procdesc.Node.t list -> Procdesc.Node.t list - -> Procdesc.Node.t list -> SourceFile.t -> bool + int + -> Location.t + -> Typ.Procname.t + -> Procdesc.Node.t list + -> Procdesc.Node.t list + -> Procdesc.Node.t list + -> SourceFile.t + -> bool val finish_node : Typ.Procname.t -> int -> SourceFile.t -> unit end = struct @@ -175,7 +180,7 @@ let force_delayed_prints () = (** Start a session, and create a new html fine for the node if it does not exist yet *) -let start_session ~pp_name node (loc: Location.t) proc_name session source = +let start_session ~pp_name node (loc : Location.t) proc_name session source = let node_id = Procdesc.Node.get_id node in if NodesHtml.start_node @@ -189,7 +194,8 @@ let start_session ~pp_name node (loc: Location.t) proc_name session source = node Io_infer.Html.pp_end_color () ; F.fprintf !curr_html_formatter "%a%a %t" Io_infer.Html.pp_hline () (Io_infer.Html.pp_session_link source ~with_name:true [".."] ~proc_name) - ((node_id :> int), session, loc.Location.line) pp_name ; + ((node_id :> int), session, loc.Location.line) + pp_name ; F.fprintf !curr_html_formatter "%a" Io_infer.Html.pp_start_color Pp.Black @@ -241,7 +247,7 @@ let write_proc_html pdesc = (** Creare a hash table mapping line numbers to the set of errors occurring on that line *) let create_table_err_per_line err_log = let err_per_line = Hashtbl.create 17 in - let add_err (key: Errlog.err_key) (err_data: Errlog.err_data) = + let add_err (key : Errlog.err_key) (err_data : Errlog.err_data) = let err_str = F.asprintf "%s %a" key.err_name.IssueType.unique_id Localise.pp_error_desc key.err_desc in @@ -268,7 +274,8 @@ let write_html_proc source proof_cover table_nodes_at_linenum global_err_log pro in let proc_loc = Procdesc.get_loc proc_desc in let process_proc = - Procdesc.is_defined proc_desc && SourceFile.equal proc_loc.Location.file source + Procdesc.is_defined proc_desc + && SourceFile.equal proc_loc.Location.file source && match Attributes.find_file_capturing_procedure proc_name with | None -> diff --git a/infer/src/backend/reporting.ml b/infer/src/backend/reporting.ml index c2a2bd456..856d4d72c 100644 --- a/infer/src/backend/reporting.ml +++ b/infer/src/backend/reporting.ml @@ -9,19 +9,25 @@ open! IStd module L = Logging type log_t = - ?ltr:Errlog.loc_trace -> ?linters_def_file:string -> ?doc_url:string -> ?access:string - -> ?extras:Jsonbug_t.extra -> exn -> unit + ?ltr:Errlog.loc_trace + -> ?linters_def_file:string + -> ?doc_url:string + -> ?access:string + -> ?extras:Jsonbug_t.extra + -> exn + -> unit let log_issue_from_errlog procname ~clang_method_kind severity err_log ~loc ~node ~ltr ~linters_def_file ~doc_url ~access ~extras exn = let issue_type = (Exceptions.recognize_exception exn).name in - if not Config.filtering (* no-filtering takes priority *) || issue_type.IssueType.enabled then + if (not Config.filtering) (* no-filtering takes priority *) || issue_type.IssueType.enabled then let session = (State.get_session () :> int) in Errlog.log_issue procname ~clang_method_kind severity err_log ~loc ~node ~session ~ltr ~linters_def_file ~doc_url ~access ~extras exn -let log_frontend_issue procname severity errlog ~loc ~node_key ~ltr ~linters_def_file ~doc_url exn = +let log_frontend_issue procname severity errlog ~loc ~node_key ~ltr ~linters_def_file ~doc_url exn + = let node = Errlog.FrontendNode {node_key} in log_issue_from_errlog procname ~clang_method_kind:None severity errlog ~loc ~node ~ltr ~linters_def_file ~doc_url ~access:None ~extras:None exn @@ -87,7 +93,7 @@ let log_issue_external procname severity ~loc ~ltr ?access issue_type error_mess ~linters_def_file:None ~doc_url:None ~access ~extras:None exn -let is_suppressed ?(field_name= None) tenv proc_desc kind = +let is_suppressed ?(field_name = None) tenv proc_desc kind = let lookup = Tenv.lookup tenv in let proc_attributes = Procdesc.get_attributes proc_desc in (* Errors can be suppressed with annotations. An error of kind CHECKER_ERROR_NAME can be @@ -95,7 +101,7 @@ let is_suppressed ?(field_name= None) tenv proc_desc kind = - @android.annotation.SuppressLint("checker-error-name") - @some.PrefixErrorName where the kind matching is case - insensitive and ignores '-' and '_' characters. *) - let annotation_matches (a: Annot.t) = + let annotation_matches (a : Annot.t) = let normalize str = Str.global_replace (Str.regexp "[_-]") "" (String.lowercase str) in let drop_prefix str = Str.replace_first (Str.regexp "^[A-Za-z]+_") "" str in let normalized_equal s1 s2 = String.equal (normalize s1) (normalize s2) in diff --git a/infer/src/backend/reporting.mli b/infer/src/backend/reporting.mli index 791a853f4..4d6a7c838 100644 --- a/infer/src/backend/reporting.mli +++ b/infer/src/backend/reporting.mli @@ -10,8 +10,13 @@ open! IStd (** Type of functions to report issues to the error_log in a spec. *) type log_t = - ?ltr:Errlog.loc_trace -> ?linters_def_file:string -> ?doc_url:string -> ?access:string - -> ?extras:Jsonbug_t.extra -> exn -> unit + ?ltr:Errlog.loc_trace + -> ?linters_def_file:string + -> ?doc_url:string + -> ?access:string + -> ?extras:Jsonbug_t.extra + -> exn + -> unit val log_issue_deprecated : Exceptions.severity -> Typ.Procname.t -> ?node:Procdesc.Node.t -> ?loc:Location.t -> log_t @@ -20,9 +25,16 @@ val log_issue_deprecated : Use log_error/warning instead *) val log_frontend_issue : - Typ.Procname.t -> Exceptions.severity -> Errlog.t -> loc:Location.t - -> node_key:Procdesc.NodeKey.t -> ltr:Errlog.loc_trace -> linters_def_file:string option - -> doc_url:string option -> exn -> unit + Typ.Procname.t + -> Exceptions.severity + -> Errlog.t + -> loc:Location.t + -> node_key:Procdesc.NodeKey.t + -> ltr:Errlog.loc_trace + -> linters_def_file:string option + -> doc_url:string option + -> exn + -> unit (** Report a frontend issue of a given kind in the given error log. *) val log_error : Summary.t -> loc:Location.t -> log_t @@ -32,8 +44,14 @@ val log_warning : Summary.t -> loc:Location.t -> log_t (** Add an warning to the given summary. *) val log_issue_external : - Typ.Procname.t -> Exceptions.severity -> loc:Location.t -> ltr:Errlog.loc_trace -> ?access:string - -> IssueType.t -> string -> unit + Typ.Procname.t + -> Exceptions.severity + -> loc:Location.t + -> ltr:Errlog.loc_trace + -> ?access:string + -> IssueType.t + -> string + -> unit (** Log an issue to the error log in [IssueLog] associated with the given procname. *) val is_suppressed : diff --git a/infer/src/base/CommandDoc.ml b/infer/src/base/CommandDoc.ml index 727f74f33..31c28aa25 100644 --- a/infer/src/base/CommandDoc.ml +++ b/infer/src/base/CommandDoc.ml @@ -238,7 +238,8 @@ $(b,infer) $(i,[options])|} "cxx": false, "infer-blacklist-files-containing": ["@generated","@Generated"] }|} - ] ~see_also:InferCommand.all_commands "infer" + ] + ~see_also:InferCommand.all_commands "infer" let report = diff --git a/infer/src/base/CommandLineOption.ml b/infer/src/base/CommandLineOption.ml index 06ec9e298..7f682c29f 100644 --- a/infer/src/base/CommandLineOption.ml +++ b/infer/src/base/CommandLineOption.ml @@ -64,7 +64,7 @@ let to_arg_speclist = List.map ~f:to_arg_spec_triple (* NOTE: All variants must be also added to `all_parse_modes` below *) type parse_mode = InferCommand | Javac | NoParse [@@deriving compare] -let equal_parse_mode = [%compare.equal : parse_mode] +let equal_parse_mode = [%compare.equal: parse_mode] let all_parse_modes = [InferCommand; Javac; NoParse] @@ -218,7 +218,8 @@ let add parse_mode sections desc = in (* in the help of `infer` itself, show in which specific commands the option is used *) let commands = - List.map ~f:fst sections |> List.sort ~compare:InferCommand.compare + List.map ~f:fst sections + |> List.sort ~compare:InferCommand.compare |> List.remove_consecutive_duplicates ~equal:InferCommand.equal |> List.map ~f:(fun cmd -> let exe = InferCommand.to_exe_name cmd in @@ -264,7 +265,7 @@ let deprecate_desc parse_mode ~long ~short ~deprecated doc desc = ; decode_json= deprecated_decode_json } -let mk ?(deprecated= []) ?(parse_mode= InferCommand) ?(in_help= []) ~long ?short:short0 ~default +let mk ?(deprecated = []) ?(parse_mode = InferCommand) ?(in_help = []) ~long ?short:short0 ~default ~meta doc ~default_to_string ~decode_json ~mk_setter ~mk_spec = let variable = ref default in let closure = mk_setter variable in @@ -316,8 +317,14 @@ let curr_command = ref None (* end parsing state *) type 'a t = - ?deprecated:string list -> long:Arg.key -> ?short:char -> ?parse_mode:parse_mode - -> ?in_help:(InferCommand.t * string) list -> ?meta:string -> Arg.doc -> 'a + ?deprecated:string list + -> long:Arg.key + -> ?short:char + -> ?parse_mode:parse_mode + -> ?in_help:(InferCommand.t * string) list + -> ?meta:string + -> Arg.doc + -> 'a let string_json_decoder ~long ~inferconfig_dir:_ json = [dashdash long; YBU.to_string json] @@ -333,7 +340,7 @@ let list_json_decoder json_decoder ~inferconfig_dir json = List.concat (YBU.convert_each (json_decoder ~inferconfig_dir) json) -let mk_set var value ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "") doc = +let mk_set var value ?(deprecated = []) ~long ?short ?parse_mode ?in_help ?(meta = "") doc = let setter () = var := value in ignore (mk ~deprecated ~long ?short ~default:() ?parse_mode ?in_help ~meta doc @@ -356,8 +363,8 @@ let reset_doc_opt ~long = Printf.sprintf "Cancel the effect of $(b,%s)." (dashda let reset_doc_list ~long = Printf.sprintf "Set $(b,%s) to the empty list." (dashdash long) -let mk_option ?(default= None) ?(default_to_string= fun _ -> "") ~f ?(mk_reset= true) - ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "string") doc = +let mk_option ?(default = None) ?(default_to_string = fun _ -> "") ~f ?(mk_reset = true) + ?(deprecated = []) ~long ?short ?parse_mode ?in_help ?(meta = "string") doc = let mk () = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~default_to_string ~decode_json:(string_json_decoder ~long) @@ -370,8 +377,8 @@ let mk_option ?(default= None) ?(default_to_string= fun _ -> "") ~f ?(mk_reset= else mk () -let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated= []) ~long ?short - ?parse_mode ?in_help ?(meta= "") doc0 = +let mk_bool ?(deprecated_no = []) ?(default = false) ?(f = fun b -> b) ?(deprecated = []) ~long + ?short ?parse_mode ?in_help ?(meta = "") doc0 = let nolong = let len = String.length long in if len > 3 && String.sub long ~pos:0 ~len:3 = "no-" then String.sub long ~pos:3 ~len:(len - 3) @@ -413,7 +420,7 @@ let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated var -let mk_bool_group ?(deprecated_no= []) ?(default= false) ?f:(f0 = Fn.id) ?(deprecated= []) ~long +let mk_bool_group ?(deprecated_no = []) ?(default = false) ?f:(f0 = Fn.id) ?(deprecated = []) ~long ?short ?parse_mode ?in_help ?meta doc children no_children = let f b = List.iter ~f:(fun child -> child := b) children ; @@ -423,8 +430,8 @@ let mk_bool_group ?(deprecated_no= []) ?(default= false) ?f:(f0 = Fn.id) ?(depre mk_bool ~deprecated ~deprecated_no ~default ~long ?short ~f ?parse_mode ?in_help ?meta doc -let mk_int ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "int") - doc = +let mk_int ~default ?(f = Fn.id) ?(deprecated = []) ~long ?short ?parse_mode ?in_help + ?(meta = "int") doc = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~default_to_string:string_of_int ~mk_setter:(fun var str -> var := f (int_of_string str)) @@ -432,21 +439,22 @@ let mk_int ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_h ~mk_spec:(fun set -> String set) -let mk_int_opt ?default ?f:(f0 = Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help - ?(meta= "int") doc = +let mk_int_opt ?default ?f:(f0 = Fn.id) ?(deprecated = []) ~long ?short ?parse_mode ?in_help + ?(meta = "int") doc = let default_to_string = function Some f -> string_of_int f | None -> "" in let f s = Some (f0 (int_of_string s)) in mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ?in_help ~meta doc -let mk_float_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "float") doc = +let mk_float_opt ?default ?(deprecated = []) ~long ?short ?parse_mode ?in_help ?(meta = "float") + doc = let default_to_string = function Some f -> string_of_float f | None -> "" in let f s = Some (float_of_string s) in mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ?in_help ~meta doc -let mk_string ~default ?(f= fun s -> s) ?(deprecated= []) ~long ?short ?parse_mode ?in_help - ?(meta= "string") doc = +let mk_string ~default ?(f = fun s -> s) ?(deprecated = []) ~long ?short ?parse_mode ?in_help + ?(meta = "string") doc = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~default_to_string:(fun s -> s) ~mk_setter:(fun var str -> var := f str) @@ -454,16 +462,16 @@ let mk_string ~default ?(f= fun s -> s) ?(deprecated= []) ~long ?short ?parse_mo ~mk_spec:(fun set -> String set) -let mk_string_opt ?default ?(f= fun s -> s) ?mk_reset ?(deprecated= []) ~long ?short ?parse_mode - ?in_help ?(meta= "string") doc = +let mk_string_opt ?default ?(f = fun s -> s) ?mk_reset ?(deprecated = []) ~long ?short ?parse_mode + ?in_help ?(meta = "string") doc = let default_to_string = function Some s -> s | None -> "" in let f s = Some (f s) in mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?mk_reset ?parse_mode ?in_help ~meta doc -let mk_string_list ?(default= []) ?(f= fun s -> s) ?(deprecated= []) ~long ?short ?parse_mode - ?in_help ?(meta= "string") doc = +let mk_string_list ?(default = []) ?(f = fun s -> s) ?(deprecated = []) ~long ?short ?parse_mode + ?in_help ?(meta = "string") doc = let mk () = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta:("+" ^ meta) doc ~default_to_string:(String.concat ~sep:",") @@ -475,7 +483,7 @@ let mk_string_list ?(default= []) ?(f= fun s -> s) ?(deprecated= []) ~long ?shor mk_with_reset [] ~reset_doc ~long ?parse_mode mk -let normalize_path_in_args_being_parsed ?(f= Fn.id) ~is_anon_arg str = +let normalize_path_in_args_being_parsed ?(f = Fn.id) ~is_anon_arg str = if Filename.is_relative str then ( (* Replace relative paths with absolute ones on the fly in the args being parsed. This assumes that [!arg_being_parsed] points at either [str] (if [is_anon_arg]) or at the option name @@ -498,8 +506,8 @@ let mk_path_helper ~setter ~default_to_string ~default ~deprecated ~long ~short ~mk_spec:(fun set -> String set) -let mk_path ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help - ?(meta= "path") = +let mk_path ~default ?(f = Fn.id) ?(deprecated = []) ~long ?short ?parse_mode ?in_help + ?(meta = "path") = mk_path_helper ~setter:(fun var x -> var := f x) ~decode_json:(path_json_decoder ~long) @@ -507,7 +515,8 @@ let mk_path ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_ ~default ~deprecated ~long ~short ~parse_mode ~in_help ~meta -let mk_path_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "path") doc = +let mk_path_opt ?default ?(deprecated = []) ~long ?short ?parse_mode ?in_help ?(meta = "path") doc + = let mk () = mk_path_helper ~setter:(fun var x -> var := Some x) @@ -519,8 +528,8 @@ let mk_path_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(m mk_with_reset None ~reset_doc ~long ?parse_mode mk -let mk_path_list ?(default= []) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "path") - doc = +let mk_path_list ?(default = []) ?(deprecated = []) ~long ?short ?parse_mode ?in_help + ?(meta = "path") doc = let mk () = mk_path_helper ~setter:(fun var x -> var := x :: !var) @@ -537,8 +546,8 @@ let mk_symbols_meta symbols = Printf.sprintf "{ %s }" (String.concat ~sep:" | " strings) -let mk_symbol ~default ~symbols ~eq ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help - ?meta doc = +let mk_symbol ~default ~symbols ~eq ?(f = Fn.id) ?(deprecated = []) ~long ?short ?parse_mode + ?in_help ?meta doc = let strings = List.map ~f:fst symbols in let sym_to_str = List.map ~f:(fun (x, y) -> (y, x)) symbols in let of_string str = List.Assoc.find_exn ~equal:String.equal symbols str in @@ -551,8 +560,8 @@ let mk_symbol ~default ~symbols ~eq ?(f= Fn.id) ?(deprecated= []) ~long ?short ? ~mk_spec:(fun set -> Symbol (strings, set)) -let mk_symbol_opt ~symbols ?(f= Fn.id) ?(mk_reset= true) ?(deprecated= []) ~long ?short ?parse_mode - ?in_help ?meta doc = +let mk_symbol_opt ~symbols ?(f = Fn.id) ?(mk_reset = true) ?(deprecated = []) ~long ?short + ?parse_mode ?in_help ?meta doc = let strings = List.map ~f:fst symbols in let of_string str = List.Assoc.find_exn ~equal:String.equal symbols str in let meta = Option.value meta ~default:(mk_symbols_meta symbols) in @@ -569,7 +578,7 @@ let mk_symbol_opt ~symbols ?(f= Fn.id) ?(mk_reset= true) ?(deprecated= []) ~long else mk () -let mk_symbol_seq ?(default= []) ~symbols ~eq ?(deprecated= []) ~long ?short ?parse_mode ?in_help +let mk_symbol_seq ?(default = []) ~symbols ~eq ?(deprecated = []) ~long ?short ?parse_mode ?in_help ?meta doc = let sym_to_str = List.map ~f:(fun (x, y) -> (y, x)) symbols in let of_string str = List.Assoc.find_exn ~equal:String.equal symbols str in @@ -583,7 +592,7 @@ let mk_symbol_seq ?(default= []) ~symbols ~eq ?(deprecated= []) ~long ?short ?pa ~mk_spec:(fun set -> String set) -let mk_json ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "json") doc = +let mk_json ?(deprecated = []) ~long ?short ?parse_mode ?in_help ?(meta = "json") doc = mk ~deprecated ~long ?short ?parse_mode ?in_help ~meta doc ~default:(`List []) ~default_to_string:Yojson.Basic.to_string ~mk_setter:(fun var json -> var := Yojson.Basic.from_string json) @@ -603,7 +612,7 @@ let normalize_desc_list speclist = else s in let remove_weird_chars = - String.filter ~f:(function 'a'..'z' | '0'..'9' | '-' -> true | _ -> false) + String.filter ~f:(function 'a' .. 'z' | '0' .. '9' | '-' -> true | _ -> false) in remove_weird_chars @@ String.lowercase @@ remove_no k in @@ -677,8 +686,8 @@ let set_curr_speclist_for_parse_mode ~usage parse_mode = List.Assoc.find_exn ~equal:equal_parse_mode parse_mode_desc_lists parse_mode in curr_speclist := - normalize_desc_list !full_desc_list |> List.map ~f:xdesc |> add_or_suppress_help - |> to_arg_speclist ; + normalize_desc_list !full_desc_list + |> List.map ~f:xdesc |> add_or_suppress_help |> to_arg_speclist ; assert (check_no_duplicates !curr_speclist) ; curr_usage @@ -694,7 +703,7 @@ let string_of_command command = s -let mk_rest_actions ?(parse_mode= InferCommand) ?(in_help= []) doc ~usage decode_action = +let mk_rest_actions ?(parse_mode = InferCommand) ?(in_help = []) doc ~usage decode_action = let rest = ref [] in let spec = String @@ -814,7 +823,7 @@ let encode_argv_to_env argv = String.concat ~sep:(String.make 1 env_var_sep) (List.filter ~f:(fun arg -> - not (String.contains arg env_var_sep) + (not (String.contains arg env_var_sep)) || ( warnf "WARNING: Ignoring unsupported option containing '%c' character: %s@\n" env_var_sep arg ; @@ -973,12 +982,12 @@ let show_manual ?internal_section format default_doc command_opt = match command_opt with | None -> default_doc - | Some command -> + | Some command -> ( match List.Assoc.find_exn ~equal:InferCommand.equal !subcommands command with | Some command_doc, _, _ -> command_doc | None, _, _ -> - L.(die InternalError) "No manual for internal command %s" (string_of_command command) + L.(die InternalError) "No manual for internal command %s" (string_of_command command) ) in let pp_meta f meta = match meta with "" -> () | meta -> F.fprintf f " $(i,%s)" (Cmdliner.Manpage.escape meta) @@ -1007,12 +1016,11 @@ let show_manual ?internal_section format default_doc command_opt = match command_doc.manual_options with | `Replace blocks -> `S Cmdliner.Manpage.s_options :: blocks - | `Prepend blocks -> + | `Prepend blocks -> ( let hidden = match internal_section with | Some section -> - `S section - :: `P "Use at your own risk." + `S section :: `P "Use at your own risk." :: List.concat_map ~f:block_of_desc (normalize_desc_list !hidden_descs_list) | None -> [] @@ -1026,11 +1034,13 @@ let show_manual ?internal_section format default_doc command_opt = (fun section descs result -> `S section :: (if String.equal section Cmdliner.Manpage.s_options then blocks else []) - @ List.concat_map ~f:block_of_desc (normalize_desc_list descs) @ result ) + @ List.concat_map ~f:block_of_desc (normalize_desc_list descs) + @ result ) !sections hidden | None -> - `S Cmdliner.Manpage.s_options :: blocks - @ List.concat_map ~f:block_of_desc (normalize_desc_list !visible_descs_list) @ hidden + (`S Cmdliner.Manpage.s_options :: blocks) + @ List.concat_map ~f:block_of_desc (normalize_desc_list !visible_descs_list) + @ hidden ) in let blocks = [ `Blocks command_doc.manual_before_options diff --git a/infer/src/base/CommandLineOption.mli b/infer/src/base/CommandLineOption.mli index aff23911f..73e2121fc 100644 --- a/infer/src/base/CommandLineOption.mli +++ b/infer/src/base/CommandLineOption.mli @@ -41,8 +41,14 @@ val init_work_dir : string - a documentation string *) type 'a t = - ?deprecated:string list -> long:string -> ?short:char -> ?parse_mode:parse_mode - -> ?in_help:(InferCommand.t * string) list -> ?meta:string -> string -> 'a + ?deprecated:string list + -> long:string + -> ?short:char + -> ?parse_mode:parse_mode + -> ?in_help:(InferCommand.t * string) list + -> ?meta:string + -> string + -> 'a val mk_set : 'a ref -> 'a -> unit t (** [mk_set variable value] defines a command line option which sets [variable] to [value]. *) @@ -55,7 +61,9 @@ val mk_bool : ?deprecated_no:string list -> ?default:bool -> ?f:(bool -> bool) - either "Activates:" or "Deactivates:", so should be phrased accordingly. *) val mk_bool_group : - ?deprecated_no:string list -> ?default:bool -> ?f:(bool -> bool) + ?deprecated_no:string list + -> ?default:bool + -> ?f:(bool -> bool) -> (bool ref list -> bool ref list -> bool ref) t (** [mk_bool_group children not_children] behaves as [mk_bool] with the addition that all the [children] are also set and the [no_children] are unset. A child can be unset by including @@ -114,8 +122,12 @@ val mk_anon : unit -> string list ref order they appeared on the command line. *) val mk_rest_actions : - ?parse_mode:parse_mode -> ?in_help:(InferCommand.t * string) list -> string -> usage:string - -> (string -> parse_mode) -> string list ref + ?parse_mode:parse_mode + -> ?in_help:(InferCommand.t * string) list + -> string + -> usage:string + -> (string -> parse_mode) + -> string list ref (** [mk_rest_actions doc ~usage command_to_parse_mode] defines a [string list ref] of the command line arguments following ["--"], in the reverse order they appeared on the command line. [usage] is the usage message in case of parse errors or if --help is passed. For example, calling @@ -127,13 +139,23 @@ val mk_rest_actions : type command_doc val mk_command_doc : - title:string -> section:int -> version:string -> date:string -> short_description:string - -> synopsis:Cmdliner.Manpage.block list -> description:Cmdliner.Manpage.block list + title:string + -> section:int + -> version:string + -> date:string + -> short_description:string + -> synopsis:Cmdliner.Manpage.block list + -> description:Cmdliner.Manpage.block list -> ?options:[`Prepend of Cmdliner.Manpage.block list | `Replace of Cmdliner.Manpage.block list] - -> ?exit_status:Cmdliner.Manpage.block list -> ?environment:Cmdliner.Manpage.block list - -> ?files:Cmdliner.Manpage.block list -> ?notes:Cmdliner.Manpage.block list - -> ?bugs:Cmdliner.Manpage.block list -> ?examples:Cmdliner.Manpage.block list - -> see_also:Cmdliner.Manpage.block list -> string -> command_doc + -> ?exit_status:Cmdliner.Manpage.block list + -> ?environment:Cmdliner.Manpage.block list + -> ?files:Cmdliner.Manpage.block list + -> ?notes:Cmdliner.Manpage.block list + -> ?bugs:Cmdliner.Manpage.block list + -> ?examples:Cmdliner.Manpage.block list + -> see_also:Cmdliner.Manpage.block list + -> string + -> command_doc (** [mk_command_doc ~title ~section ~version ~short_description ~synopsis ~description ~see_also command_exe] records information about a command that is used to create its man page. A lot of the concepts are taken from man-pages(7). @@ -152,9 +174,14 @@ val mk_command_doc : *) val mk_subcommand : - InferCommand.t -> ?on_unknown_arg:[`Add | `Skip | `Reject] -> name:string - -> ?deprecated_long:string -> ?parse_mode:parse_mode -> ?in_help:(InferCommand.t * string) list - -> command_doc option -> unit + InferCommand.t + -> ?on_unknown_arg:[`Add | `Skip | `Reject] + -> name:string + -> ?deprecated_long:string + -> ?parse_mode:parse_mode + -> ?in_help:(InferCommand.t * string) list + -> command_doc option + -> unit (** [mk_subcommand command ~long command_doc] defines the subcommand [command]. A subcommand is activated by passing [name], and by passing [--deprecated_long] if specified. A man page is automatically generated for [command] based on the information in [command_doc], if available @@ -174,7 +201,10 @@ val extend_env_args : string list -> unit (** [extend_env_args args] appends [args] to those passed via [args_env_var] *) val parse : - ?config_file:string -> usage:Arg.usage_msg -> parse_mode -> InferCommand.t option + ?config_file:string + -> usage:Arg.usage_msg + -> parse_mode + -> InferCommand.t option -> InferCommand.t option * (int -> 'a) (** [parse ~usage parse_mode command] parses command line arguments as specified by preceding calls to the [mk_*] functions, and returns: @@ -198,7 +228,10 @@ val is_env_var_set : string -> bool (** [is_env_var_set var] is true if $[var]=1 *) val show_manual : - ?internal_section:string -> Cmdliner.Manpage.format -> command_doc -> InferCommand.t option + ?internal_section:string + -> Cmdliner.Manpage.format + -> command_doc + -> InferCommand.t option -> unit (** Display the manual of [command] to the user, or [command_doc] if [command] is None. [format] is used as for [Cmdliner.Manpage.print]. If [internal_section] is specified, add a section titled diff --git a/infer/src/base/Config.ml b/infer/src/base/Config.ml index 8a0315457..ed06d7b92 100644 --- a/infer/src/base/Config.ml +++ b/infer/src/base/Config.ml @@ -19,7 +19,7 @@ module L = Die type analyzer = CaptureOnly | CompileOnly | Checkers | Crashcontext | Linters [@@deriving compare] -let equal_analyzer = [%compare.equal : analyzer] +let equal_analyzer = [%compare.equal: analyzer] let string_to_analyzer = [ ("checkers", Checkers) @@ -90,7 +90,7 @@ type build_system = | BXcode [@@deriving compare] -let equal_build_system = [%compare.equal : build_system] +let equal_build_system = [%compare.equal: build_system] (* List of ([build system], [executable name]). Several executables may map to the same build system. In that case, the first one in the list will be used for printing, eg, in which mode @@ -134,7 +134,8 @@ let build_system_of_exe_name name = @[ %a@]" name (Pp.seq ~print_env:Pp.text_break ~sep:"" F.pp_print_string) - ( List.map ~f:fst build_system_exe_assoc |> List.map ~f:string_of_build_system + ( List.map ~f:fst build_system_exe_assoc + |> List.map ~f:string_of_build_system |> List.dedup_and_sort ~compare:String.compare ) @@ -515,7 +516,7 @@ let all_checkers = ref [] let disable_all_checkers () = List.iter !all_checkers ~f:(fun (var, _, _, _) -> var := false) let () = - let on_unknown_arg_from_command (cmd: InferCommand.t) = + let on_unknown_arg_from_command (cmd : InferCommand.t) = match cmd with | Report -> `Add @@ -555,7 +556,7 @@ and ( analysis_blacklist_files_containing_options , analysis_path_regex_blacklist_options , analysis_path_regex_whitelist_options , analysis_suppress_errors_options ) = - let mk_filtering_options ~suffix ?(deprecated_suffix= []) ~help ~meta = + let mk_filtering_options ~suffix ?(deprecated_suffix = []) ~help ~meta = (* reuse the same config var for all the forms of the analyzer name (eg infer and biabduction must map to the same filtering config)*) let config_vars = ref [] in @@ -619,11 +620,7 @@ and analyzer = match Checkers with (* NOTE: if compilation fails here, it means you have added a new analyzer without updating the documentation of this option *) - | CaptureOnly - | CompileOnly - | Checkers - | Crashcontext - | Linters -> + | CaptureOnly | CompileOnly | Checkers | Crashcontext | Linters -> () in CLOpt.mk_symbol_opt ~deprecated:["analyzer"] ~long:"analyzer" ~short:'a' @@ -637,19 +634,19 @@ and analyzer = - $(b,compile): similar to specifying the $(b,compile) subcommand (DEPRECATED) - $(b,crashcontext): experimental (see $(b,--crashcontext))|} ~f:(function - | (CaptureOnly | CompileOnly) as x -> - let analyzer_str = - List.find_map_exn string_to_analyzer ~f:(fun (s, y) -> - if equal_analyzer x y then Some s else None ) - in - CLOpt.warnf - "WARNING: The analyzer '%s' is deprecated, use the '%s' subcommand instead:@\n\ - @\n \ - infer %s ..." - analyzer_str analyzer_str analyzer_str ; - x - | _ as x -> - x) + | (CaptureOnly | CompileOnly) as x -> + let analyzer_str = + List.find_map_exn string_to_analyzer ~f:(fun (s, y) -> + if equal_analyzer x y then Some s else None ) + in + CLOpt.warnf + "WARNING: The analyzer '%s' is deprecated, use the '%s' subcommand instead:@\n\ + @\n \ + infer %s ..." + analyzer_str analyzer_str analyzer_str ; + x + | _ as x -> + x) ~symbols:string_to_analyzer @@ -675,7 +672,7 @@ and ( annotation_reachability , starvation , suggest_nullable , uninit ) = - let mk_checker ?(default= false) ?(deprecated= []) ~long doc = + let mk_checker ?(default = false) ?(deprecated = []) ~long doc = let var = CLOpt.mk_bool ~long ~in_help:InferCommand.[(Analyze, manual_generic)] @@ -762,7 +759,8 @@ and ( annotation_reachability |> String.concat ~sep:", " ) ) ~f:(fun b -> List.iter - ~f:(fun (var, _, _, default) -> var := if b then default || !var else not default && !var) + ~f:(fun (var, _, _, default) -> + var := if b then default || !var else (not default) && !var ) !all_checkers ; b ) [] (* do all the work in ~f *) @@ -818,7 +816,9 @@ and array_level = and blacklist = - CLOpt.mk_string_opt ~deprecated:["-blacklist-regex"; "-blacklist"] ~long:"buck-blacklist" + CLOpt.mk_string_opt + ~deprecated:["-blacklist-regex"; "-blacklist"] + ~long:"buck-blacklist" ~in_help:InferCommand.[(Run, manual_buck_flavors); (Capture, manual_buck_flavors)] ~meta:"regex" "Skip analysis of files matched by the specified regular expression" @@ -1105,7 +1105,8 @@ and ( bo_debug ; reports_include_ml_loc ; trace_error ; write_html - ; write_dotty ] [filtering; only_cheap_debug] + ; write_dotty ] + [filtering; only_cheap_debug] and _ : int option ref = CLOpt.mk_int_opt ~long:"debug-level" ~in_help:all_generic_manuals ~meta:"level" ~f:(fun level -> set_debug_level level ; level) @@ -1118,7 +1119,8 @@ and ( bo_debug "Generate lightweight debugging information: just print the internal exceptions during \ analysis (also sets $(b,--developer-mode), $(b,--no-filtering), $(b,--print-buckets), \ $(b,--reports-include-ml-loc))" - [developer_mode; print_buckets; reports_include_ml_loc] [filtering; keep_going] + [developer_mode; print_buckets; reports_include_ml_loc] + [filtering; keep_going] and default_linters = CLOpt.mk_bool ~long:"default-linters" ~in_help:InferCommand.[(Capture, manual_clang_linters)] @@ -1228,7 +1230,8 @@ and () = By default, the following issue types are disabled: %s.\n\n \ See also $(b,--report-issue-type).\n" (String.concat ~sep:", " disabled_issues_ids)) ; - mk true ~long:"enable-issue-type" ~deprecated:["enable_checks"; "-enable-checks"] + mk true ~long:"enable-issue-type" + ~deprecated:["enable_checks"; "-enable-checks"] "Show reports coming from this type of issue. By default, all issue types are enabled except \ the ones listed in $(b,--disable-issue-type). Note that enabling issue types does not make \ the corresponding checker run; see individual checker options to turn them on or off." @@ -1446,7 +1449,8 @@ and issues_fields = ; `Issue_field_bug_type ; `Issue_field_bucket ; `Issue_field_kind - ; `Issue_field_bug_trace ] ~symbols:issues_fields_symbols ~eq:PolyVariantEqual.( = ) + ; `Issue_field_bug_trace ] + ~symbols:issues_fields_symbols ~eq:PolyVariantEqual.( = ) "Fields to emit with $(b,--issues-tests)" @@ -1765,15 +1769,17 @@ and progress_bar = and progress_bar_style = CLOpt.mk_symbol ~long:"progress-bar-style" - ~symbols:[("auto", `Auto); ("plain", `Plain); ("multiline", `MultiLine)] ~eq:Pervasives.( = ) - ~default:`Auto ~in_help:[(Analyze, manual_generic); (Capture, manual_generic)] + ~symbols:[("auto", `Auto); ("plain", `Plain); ("multiline", `MultiLine)] + ~eq:Pervasives.( = ) ~default:`Auto + ~in_help:[(Analyze, manual_generic); (Capture, manual_generic)] "Style of the progress bar. $(b,auto) selects $(b,multiline) if connected to a tty, otherwise \ $(b,plain)." and project_root = - CLOpt.mk_path ~deprecated:["project_root"; "-project_root"; "pr"] ~long:"project-root" ~short:'C' - ~default:CLOpt.init_work_dir + CLOpt.mk_path + ~deprecated:["project_root"; "-project_root"; "pr"] + ~long:"project-root" ~short:'C' ~default:CLOpt.init_work_dir ~in_help: InferCommand. [ (Analyze, manual_generic) @@ -2016,7 +2022,8 @@ and specs_library = in (* Add the newline-separated directories listed in to the list of directories to be searched for .spec files *) - CLOpt.mk_path ~deprecated:["specs-dir-list-file"; "-specs-dir-list-file"] + CLOpt.mk_path + ~deprecated:["specs-dir-list-file"; "-specs-dir-list-file"] ~long:"specs-library-index" ~default:"" ~f:(fun file -> specs_library := read_specs_dir_list_file file @ !specs_library ; @@ -2091,8 +2098,9 @@ and profiler_samples = and testing_mode = - CLOpt.mk_bool ~deprecated:["testing_mode"; "-testing_mode"; "tm"] ~deprecated_no:["ntm"] - ~long:"testing-mode" + CLOpt.mk_bool + ~deprecated:["testing_mode"; "-testing_mode"; "tm"] + ~deprecated_no:["ntm"] ~long:"testing-mode" "Mode for testing, where no headers are translated, and dot files are created (clang only)" @@ -2326,7 +2334,7 @@ let post_parsing_initialization command_opt = error "Uncaught Internal Error: " (Exn.to_string exn) in print_exception () ; - if not is_infer_exit_zero && (should_print_backtrace_default || !developer_mode) then ( + if (not is_infer_exit_zero) && (should_print_backtrace_default || !developer_mode) then ( ANSITerminal.prerr_string L.(term_styles_of_style Error) "Error backtrace:\n" ; ANSITerminal.prerr_string L.(term_styles_of_style Error) backtrace ) ; if not is_infer_exit_zero then Out_channel.newline stderr ; @@ -2365,13 +2373,13 @@ let post_parsing_initialization command_opt = if !linters_developer_mode then linters := true ; if !default_linters then linters_def_file := linters_def_default_file :: !linters_def_file ; ( if Option.is_none !analyzer then - match (command_opt : InferCommand.t option) with - | Some Compile -> - analyzer := Some CompileOnly - | Some Capture -> - analyzer := Some CaptureOnly - | _ -> - () ) ; + match (command_opt : InferCommand.t option) with + | Some Compile -> + analyzer := Some CompileOnly + | Some Capture -> + analyzer := Some CaptureOnly + | _ -> + () ) ; ( match !analyzer with | Some Crashcontext -> disable_all_checkers () ; @@ -3014,5 +3022,5 @@ let java_package_is_external package = | [] -> false | _ -> - List.exists external_java_packages ~f:(fun (prefix: string) -> + List.exists external_java_packages ~f:(fun (prefix : string) -> String.is_prefix package ~prefix ) diff --git a/infer/src/base/DB.ml b/infer/src/base/DB.ml index 50d5982be..9966e9cde 100644 --- a/infer/src/base/DB.ml +++ b/infer/src/base/DB.ml @@ -17,7 +17,7 @@ let cutoff_length = 100 let crc_token = '.' -let append_crc_cutoff ?(key= "") ?(crc_only= false) name = +let append_crc_cutoff ?(key = "") ?(crc_only = false) name = let name_up_to_cutoff = if String.length name <= cutoff_length then name else String.sub name ~pos:0 ~len:cutoff_length in @@ -79,7 +79,7 @@ let filename_add_suffix fn s = fn ^ s let file_exists path = Sys.file_exists path = `Yes (** Return the time when a file was last modified. The file must exist. *) -let file_modified_time ?(symlink= false) fname = +let file_modified_time ?(symlink = false) fname = try let stat = (if symlink then Unix.lstat else Unix.stat) fname in stat.Unix.st_mtime diff --git a/infer/src/base/EventLogger.ml b/infer/src/base/EventLogger.ml index bf8c3e643..111d22999 100644 --- a/infer/src/base/EventLogger.ml +++ b/infer/src/base/EventLogger.ml @@ -80,7 +80,8 @@ type analysis_issue = let create_analysis_issue_row base record = let open JsonBuilder in - base |> add_string ~key:"bug_kind" ~data:record.bug_kind + base + |> add_string ~key:"bug_kind" ~data:record.bug_kind |> add_string ~key:"bug_type" ~data:record.bug_type |> add_string_opt ~key:"clang_method_kind" ~data:record.clang_method_kind |> add_string_opt ~key:"exception_triggered_location" @@ -109,7 +110,8 @@ type analysis_stats = let create_analysis_stats_row base record = let open JsonBuilder in - base |> add_int ~key:"analysis_nodes_visited" ~data:record.analysis_nodes_visited + base + |> add_int ~key:"analysis_nodes_visited" ~data:record.analysis_nodes_visited |> add_string ~key:"analysis_status" ~data: (Option.value_map record.analysis_status ~default:"OK" ~f:(fun stats_failure -> @@ -171,7 +173,8 @@ let create_call_trace_row base record = ~data:(Option.map ~f:SourceFile.to_rel_path record.callee_source_file) |> add_string ~key:"callee_name" ~data:record.callee_name |> add_string ~key:"caller_name" ~data:record.caller_name - |> add_string ~key:"lang" ~data:record.lang |> add_string_opt ~key:"reason" ~data:record.reason + |> add_string ~key:"lang" ~data:record.lang + |> add_string_opt ~key:"reason" ~data:record.reason |> add_string ~key:"dynamic_dispatch" ~data:(string_of_dynamic_dispatch_opt record.dynamic_dispatch) @@ -186,7 +189,8 @@ type frontend_exception = let create_frontend_exception_row base record = let open JsonBuilder in - base |> add_string_opt ~key:"ast_node" ~data:record.ast_node + base + |> add_string_opt ~key:"ast_node" ~data:record.ast_node |> add_string ~key:"exception_triggered_location" ~data:(Logging.ocaml_pos_to_string record.exception_triggered_location) |> add_string ~key:"exception_type" ~data:record.exception_type @@ -239,7 +243,8 @@ let create_performance_stats_row base record = let open JsonBuilder in let add_mem_perf t = Option.value_map ~default:t record.mem_perf ~f:(fun mem_perf -> - t |> add_float ~key:"minor_heap_mem" ~data:mem_perf.minor_heap_mem + t + |> add_float ~key:"minor_heap_mem" ~data:mem_perf.minor_heap_mem |> add_float ~key:"promoted_minor_heap_mem" ~data:mem_perf.promoted_minor_heap_mem |> add_float ~key:"major_heap_mem" ~data:mem_perf.major_heap_mem |> add_float ~key:"total_allocated_mem" ~data:mem_perf.total_allocated_mem @@ -252,16 +257,19 @@ let create_performance_stats_row base record = in let add_time_perf t = Option.value_map ~default:t record.time_perf ~f:(fun time_perf -> - t |> add_float ~key:"real_time" ~data:time_perf.real_time + t + |> add_float ~key:"real_time" ~data:time_perf.real_time |> add_float ~key:"user_time" ~data:time_perf.user_time |> add_float ~key:"sys_time" ~data:time_perf.sys_time |> add_float ~key:"children_user_time" ~data:time_perf.children_user_time |> add_float ~key:"children_sys_time" ~data:time_perf.children_sys_time ) in - base |> add_string ~key:"lang" ~data:record.lang + base + |> add_string ~key:"lang" ~data:record.lang |> add_string_opt ~key:"source_file" ~data:(Option.map ~f:SourceFile.to_rel_path record.source_file) - |> add_string ~key:"stats_type" ~data:record.stats_type |> add_mem_perf |> add_time_perf + |> add_string ~key:"stats_type" ~data:record.stats_type + |> add_mem_perf |> add_time_perf type procedures_translated = @@ -272,7 +280,8 @@ type procedures_translated = let create_procedures_translated_row base record = let open JsonBuilder in - base |> add_string ~key:"lang" ~data:record.lang + base + |> add_string ~key:"lang" ~data:record.lang |> add_int ~key:"procedures_translated_failed" ~data:record.procedures_translated_failed |> add_int ~key:"procedures_translated_total" ~data:record.procedures_translated_total |> add_string ~key:"source_file" ~data:(SourceFile.to_rel_path record.source_file) @@ -334,12 +343,14 @@ module LoggerImpl : S = struct incr sequence_ctr ; let open JsonBuilder in let base = - empty |> add_string ~key:"command" ~data:(InferCommand.to_string Config.command) + empty + |> add_string ~key:"command" ~data:(InferCommand.to_string Config.command) |> add_string ~key:"event_tag" ~data:(string_of_event event) |> add_string ~key:"hostname" ~data:(Unix.gethostname ()) |> add_string ~key:"infer_commit" ~data:Version.commit |> add_int ~key:"is_originator" ~data:(if CLOpt.is_originator then 1 else 0) - |> add_string_opt ~key:"job_id" ~data:Config.job_id |> add_int ~key:"pid" ~data:(pid ()) + |> add_string_opt ~key:"job_id" ~data:Config.job_id + |> add_int ~key:"pid" ~data:(pid ()) |> add_string ~key:"run_identifier" ~data:(get_log_identifier ()) |> add_int ~key:"sequence" ~data:(!sequence_ctr - 1) |> add_string ~key:"sysname" ~data:sysname @@ -359,7 +370,8 @@ module LoggerImpl : S = struct | ProceduresTranslatedSummary record -> create_procedures_translated_row base record | UncaughtException (exn, exitcode) -> - base |> add_string ~key:"exception" ~data:(Caml.Printexc.exn_slot_name exn) + base + |> add_string ~key:"exception" ~data:(Caml.Printexc.exn_slot_name exn) |> add_string ~key:"exception_info" ~data:(Exn.to_string exn) |> add_int ~key:"exitcode" ~data:exitcode ) |> JsonBuilder.to_json @@ -383,4 +395,4 @@ module DummyLogger : S = struct end (* use real logger if logging is enabled, dummy logger otherwise *) -include ( val if Config.log_events then (module LoggerImpl : S) else (module DummyLogger : S) ) +include (val if Config.log_events then (module LoggerImpl : S) else (module DummyLogger : S)) diff --git a/infer/src/base/FileDiff.ml b/infer/src/base/FileDiff.ml index f00fde7cf..e8e946dac 100644 --- a/infer/src/base/FileDiff.ml +++ b/infer/src/base/FileDiff.ml @@ -10,7 +10,7 @@ open! IStd module UnixDiff = struct type t = Unchanged | New | Old [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let directive_of_char c = match c with diff --git a/infer/src/base/IssueType.ml b/infer/src/base/IssueType.ml index c53693fae..97b497a7e 100644 --- a/infer/src/base/IssueType.ml +++ b/infer/src/base/IssueType.ml @@ -25,7 +25,7 @@ end = struct let compare {unique_id= id1} {unique_id= id2} = String.compare id1 id2 - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] end include T @@ -51,7 +51,7 @@ end = struct 2., but issues of type 2. have not yet been defined. Thus, we record only there [enabled] status definitely. The [hum]an-readable description can be updated when we encounter the definition of the issue type, eg in AL. *) - let from_string ?(enabled= true) ?hum:hum0 unique_id = + let from_string ?(enabled = true) ?hum:hum0 unique_id = let hum = match hum0 with Some str -> str | _ -> prettify unique_id in let issue = {unique_id; enabled; hum} in try diff --git a/infer/src/base/Language.ml b/infer/src/base/Language.ml index c4c0a3a64..8528b289c 100644 --- a/infer/src/base/Language.ml +++ b/infer/src/base/Language.ml @@ -8,7 +8,7 @@ open! IStd type t = Clang | Java | Python [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let language_to_string = [(Clang, "C/C++/ObjC"); (Java, "Java"); (Python, "python")] diff --git a/infer/src/base/Location.ml b/infer/src/base/Location.ml index 621a5121a..aabe7a6a3 100644 --- a/infer/src/base/Location.ml +++ b/infer/src/base/Location.ml @@ -14,14 +14,14 @@ type t = ; file: SourceFile.t (** The name of the source file *) } [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let none file = {line= -1; col= -1; file} let dummy = none (SourceFile.invalid __FILE__) (** Pretty print a location *) -let pp f (loc: t) = +let pp f (loc : t) = F.fprintf f "line %d" loc.line ; if loc.col <> -1 then F.fprintf f ", column %d" loc.col @@ -34,7 +34,7 @@ let pp_short f loc = let to_string loc = F.asprintf "%a" pp_short loc (** Pretty print a file-position of a location *) -let pp_file_pos f (loc: t) = F.fprintf f "%a:%a" SourceFile.pp loc.file pp_short loc +let pp_file_pos f (loc : t) = F.fprintf f "%a:%a" SourceFile.pp loc.file pp_short loc let pp_range f (loc_start, loc_end) = let pp_end loc_start f loc_end = diff --git a/infer/src/base/Logging.ml b/infer/src/base/Logging.ml index 4009b0132..19f5de309 100644 --- a/infer/src/base/Logging.ml +++ b/infer/src/base/Logging.ml @@ -62,7 +62,7 @@ let mk_file_formatter file_fmt category0 = not (phys_equal !prev_category prefix) in if !is_newline || category_has_changed then ( - if not !is_newline && category_has_changed then + if (not !is_newline) && category_has_changed then (* category change but previous line has not ended: print newline *) out_functions_orig.out_newline () ; is_newline := false ; @@ -85,7 +85,7 @@ let mk_file_formatter file_fmt category0 = f -let color_console ?(use_stdout= false) scheme = +let color_console ?(use_stdout = false) scheme = let scheme = Option.value scheme ~default:Normal in let formatter = if use_stdout then F.std_formatter else F.err_formatter in let can_colorize = Unix.(isatty (if use_stdout then stdout else stderr)) in @@ -168,7 +168,7 @@ let close_logs () = let () = Epilogues.register ~f:close_logs "flushing logs and closing log file" -let log ~to_console ?(to_file= true) (lazy formatters) = +let log ~to_console ?(to_file = true) (lazy formatters) = match (to_console, to_file) with | false, false -> F.ifprintf F.std_formatter @@ -343,17 +343,17 @@ let setup_log_file () = (** delayable print action *) type print_action = - | PTdecrease_indent: int -> print_action - | PTincrease_indent: int -> print_action - | PTstr: string -> print_action - | PTstr_color: string * Pp.color -> print_action - | PTstrln: string -> print_action - | PTstrln_color: string * Pp.color -> print_action - | PTwarning: string -> print_action - | PTerror: string -> print_action - | PTinfo: string -> print_action - | PT_generic: (Format.formatter -> 'a -> unit) * 'a -> print_action - | PT_generic_with_pe: + | PTdecrease_indent : int -> print_action + | PTincrease_indent : int -> print_action + | PTstr : string -> print_action + | PTstr_color : string * Pp.color -> print_action + | PTstrln : string -> print_action + | PTstrln_color : string * Pp.color -> print_action + | PTwarning : string -> print_action + | PTerror : string -> print_action + | PTinfo : string -> print_action + | PT_generic : (Format.formatter -> 'a -> unit) * 'a -> print_action + | PT_generic_with_pe : Pp.color option * (Pp.env -> Format.formatter -> 'a -> unit) * 'a -> print_action @@ -372,7 +372,9 @@ let pp_maybe_with_color color pp fmt x = (** Execute the delayed print actions *) let force_delayed_print fmt = function | PTdecrease_indent n -> - for _ = 1 to n do F.fprintf fmt "@]" done + for _ = 1 to n do + F.fprintf fmt "@]" + done | PTincrease_indent n -> F.fprintf fmt "%s@[" (String.make (2 * n) ' ') | PTstr s -> @@ -424,25 +426,25 @@ let get_delayed_prints () = !delayed_actions let set_delayed_prints new_delayed_actions = delayed_actions := new_delayed_actions (** dump a string *) -let d_str (s: string) = add_print_action (PTstr s) +let d_str (s : string) = add_print_action (PTstr s) (** dump a string with the given color *) -let d_str_color (c: Pp.color) (s: string) = add_print_action (PTstr_color (s, c)) +let d_str_color (c : Pp.color) (s : string) = add_print_action (PTstr_color (s, c)) (** dump an error string *) -let d_error (s: string) = add_print_action (PTerror s) +let d_error (s : string) = add_print_action (PTerror s) (** dump a warning string *) -let d_warning (s: string) = add_print_action (PTwarning s) +let d_warning (s : string) = add_print_action (PTwarning s) (** dump an info string *) -let d_info (s: string) = add_print_action (PTinfo s) +let d_info (s : string) = add_print_action (PTinfo s) (** dump a string plus newline *) -let d_strln (s: string) = add_print_action (PTstrln s) +let d_strln (s : string) = add_print_action (PTstrln s) (** dump a string plus newline with the given color *) -let d_strln_color (c: Pp.color) (s: string) = add_print_action (PTstrln_color (s, c)) +let d_strln_color (c : Pp.color) (s : string) = add_print_action (PTstrln_color (s, c)) (** dump a newline *) let d_ln () = add_print_action (PTstrln "") @@ -455,7 +457,7 @@ let d_indent indent = (** dump command to increase the indentation level *) -let d_increase_indent (indent: int) = add_print_action (PTincrease_indent indent) +let d_increase_indent (indent : int) = add_print_action (PTincrease_indent indent) (** dump command to decrease the indentation level *) -let d_decrease_indent (indent: int) = add_print_action (PTdecrease_indent indent) +let d_decrease_indent (indent : int) = add_print_action (PTdecrease_indent indent) diff --git a/infer/src/base/MarkupFormatter.mli b/infer/src/base/MarkupFormatter.mli index 269fa66a8..b9084f28a 100644 --- a/infer/src/base/MarkupFormatter.mli +++ b/infer/src/base/MarkupFormatter.mli @@ -31,5 +31,5 @@ val wrap_bold : (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> un val pp_bold : Format.formatter -> string -> unit (** pp to wrap into a bold block *) -val bold_to_string : string -> string [@@warning "-32"] +val bold_to_string : string -> string [@@warning "-32"] (** wrap into a bold block *) diff --git a/infer/src/base/Multilinks.ml b/infer/src/base/Multilinks.ml index 4e1f45383..a80decc3c 100644 --- a/infer/src/base/Multilinks.ml +++ b/infer/src/base/Multilinks.ml @@ -62,7 +62,7 @@ let resolve fname = match lookup ~dir with | None -> fname - | Some links -> + | Some links -> ( try DB.filename_from_string (String.Table.find_exn links base) with | Not_found_s _ | Caml.Not_found -> - fname + fname ) diff --git a/infer/src/base/Process.ml b/infer/src/base/Process.ml index 17f964a7f..c1fa43a1e 100644 --- a/infer/src/base/Process.ml +++ b/infer/src/base/Process.ml @@ -11,7 +11,7 @@ module F = Format (** Prints an error message to a log file, prints a message saying that the error can be found in that file, and exits, with default code 1 or a given code. *) -let print_error_and_exit ?(exit_code= 1) fmt = +let print_error_and_exit ?(exit_code = 1) fmt = F.kfprintf (fun _ -> L.external_error "%s" (F.flush_str_formatter ()) ; @@ -23,15 +23,16 @@ let print_error_and_exit ?(exit_code= 1) fmt = terminate. The standard out and error are not redirected. If the command fails to execute, print an error message and exit. *) let create_process_and_wait ~prog ~args = - Unix.fork_exec ~prog ~argv:(prog :: args) () |> Unix.waitpid + Unix.fork_exec ~prog ~argv:(prog :: args) () + |> Unix.waitpid |> function - | Ok () -> - () - | Error _ as status -> - L.(die ExternalError) - "Error executing: %s@\n%s@\n" - (String.concat ~sep:" " (prog :: args)) - (Unix.Exit_or_signal.to_string_hum status) + | Ok () -> + () + | Error _ as status -> + L.(die ExternalError) + "Error executing: %s@\n%s@\n" + (String.concat ~sep:" " (prog :: args)) + (Unix.Exit_or_signal.to_string_hum status) let pipeline ~producer_prog ~producer_args ~consumer_prog ~consumer_args = @@ -45,7 +46,7 @@ let pipeline ~producer_prog ~producer_args ~consumer_prog ~consumer_args = Unix.close pipe_in ; (* exec producer *) never_returns (Unix.exec ~prog:producer_prog ~argv:producer_args ()) - | `In_the_parent producer_pid -> + | `In_the_parent producer_pid -> ( match Unix.fork () with | `In_the_child -> (* redirect consumer's stdin to pipe_in *) @@ -62,4 +63,4 @@ let pipeline ~producer_prog ~producer_args ~consumer_prog ~consumer_args = (* wait for children *) let producer_status = Unix.waitpid producer_pid in let consumer_status = Unix.waitpid consumer_pid in - (producer_status, consumer_status) + (producer_status, consumer_status) ) diff --git a/infer/src/base/Process.mli b/infer/src/base/Process.mli index 060c0b8c8..57868b4f5 100644 --- a/infer/src/base/Process.mli +++ b/infer/src/base/Process.mli @@ -17,6 +17,9 @@ val print_error_and_exit : ?exit_code:int -> ('a, Format.formatter, unit, 'b) fo found in that file, and exist, with default code 1 or a given code. *) val pipeline : - producer_prog:string -> producer_args:string list -> consumer_prog:string - -> consumer_args:string list -> Unix.Exit_or_signal.t * Unix.Exit_or_signal.t + producer_prog:string + -> producer_args:string list + -> consumer_prog:string + -> consumer_args:string list + -> Unix.Exit_or_signal.t * Unix.Exit_or_signal.t (** Pipeline producer program into consumer program *) diff --git a/infer/src/base/ProcessPool.ml b/infer/src/base/ProcessPool.ml index a13049f70..7de150a45 100644 --- a/infer/src/base/ProcessPool.ml +++ b/infer/src/base/ProcessPool.ml @@ -63,7 +63,7 @@ type 'a boss_message = let marshal_to_pipe fd x = Marshal.to_channel fd x [] ; Out_channel.flush fd (** like [Unix.read] but reads until [len] bytes have been read *) -let rec really_read ?(pos= 0) ~len fd ~buf = +let rec really_read ?(pos = 0) ~len fd ~buf = if len <= 0 then () else let read = Unix.read ~pos ~len fd ~buf in @@ -129,11 +129,11 @@ let process_updates pool buffer = | UpdateStatus (slot, t, status) -> TaskBar.update_status pool.task_bar ~slot t status | Crash slot -> - let {pid} = (pool.slots).(slot) in + let {pid} = pool.slots.(slot) in (* clean crash, give the child process a chance to cleanup *) Unix.wait (`Pid pid) |> ignore ; killall pool ~slot "see backtrace above" - | Ready slot -> + | Ready slot -> ( TaskBar.tasks_done_add pool.task_bar 1 ; match pool.tasks with | [] -> @@ -141,8 +141,8 @@ let process_updates pool buffer = pool.idle_children <- pool.idle_children + 1 | x :: tasks -> pool.tasks <- tasks ; - let {down_pipe} = (pool.slots).(slot) in - marshal_to_pipe down_pipe (Do x) ) + let {down_pipe} = pool.slots.(slot) in + marshal_to_pipe down_pipe (Do x) ) ) (** terminate all worker processes *) @@ -204,7 +204,7 @@ let fork_child ~child_prelude ~slot (updates_r, updates_w) ~f = ProcessPoolState.in_child := true ; child_prelude () ; let updates_oc = Unix.out_channel_of_descr updates_w in - let send_to_parent (message: worker_message) = marshal_to_pipe updates_oc message in + let send_to_parent (message : worker_message) = marshal_to_pipe updates_oc message in (* Function to send updates up the pipe to the parent instead of directly to the task bar. This is because only the parent knows about all the children, hence it's in charge of actually updating the task bar. *) @@ -235,7 +235,7 @@ let create : jobs:int -> child_prelude:(unit -> unit) -> f:('a -> unit) -> 'a t (* Pipe to communicate from children to parent. Only one pipe is needed: the messages sent by children include the identifier of the child sending the message (its [slot]). This way there is only one pipe to wait on for updates. *) - let (pipe_child_r, pipe_child_w) as status_pipe = Unix.pipe () in + let ((pipe_child_r, pipe_child_w) as status_pipe) = Unix.pipe () in let slots = Array.init jobs ~f:(fun slot -> fork_child ~child_prelude ~slot status_pipe ~f) in (* we have forked the child processes and are now in the parent *) let[@warning "-26"] pipe_child_w = Unix.close pipe_child_w in diff --git a/infer/src/base/ResultsDir.ml b/infer/src/base/ResultsDir.ml index 375826bec..a4c5877df 100644 --- a/infer/src/base/ResultsDir.ml +++ b/infer/src/base/ResultsDir.ml @@ -18,7 +18,8 @@ let is_results_dir ~check_correct_version () = || ( not_found := d ^ "/" ; false ) ) - && ( not check_correct_version || Sys.is_file ResultsDatabase.database_fullpath = `Yes + && ( (not check_correct_version) + || Sys.is_file ResultsDatabase.database_fullpath = `Yes || ( not_found := ResultsDatabase.database_fullpath ; false ) ) diff --git a/infer/src/base/Serialization.ml b/infer/src/base/Serialization.ml index 743716443..f6acded90 100644 --- a/infer/src/base/Serialization.ml +++ b/infer/src/base/Serialization.ml @@ -27,8 +27,8 @@ end (** version of the binary files, to be incremented for each change *) let version = 27 -let create_serializer (key: Key.t) : 'a serializer = - let read_data ((key': Key.t), (version': int), (value: 'a)) source_msg = +let create_serializer (key : Key.t) : 'a serializer = + let read_data ((key' : Key.t), (version' : int), (value : 'a)) source_msg = if key <> key' then ( L.user_error "Wrong key in when loading data from %s -- are you running infer with results coming from \ @@ -43,17 +43,17 @@ let create_serializer (key: Key.t) : 'a serializer = None ) else Some value in - let read_from_string (str: string) : 'a option = + let read_from_string (str : string) : 'a option = read_data (Marshal.from_string str 0) "string" in - let read_from_file (fname: DB.filename) : 'a option = + let read_from_file (fname : DB.filename) : 'a option = (* The serialization is based on atomic file renames, so the deserialization cannot read a file while it is being written. *) let filename = DB.filename_to_string fname in try Utils.with_file_in filename ~f:(fun inc -> read_data (Marshal.from_channel inc) filename) with Sys_error _ -> None in - let write_to_file ~(data: 'a) (fname: DB.filename) = + let write_to_file ~(data : 'a) (fname : DB.filename) = let filename = DB.filename_to_string fname in Utils.with_intermediate_temp_file_out filename ~f:(fun outc -> Marshal.to_channel outc (key, version, data) [] ) diff --git a/infer/src/base/SourceFile.ml b/infer/src/base/SourceFile.ml index 93d46d928..7d99e21c5 100644 --- a/infer/src/base/SourceFile.ml +++ b/infer/src/base/SourceFile.ml @@ -9,7 +9,7 @@ open! IStd open PolyVariantEqual module L = Logging -let count_newlines (path: string) : int = +let count_newlines (path : string) : int = let f file = In_channel.fold_lines file ~init:0 ~f:(fun i _ -> i + 1) in In_channel.with_file path ~f @@ -24,7 +24,7 @@ type t = (* relative to infer models *) [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] module OrderedSourceFile = struct type nonrec t = t @@ -43,7 +43,7 @@ module Hash = Caml.Hashtbl.Make (struct let hash = Caml.Hashtbl.hash end) -let from_abs_path ?(warn_on_error= true) fname = +let from_abs_path ?(warn_on_error = true) fname = if Filename.is_relative fname then L.(die InternalError) "Path '%s' is relative, when absolute path was expected." fname ; (* try to get realpath of source file. Use original if it fails *) @@ -58,13 +58,13 @@ let from_abs_path ?(warn_on_error= true) fname = RelativeProjectRoot path | None when Config.buck_cache_mode && Filename.check_suffix fname_real "java" -> L.(die InternalError) "%s is not relative to %s" fname_real project_root_real - | None -> + | None -> ( match Utils.filename_to_relative ~root:models_dir_real fname_real with | Some path -> RelativeInferModel path | None -> (* fname_real is absolute already *) - Absolute fname_real + Absolute fname_real ) let to_string fname = @@ -142,7 +142,7 @@ let path_exists abs_path = result -let of_header ?(warn_on_error= true) header_file = +let of_header ?(warn_on_error = true) header_file = let abs_path = to_abs_path header_file in let source_exts = ["c"; "cc"; "cpp"; "cxx"; "m"; "mm"] in let header_exts = ["h"; "hh"; "hpp"; "hxx"] in @@ -156,7 +156,7 @@ let of_header ?(warn_on_error= true) header_file = None -let create ?(warn_on_error= true) path = +let create ?(warn_on_error = true) path = if Filename.is_relative path then (* sources in changed-files-index may be specified relative to project root *) RelativeProjectRoot path diff --git a/infer/src/base/SqliteUtils.ml b/infer/src/base/SqliteUtils.ml index ee3c6f618..37df4e2cb 100644 --- a/infer/src/base/SqliteUtils.ml +++ b/infer/src/base/SqliteUtils.ml @@ -13,7 +13,7 @@ let error ~fatal fmt = (if fatal then Format.kasprintf (fun err -> raise (Error err)) else L.internal_error) fmt -let check_result_code ?(fatal= false) db ~log rc = +let check_result_code ?(fatal = false) db ~log rc = match (rc : Sqlite3.Rc.t) with | OK | ROW -> () diff --git a/infer/src/base/SqliteUtils.mli b/infer/src/base/SqliteUtils.mli index dd98020cf..640c4bf46 100644 --- a/infer/src/base/SqliteUtils.mli +++ b/infer/src/base/SqliteUtils.mli @@ -22,17 +22,31 @@ val finalize : Sqlite3.db -> log:string -> Sqlite3.stmt -> unit (** Finalize the given [stmt]. Raises {!Error} on failure. *) val result_fold_rows : - ?finalize:bool -> Sqlite3.db -> log:string -> Sqlite3.stmt -> init:'a - -> f:('a -> Sqlite3.stmt -> 'a) -> 'a + ?finalize:bool + -> Sqlite3.db + -> log:string + -> Sqlite3.stmt + -> init:'a + -> f:('a -> Sqlite3.stmt -> 'a) + -> 'a (** Fold [f] over each row of the result. [f] must not access the database. *) val result_fold_single_column_rows : - ?finalize:bool -> Sqlite3.db -> log:string -> Sqlite3.stmt -> init:'b - -> f:('b -> Sqlite3.Data.t -> 'b) -> 'b + ?finalize:bool + -> Sqlite3.db + -> log:string + -> Sqlite3.stmt + -> init:'b + -> f:('b -> Sqlite3.Data.t -> 'b) + -> 'b (** Like {!result_fold_rows} but pass column 0 of each row in the results to [f]. *) val result_option : - ?finalize:bool -> Sqlite3.db -> log:string -> read_row:(Sqlite3.stmt -> 'a) -> Sqlite3.stmt + ?finalize:bool + -> Sqlite3.db + -> log:string + -> read_row:(Sqlite3.stmt -> 'a) + -> Sqlite3.stmt -> 'a option (** Same as {!result_fold_rows} but asserts that at most one row is returned. *) @@ -58,5 +72,4 @@ end (** A default implementation of the Data API that encodes every objects as marshalled blobs *) module MarshalledData (D : sig type t -end) : - Data with type t = D.t +end) : Data with type t = D.t diff --git a/infer/src/base/TaskBar.ml b/infer/src/base/TaskBar.ml index 99a96c2ca..c5583c818 100644 --- a/infer/src/base/TaskBar.ml +++ b/infer/src/base/TaskBar.ml @@ -59,9 +59,12 @@ let draw_top_bar fmt ~term_width ~total ~finished ~elapsed = (* add pairs of a partial format string and its expected size *) let ( ++ ) (f1, l1) (f2, l2) = (f1 ^^ f2, l1 + l2) in let ( +++ ) (f1, l1) f2 = (f1 ^^ f2, l1 + (string_of_format f2 |> String.length)) in - ("%*d", bar_tasks_num_size (* finished *)) +++ "/" ++ ("%s", bar_tasks_num_size (* total *)) + ("%*d", bar_tasks_num_size (* finished *)) + +++ "/" + ++ ("%s", bar_tasks_num_size (* total *)) +++ " [" ++ ("%a%a", 0 (* progress bar *)) +++ "] " - ++ ("%d%%", 3 (* "xxx%", even though sometimes it's just "x%" *)) +++ " " + ++ ("%d%%", 3 (* "xxx%", even though sometimes it's just "x%" *)) + +++ " " ++ ( "%s" , max (String.length elapsed_string) 9 (* leave some room for elapsed_string to avoid flicker. 9 characters is "XXhXXmXXs" so it @@ -71,8 +74,8 @@ let draw_top_bar fmt ~term_width ~total ~finished ~elapsed = let top_bar_size = min term_width top_bar_size_default in let progress_bar_size = top_bar_size - size_around_progress_bar in ( if progress_bar_size < min_acceptable_progress_bar then - let s = Printf.sprintf "%d/%s %s" finished tasks_total_string elapsed_string in - F.fprintf fmt "%s" (String.prefix s term_width) + let s = Printf.sprintf "%d/%s %s" finished tasks_total_string elapsed_string in + F.fprintf fmt "%s" (String.prefix s term_width) else let bar_done_size = finished * progress_bar_size / total in F.fprintf fmt top_bar_fmt bar_tasks_num_size finished tasks_total_string (pp_n '#') @@ -144,8 +147,8 @@ let create ~jobs = let update_status_multiline task_bar ~slot:job t0 status = - (task_bar.jobs_statuses).(job) <- status ; - (task_bar.jobs_start_times).(job) <- t0 ; + task_bar.jobs_statuses.(job) <- status ; + task_bar.jobs_start_times.(job) <- t0 ; () diff --git a/infer/src/base/Utils.ml b/infer/src/base/Utils.ml index 7e609daa4..bd81492dc 100644 --- a/infer/src/base/Utils.ml +++ b/infer/src/base/Utils.ml @@ -95,7 +95,7 @@ let filename_to_absolute ~root fname = (** Convert an absolute filename to one relative to the given directory. *) -let filename_to_relative ?(backtrack= 0) ~root fname = +let filename_to_relative ?(backtrack = 0) ~root fname = let rec relativize_if_under prefix backtrack origin target = match (origin, target) with | x :: xs, y :: ys when String.equal x y -> @@ -206,7 +206,11 @@ let write_json_to_file destfile json = let with_channel_in ~f chan_in = - try while true do f @@ In_channel.input_line_exn chan_in done with End_of_file -> () + try + while true do + f @@ In_channel.input_line_exn chan_in + done + with End_of_file -> () let consume_in chan_in = with_channel_in ~f:ignore chan_in @@ -220,7 +224,7 @@ let with_process_in command read = do_finally_swallow_timeout ~f ~finally -let with_process_lines ~(debug: ('a, F.formatter, unit) format -> 'a) ~cmd ~tmp_prefix ~f = +let with_process_lines ~(debug : ('a, F.formatter, unit) format -> 'a) ~cmd ~tmp_prefix ~f = let shell_cmd = List.map ~f:Escape.escape_shell cmd |> String.concat ~sep:" " in let verbose_err_file = Filename.temp_file tmp_prefix ".err" in let shell_cmd_redirected = Printf.sprintf "%s 2>'%s'" shell_cmd verbose_err_file in @@ -246,19 +250,19 @@ let create_dir dir = try if (Unix.stat dir).Unix.st_kind <> Unix.S_DIR then L.(die ExternalError) "file '%s' already exists and is not a directory" dir - with Unix.Unix_error _ -> + with Unix.Unix_error _ -> ( try Unix.mkdir dir ~perm:0o700 with Unix.Unix_error _ -> let created_concurrently = (* check if another process created it meanwhile *) try Polymorphic_compare.( = ) (Unix.stat dir).Unix.st_kind Unix.S_DIR with Unix.Unix_error _ -> false in - if not created_concurrently then L.(die ExternalError) "cannot create directory '%s'" dir + if not created_concurrently then L.(die ExternalError) "cannot create directory '%s'" dir ) let realpath_cache = Hashtbl.create 1023 -let realpath ?(warn_on_error= true) path = +let realpath ?(warn_on_error = true) path = match Hashtbl.find realpath_cache path with | exception Caml.Not_found -> ( match Filename.realpath path with @@ -298,10 +302,10 @@ let compare_versions v1 v2 = in let lv1 = int_list_of_version v1 in let lv2 = int_list_of_version v2 in - [%compare : int list] lv1 lv2 + [%compare: int list] lv1 lv2 -let write_file_with_locking ?(delete= false) ~f:do_write fname = +let write_file_with_locking ?(delete = false) ~f:do_write fname = Unix.with_file ~mode:Unix.[O_WRONLY; O_CREAT] fname diff --git a/infer/src/base/Utils.mli b/infer/src/base/Utils.mli index 071627689..ca246b057 100644 --- a/infer/src/base/Utils.mli +++ b/infer/src/base/Utils.mli @@ -69,8 +69,11 @@ val echo_in : In_channel.t -> unit val with_process_in : string -> (In_channel.t -> 'a) -> 'a * Unix.Exit_or_signal.t val with_process_lines : - debug:((string -> unit, Format.formatter, unit) format -> string -> unit) -> cmd:string list - -> tmp_prefix:string -> f:(string list -> 'res) -> 'res + debug:((string -> unit, Format.formatter, unit) format -> string -> unit) + -> cmd:string list + -> tmp_prefix:string + -> f:(string list -> 'res) + -> 'res (** Runs the command [cmd] and calls [f] on the output lines. Uses [debug] to print debug information, and [tmp_prefix] as a prefix for temporary files. *) diff --git a/infer/src/base/ZipLib.ml b/infer/src/base/ZipLib.ml index 8323f90f7..173c5ed72 100644 --- a/infer/src/base/ZipLib.ml +++ b/infer/src/base/ZipLib.ml @@ -11,7 +11,7 @@ open PolyVariantEqual type zip_library = {zip_filename: string; zip_channel: Zip.in_file Lazy.t} let load_from_zip serializer zip_path zip_library = - let lazy zip_channel = zip_library.zip_channel in + let (lazy zip_channel) = zip_library.zip_channel in let deserialize = Serialization.read_from_string serializer in match deserialize (Zip.read_entry zip_channel (Zip.find_entry zip_channel zip_path)) with | Some data -> @@ -45,7 +45,7 @@ let zip_libraries = line. *) List.rev_filter_map Config.specs_library ~f:load_zip in - if Config.biabduction && not Config.models_mode && Sys.file_exists Config.models_jar = `Yes + if Config.biabduction && (not Config.models_mode) && Sys.file_exists Config.models_jar = `Yes then mk_zip_lib Config.models_jar :: zip_libs else zip_libs) diff --git a/infer/src/base/dune.in b/infer/src/base/dune.in index 15a7b5803..0da4d8431 100644 --- a/infer/src/base/dune.in +++ b/infer/src/base/dune.in @@ -1,7 +1,9 @@ (* -*- tuareg -*- *) (* NOTE: prepend dune.common to this file! *) -;; Format.sprintf - {| + +;; +Format.sprintf + {| (library (name InferBase) (public_name InferBase) @@ -16,7 +18,7 @@ (mld_files index) ) |} - (String.concat " " common_cflags) - (String.concat " " common_optflags) - (String.concat " " ("InferStdlib" :: "InferGenerated" :: common_libraries)) - |> Jbuild_plugin.V1.send + (String.concat " " common_cflags) + (String.concat " " common_optflags) + (String.concat " " ("InferStdlib" :: "InferGenerated" :: common_libraries)) +|> Jbuild_plugin.V1.send diff --git a/infer/src/biabduction/Abs.ml b/infer/src/biabduction/Abs.ml index 9353db3ff..1a3b7091c 100644 --- a/infer/src/biabduction/Abs.ml +++ b/infer/src/biabduction/Abs.ml @@ -56,7 +56,7 @@ let create_fresh_primeds_ls para = (ids_tuple, exps_tuple) -let create_condition_ls ids_private id_base p_leftover (inst: Sil.exp_subst) = +let create_condition_ls ids_private id_base p_leftover (inst : Sil.exp_subst) = let insts_of_private_ids, insts_of_public_ids, inst_of_base = let f id' = List.exists ~f:(fun id'' -> Ident.equal id' id'') ids_private in let inst_private, inst_public = Sil.sub_domain_partition f inst in @@ -77,10 +77,11 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.exp_subst) = && List.for_all ~f:(fun e -> Exp.program_vars e |> Sequence.is_empty) insts_of_private_ids && let fav_insts_of_private_ids = - Sequence.of_list insts_of_private_ids |> Sequence.concat_map ~f:Exp.free_vars + Sequence.of_list insts_of_private_ids + |> Sequence.concat_map ~f:Exp.free_vars |> Sequence.memoize in - not (Sequence.exists fav_insts_of_private_ids ~f:Ident.is_normal) + (not (Sequence.exists fav_insts_of_private_ids ~f:Ident.is_normal)) && let fav_insts_of_private_ids = Ident.set_of_sequence fav_insts_of_private_ids in let intersects_fav_insts_of_private_ids s = @@ -93,7 +94,7 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.exp_subst) = Exp.free_vars e |> Fn.non intersects_fav_insts_of_private_ids ) -let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para: Sil.hpara) = +let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Sil.hpara) = let ids_tuple, exps_tuple = create_fresh_primeds_ls para in let id_base, id_next, id_end, ids_shared = ids_tuple in let exp_base, exp_next, exp_end, exps_shared = exps_tuple in @@ -116,12 +117,12 @@ let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para: Sil.hpara) = (ids, para_body_hpats) in let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = [] in + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] in let condition = let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in create_condition_ls ids_private id_base in - { r_vars= id_base :: id_next :: id_end :: ids_shared @ ids_exist_fst @ ids_exist_snd + { r_vars= (id_base :: id_next :: id_end :: ids_shared) @ ids_exist_fst @ ids_exist_snd ; r_root= para_fst_start ; r_sigma= para_fst_rest @ para_snd ; r_new_sigma= [lseg_res] @@ -147,12 +148,12 @@ let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para = {Match.hpred= Prop.mk_lseg tenv k2 para exp_next exp_end exps_shared; Match.flag= impl_ok2} in let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = [] in + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] in let condition = let ids_private = id_next :: ids_exist in create_condition_ls ids_private id_base in - { r_vars= id_base :: id_next :: id_end :: ids_shared @ ids_exist + { r_vars= (id_base :: id_next :: id_end :: ids_shared) @ ids_exist ; r_root= para_inst_start ; r_sigma= para_inst_rest @ [lseg_pat] ; r_new_pi= gen_pi_res @@ -174,12 +175,12 @@ let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para = (ids, para_body_pat) in let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = [] in + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] in let condition = let ids_private = id_next :: ids_exist in create_condition_ls ids_private id_base in - { r_vars= id_base :: id_next :: id_end :: ids_shared @ ids_exist + { r_vars= (id_base :: id_next :: id_end :: ids_shared) @ ids_exist ; r_root= lseg_pat ; r_sigma= para_inst_pat ; r_new_sigma= [lseg_res] @@ -207,7 +208,7 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = in let k_res = lseg_kind_add k1 k2 in let lseg_res = Prop.mk_lseg tenv k_res para exp_base exp_end exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] (* let inst_base, inst_next, inst_end = @@ -239,7 +240,7 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = ; r_condition= condition } -let mk_rules_for_sll tenv (para: Sil.hpara) : rule list = +let mk_rules_for_sll tenv (para : Sil.hpara) : rule list = if not Config.nelseg then let pts_pts = mk_rule_ptspts_ls tenv true true para in let pts_pels = mk_rule_ptsls_ls tenv Sil.Lseg_PE true false para in @@ -294,7 +295,7 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para = (ids, para_body_hpats) in let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = [] in + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] in let condition = (* for the case of ptspts since iF'=iB therefore iF' cannot be private*) let ids_private = ids_exist_fst @ ids_exist_snd in @@ -306,7 +307,7 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para = L.out "para_snd=%a @.@." pp_hpat_list para_snd; L.out "dllseg_res=%a @.@." pp_hpred dllseg_res; *) - { r_vars= id_iF :: id_oB :: id_iF' :: id_oF :: ids_shared @ ids_exist_fst @ ids_exist_snd + { r_vars= (id_iF :: id_oB :: id_iF' :: id_oF :: ids_shared) @ ids_exist_fst @ ids_exist_snd ; r_root= para_fst_start ; r_sigma= para_fst_rest @ para_snd ; r_new_sigma= [dllseg_res] @@ -345,12 +346,12 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para = ; Match.flag= impl_ok2 } in let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = [] in + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] in let condition = let ids_private = id_iF' :: ids_exist in create_condition_dll ids_private id_iF in - { r_vars= id_iF :: id_oB :: id_iF' :: id_oF :: id_iB :: ids_shared @ ids_exist + { r_vars= (id_iF :: id_oB :: id_iF' :: id_oF :: id_iB :: ids_shared) @ ids_exist ; r_root= para_inst_start ; r_sigma= para_inst_rest @ [dllseg_pat] ; r_new_pi= gen_pi_res @@ -385,12 +386,12 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para = ; Match.flag= impl_ok1 } in let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = [] in + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] in let condition = let ids_private = id_oB' :: ids_exist in create_condition_dll ids_private id_iF in - { r_vars= id_iF :: id_oB :: id_iF' :: id_oB' :: id_oF :: ids_shared @ ids_exist + { r_vars= (id_iF :: id_oB :: id_iF' :: id_oB' :: id_oF :: ids_shared) @ ids_exist ; r_root= dllseg_pat ; r_sigma= para_inst_pat ; r_new_pi= gen_pi_res @@ -427,7 +428,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para = in let k_res = lseg_kind_add k1 k2 in let lseg_res = Prop.mk_dllseg tenv k_res para exp_iF exp_oB exp_oF exp_iB exps_shared in - let gen_pi_res _ _ (_: Sil.exp_subst) = [] in + let gen_pi_res _ _ (_ : Sil.exp_subst) = [] in let condition = let ids_private = [id_iF'; id_oB'] in create_condition_dll ids_private id_iF @@ -440,7 +441,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para = ; r_condition= condition } -let mk_rules_for_dll tenv (para: Sil.hpara_dll) : rule list = +let mk_rules_for_dll tenv (para : Sil.hpara_dll) : rule list = if not Config.nelseg then let pts_pts = mk_rule_ptspts_dll tenv true true para in let pts_pedll = mk_rule_ptsdll_dll tenv Sil.Lseg_PE true false para in @@ -460,7 +461,7 @@ let mk_rules_for_dll tenv (para: Sil.hpara_dll) : rule list = (****************** End of DLL abstraction rules ******************) (****************** Start of Predicate Discovery ******************) let typ_get_recursive_flds tenv typ_exp = - let filter typ (_, (t: Typ.t), _) = + let filter typ (_, (t : Typ.t), _) = match t.desc with | Tstruct _ | Tint _ | Tfloat _ | Tvoid | Tfun _ | TVar _ -> false @@ -480,8 +481,7 @@ let typ_get_recursive_flds tenv typ_exp = L.(debug Analysis Quiet) "@\ntyp_get_recursive_flds: unexpected %a unknown struct type: %a@." Exp.pp typ_exp Typ.Name.pp name ; - [] - (* ToDo: assert false *) ) + [] (* ToDo: assert false *) ) | Tint _ | Tvoid | Tfun _ | Tptr _ | Tfloat _ | Tarray _ | TVar _ -> [] ) | Exp.Var _ -> @@ -496,7 +496,7 @@ let typ_get_recursive_flds tenv typ_exp = let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option = let eq_arg1 = Exp.equal root1 next1 in let eq_arg2 = Exp.equal root2 next2 in - let precondition_check = not eq_arg1 && not eq_arg2 in + let precondition_check = (not eq_arg1) && not eq_arg2 in if not precondition_check then None else let corres = [(next1, next2)] in @@ -681,7 +681,7 @@ let eqs_sub subst eqs = let eqs_solve ids_in eqs_in = - let rec solve (sub: Sil.exp_subst) (eqs: (Exp.t * Exp.t) list) : Sil.exp_subst option = + let rec solve (sub : Sil.exp_subst) (eqs : (Exp.t * Exp.t) list) : Sil.exp_subst option = let do_default id e eqs_rest = if not (List.exists ~f:(fun id' -> Ident.equal id id') ids_in) then None else @@ -776,8 +776,8 @@ let hpara_special_cases_dll hpara : Sil.hpara_dll list = List.map ~f:update_para special_cases -let abs_rules_apply_rsets tenv (rsets: rule_set list) (p_in: Prop.normal Prop.t) - : Prop.normal Prop.t = +let abs_rules_apply_rsets tenv (rsets : rule_set list) (p_in : Prop.normal Prop.t) : + Prop.normal Prop.t = let apply_rule (changed, p) r = match sigma_rewrite tenv p r with | None -> @@ -797,7 +797,7 @@ let abs_rules_apply_rsets tenv (rsets: rule_set list) (p_in: Prop.normal Prop.t) List.fold ~f:apply_rule_set ~init:p_in rsets -let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = +let abs_rules_apply_lists tenv (p_in : Prop.normal Prop.t) : Prop.normal Prop.t = let new_rsets = ref [] in let old_rsets = get_current_rules () in let rec discover_then_abstract p = @@ -816,11 +816,11 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = match rset with DLL para', _ -> Match.hpara_dll_iso tenv para para' | _ -> false in let filter_sll para = - not (List.exists ~f:(eq_sll para) old_rsets) + (not (List.exists ~f:(eq_sll para) old_rsets)) && not (List.exists ~f:(eq_sll para) !new_rsets) in let filter_dll para = - not (List.exists ~f:(eq_dll para) old_rsets) + (not (List.exists ~f:(eq_dll para) old_rsets)) && not (List.exists ~f:(eq_dll para) !new_rsets) in let todo_paras_sll = List.filter ~f:filter_sll closed_paras_sll in @@ -847,13 +847,13 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = set_current_rules new_rules ; p2 -let abs_rules_apply tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = +let abs_rules_apply tenv (p_in : Prop.normal Prop.t) : Prop.normal Prop.t = abs_rules_apply_lists tenv p_in (****************** End of the ADT abs_rules ******************) (****************** Start of Main Abstraction Functions ******************) -let abstract_pure_part tenv p ~(from_abstract_footprint: bool) = +let abstract_pure_part tenv p ~(from_abstract_footprint : bool) = let do_pure pure = let pi_filtered = let sigma = p.Prop.sigma in @@ -1002,7 +1002,8 @@ let check_junk pname tenv prop = let should_remove_hpred entries = let predicate = function | Exp.Var id -> - (Ident.is_primed id || Ident.is_footprint id) && not (Ident.Set.mem id fav_root) + (Ident.is_primed id || Ident.is_footprint id) + && (not (Ident.Set.mem id fav_root)) && not (id_considered_reachable id) | _ -> false @@ -1034,20 +1035,20 @@ let check_junk pname tenv prop = | Some (Apred ((Awont_leak as a), _)) -> L.d_strln "WONT_LEAK" ; res := Some a - | _ -> + | _ -> ( match Attribute.get_resource tenv prop e with | Some (Apred ((Aresource {ra_kind= Racquire} as a), _)) -> L.d_str "ATTRIBUTE: " ; PredSymb.d_attribute a ; L.d_ln () ; res := Some a - | _ -> + | _ -> ( match Attribute.get_undef tenv prop e with | Some (Apred ((Aundef _ as a), _)) -> L.d_strln "UNDEF" ; res := Some a | _ -> - () + () ) ) in List.iter ~f:do_entry entries ; !res in @@ -1164,7 +1165,7 @@ let remove_redundant_array_elements pname tenv prop = check_junk pname tenv prop' -let abstract_prop pname tenv ~(rename_primed: bool) ~(from_abstract_footprint: bool) p = +let abstract_prop pname tenv ~(rename_primed : bool) ~(from_abstract_footprint : bool) p = Absarray.array_abstraction_performed := false ; let pure_abs_p = abstract_pure_part tenv ~from_abstract_footprint:true p in let array_abs_p = @@ -1210,7 +1211,7 @@ let get_local_stack cur_sigma init_sigma = (** Extract the footprint, add a local stack and return it as a prop *) -let extract_footprint_for_abs (p: 'a Prop.t) : Prop.exposed Prop.t * Pvar.t list = +let extract_footprint_for_abs (p : 'a Prop.t) : Prop.exposed Prop.t * Pvar.t list = let sigma = p.Prop.sigma in let pi_fp = p.Prop.pi_fp in let sigma_fp = p.Prop.sigma_fp in @@ -1232,8 +1233,8 @@ let remove_local_stack sigma pvars = (** [prop_set_fooprint p p_foot] removes a local stack from [p_foot], and sets proposition [p_foot] as footprint of [p]. *) -let set_footprint_for_abs (p: 'a Prop.t) (p_foot: 'a Prop.t) local_stack_pvars - : Prop.exposed Prop.t = +let set_footprint_for_abs (p : 'a Prop.t) (p_foot : 'a Prop.t) local_stack_pvars : + Prop.exposed Prop.t = let p_foot_pure = Prop.get_pure p_foot in let p_sigma_fp = p_foot.Prop.sigma in let pi = p_foot_pure in @@ -1242,7 +1243,7 @@ let set_footprint_for_abs (p: 'a Prop.t) (p_foot: 'a Prop.t) local_stack_pvars (** Abstract the footprint of prop *) -let abstract_footprint pname (tenv: Tenv.t) (prop: Prop.normal Prop.t) : Prop.normal Prop.t = +let abstract_footprint pname (tenv : Tenv.t) (prop : Prop.normal Prop.t) : Prop.normal Prop.t = let p, added_local_vars = extract_footprint_for_abs prop in let p_abs = abstract_prop pname tenv ~rename_primed:false ~from_abstract_footprint:true diff --git a/infer/src/biabduction/Absarray.ml b/infer/src/biabduction/Absarray.ml index 26919bf4d..ff4623dd5 100644 --- a/infer/src/biabduction/Absarray.ml +++ b/infer/src/biabduction/Absarray.ml @@ -60,7 +60,7 @@ end = struct type path = Exp.t * syn_offset list (** Find a strexp and a type at the given syntactic offset list *) - let rec get_strexp_at_syn_offsets tenv se (t: Typ.t) syn_offs = + let rec get_strexp_at_syn_offsets tenv se (t : Typ.t) syn_offs = let fail () = L.d_strln "Failure of get_strexp_at_syn_offsets" ; L.d_str "se: " ; @@ -90,7 +90,7 @@ end = struct (** Replace a strexp at the given syntactic offset list *) - let rec replace_strexp_at_syn_offsets tenv se (t: Typ.t) syn_offs update = + let rec replace_strexp_at_syn_offsets tenv se (t : Typ.t) syn_offs update = match (se, t.desc, syn_offs) with | _, _, [] -> update se @@ -164,9 +164,9 @@ end = struct (** Find a sub strexp with the given property. Can raise [Not_found] *) - let find tenv (sigma: sigma) (pred: strexp_data -> bool) : t list = + let find tenv (sigma : sigma) (pred : strexp_data -> bool) : t list = let found = ref [] in - let rec find_offset_sexp sigma_other hpred root offs se (typ: Typ.t) = + let rec find_offset_sexp sigma_other hpred root offs se (typ : Typ.t) = let offs' = List.rev offs in let path = (root, offs') in if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found @@ -218,7 +218,7 @@ end = struct (** Get the matched strexp *) - let get_data tenv ((_, hpred, syn_offs): t) = + let get_data tenv ((_, hpred, syn_offs) : t) = match hpred with | Sil.Hpointsto (root, se, te) -> let t = Exp.texp_to_typ None te in @@ -230,7 +230,7 @@ end = struct (** Replace the current hpred *) - let replace_hpred ((sigma, hpred, _): t) hpred' = + let replace_hpred ((sigma, hpred, _) : t) hpred' = List.map ~f:(fun hpred'' -> if phys_equal hpred'' hpred then hpred' else hpred'') sigma @@ -260,15 +260,15 @@ end = struct (** Replace the strexp at a given position by a new strexp *) - let replace_strexp tenv footprint_part ((sigma, hpred, syn_offs): t) se_in = + let replace_strexp tenv footprint_part ((sigma, hpred, syn_offs) : t) se_in = let update _ = se_in in let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in replace_hpred (sigma, hpred, syn_offs) hpred' (** Replace the index in the array at a given position with the new index *) - let replace_index tenv footprint_part ((sigma, hpred, syn_offs): t) (index: Exp.t) - (index': Exp.t) = + let replace_index tenv footprint_part ((sigma, hpred, syn_offs) : t) (index : Exp.t) + (index' : Exp.t) = let update se' = match se' with | Sil.Earray (len, esel, inst) -> @@ -287,8 +287,8 @@ end (** This function renames expressions in [p]. The renaming is, roughly speaking, to replace [path.i] by [path.i'] for all (i, i') in [map]. *) -let prop_replace_path_index tenv (p: Prop.exposed Prop.t) (path: StrexpMatch.path) - (map: (Exp.t * Exp.t) list) : Prop.exposed Prop.t = +let prop_replace_path_index tenv (p : Prop.exposed Prop.t) (path : StrexpMatch.path) + (map : (Exp.t * Exp.t) list) : Prop.exposed Prop.t = let elist_path = StrexpMatch.path_to_exps path in let expmap_list = List.fold @@ -313,8 +313,8 @@ let prop_replace_path_index tenv (p: Prop.exposed Prop.t) (path: StrexpMatch.pat (** This function uses [update] and transforms the two sigma parts of [p], the sigma of the current SH of [p] and that of the footprint of [p]. *) -let prop_update_sigma_and_fp_sigma tenv (p: Prop.normal Prop.t) - (update: bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool = +let prop_update_sigma_and_fp_sigma tenv (p : Prop.normal Prop.t) + (update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool = let sigma', changed = update false p.Prop.sigma in let ep1 = Prop.set p ~sigma:sigma' in let ep2, changed2 = @@ -332,11 +332,11 @@ let array_abstraction_performed = ref false (** This function abstracts strexps. The parameter [can_abstract] spots strexps where the abstraction might be applicable, and the parameter [do_abstract] does the abstraction to those spotted strexps. *) -let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal Prop.t) - (can_abstract_: StrexpMatch.strexp_data -> bool) - (do_abstract: - bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool) - : Prop.normal Prop.t = +let generic_strexp_abstract tenv (abstraction_name : string) (p_in : Prop.normal Prop.t) + (can_abstract_ : StrexpMatch.strexp_data -> bool) + (do_abstract : + bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool) : + Prop.normal Prop.t = let can_abstract data = let r = can_abstract_ data in if r then array_abstraction_performed := true ; @@ -385,7 +385,8 @@ let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal P (** Return [true] if there's a pointer to the index *) -let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t) : bool = +let index_is_pointed_to tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path) (index : Exp.t) : + bool = let indices = let index_plus_one = Exp.BinOp (Binop.PlusA, index, Exp.one) in [index; index_plus_one] @@ -406,8 +407,8 @@ let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (i (** Given [p] containing an array at [path], blur [index] in it *) -let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t) - : Prop.normal Prop.t = +let blur_array_index tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path) (index : Exp.t) : + Prop.normal Prop.t = try let fresh_index = Exp.Var (Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) @@ -438,15 +439,15 @@ let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (inde (** Given [p] containing an array at [root], blur [indices] in it *) -let blur_array_indices tenv (p: Prop.normal Prop.t) (root: StrexpMatch.path) (indices: Exp.t list) - : Prop.normal Prop.t * bool = +let blur_array_indices tenv (p : Prop.normal Prop.t) (root : StrexpMatch.path) + (indices : Exp.t list) : Prop.normal Prop.t * bool = let f prop index = blur_array_index tenv prop root index in (List.fold ~f ~init:p indices, List.length indices > 0) (** Given [p] containing an array at [root], only keep [indices] in it *) -let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (indices: Exp.t list) - : Prop.normal Prop.t * bool = +let keep_only_indices tenv (p : Prop.normal Prop.t) (path : StrexpMatch.path) + (indices : Exp.t list) : Prop.normal Prop.t * bool = let prune_sigma footprint_part sigma = try let matched = StrexpMatch.find_path sigma path in @@ -478,7 +479,7 @@ let array_typ_can_abstract {Typ.desc} = (** This function checks whether we can apply an abstraction to a strexp *) -let strexp_can_abstract ((_, se, typ): StrexpMatch.strexp_data) : bool = +let strexp_can_abstract ((_, se, typ) : StrexpMatch.strexp_data) : bool = let can_abstract_se = match se with | Sil.Earray (_, esel, _) -> @@ -491,8 +492,8 @@ let strexp_can_abstract ((_, se, typ): StrexpMatch.strexp_data) : bool = (** This function abstracts a strexp *) -let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.strexp_data) - : Prop.normal Prop.t * bool = +let strexp_do_abstract tenv footprint_part p ((path, se_in, _) : StrexpMatch.strexp_data) : + Prop.normal Prop.t * bool = if Config.trace_absarray && footprint_part then ( L.d_str "strexp_do_abstract (footprint)" ; L.d_ln () ) ; @@ -565,7 +566,7 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.stre if !Config.footprint then do_footprint () else do_reexecution () -let strexp_abstract tenv (p: Prop.normal Prop.t) : Prop.normal Prop.t = +let strexp_abstract tenv (p : Prop.normal Prop.t) : Prop.normal Prop.t = generic_strexp_abstract tenv "strexp_abstract" p strexp_can_abstract (strexp_do_abstract tenv) @@ -630,7 +631,8 @@ let remove_redundant_elements tenv prop = let occurs_at_most_once : Ident.t -> bool = let fav_curr = let ( @@@ ) = Sequence.append in - Sil.exp_subst_free_vars prop.Prop.sub @@@ Prop.pi_free_vars prop.Prop.pi + Sil.exp_subst_free_vars prop.Prop.sub + @@@ Prop.pi_free_vars prop.Prop.pi @@@ Prop.sigma_free_vars prop.Prop.sigma in let fav_foot = @@ -656,9 +658,11 @@ let remove_redundant_elements tenv prop = in match (e, se) with | Exp.Const (Const.Cint i), Sil.Eexp (Exp.Var id, _) - when (not fp_part || IntLit.iszero i) && not (Ident.is_normal id) && occurs_at_most_once id -> + when ((not fp_part) || IntLit.iszero i) + && (not (Ident.is_normal id)) + && occurs_at_most_once id -> remove () (* unknown value can be removed in re-execution mode or if the index is zero *) - | Exp.Var id, Sil.Eexp _ when not (Ident.is_normal id) && occurs_at_most_once id -> + | Exp.Var id, Sil.Eexp _ when (not (Ident.is_normal id)) && occurs_at_most_once id -> remove () (* index unknown can be removed *) | _ -> true diff --git a/infer/src/biabduction/Attribute.ml b/infer/src/biabduction/Attribute.ml index b2e1ed9dc..0c29d1a0e 100644 --- a/infer/src/biabduction/Attribute.ml +++ b/infer/src/biabduction/Attribute.ml @@ -14,7 +14,7 @@ open! IStd let is_pred atom = match atom with Sil.Apred _ | Anpred _ -> true | _ -> false (** Add an attribute associated to the argument expressions *) -let add tenv ?(footprint= false) ?(polarity= true) prop attr args = +let add tenv ?(footprint = false) ?(polarity = true) prop attr args = Prop.prop_atom_and tenv ~footprint prop (if polarity then Sil.Apred (attr, args) else Sil.Anpred (attr, args)) @@ -54,15 +54,14 @@ let add_or_replace tenv prop atom = (** Get all the attributes of the prop *) -let get_all (prop: 'a Prop.t) = +let get_all (prop : 'a Prop.t) = let res = ref [] in let do_atom a = if is_pred a then res := a :: !res in - List.iter ~f:do_atom prop.pi ; - List.rev !res + List.iter ~f:do_atom prop.pi ; List.rev !res (** Get the attribute associated to the expression, if any *) -let get_for_exp tenv (prop: 'a Prop.t) exp = +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 @@ -78,10 +77,10 @@ let get tenv prop exp category = let atts = get_for_exp tenv prop exp in List.find ~f:(function - | Sil.Apred (att, _) | Anpred (att, _) -> - PredSymb.equal_category (PredSymb.to_category att) category - | _ -> - false) + | Sil.Apred (att, _) | Anpred (att, _) -> + PredSymb.equal_category (PredSymb.to_category att) category + | _ -> + false) atts @@ -281,7 +280,7 @@ let find_arithmetic_problem tenv proc_node_session prop exp = (** Deallocate the stack variables in [pvars], and replace them by normal variables. Return the list of stack variables whose address was still present after deallocation. *) -let deallocate_stack_vars tenv (p: 'a Prop.t) pvars = +let deallocate_stack_vars tenv (p : 'a Prop.t) pvars = let filter = function | Sil.Hpointsto (Exp.Lvar v, _, _) -> List.exists ~f:(Pvar.equal v) pvars @@ -296,12 +295,12 @@ let deallocate_stack_vars tenv (p: 'a Prop.t) pvars = let exp_replace = List.map ~f:(function - | Sil.Hpointsto (Exp.Lvar v, _, _) -> - let freshv = Ident.create_fresh Ident.kprimed in - fresh_address_vars := (v, freshv) :: !fresh_address_vars ; - (Exp.Lvar v, Exp.Var freshv) - | _ -> - assert false) + | Sil.Hpointsto (Exp.Lvar v, _, _) -> + let freshv = Ident.create_fresh Ident.kprimed in + fresh_address_vars := (v, freshv) :: !fresh_address_vars ; + (Exp.Lvar v, Exp.Var freshv) + | _ -> + assert false) sigma_stack in let pi1 = List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in @@ -349,7 +348,7 @@ let find_equal_formal_path tenv e prop = match res with | Some _ -> res - | None -> + | None -> ( match hpred with | Sil.Hpointsto (Exp.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal (_, _)), _) when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) -> @@ -360,7 +359,7 @@ let find_equal_formal_path tenv e prop = match res with | Some _ -> res - | None -> + | None -> ( match strexp with | Sil.Eexp (exp2, _) when Exp.equal exp2 e -> ( match find_in_sigma exp1 seen_hpreds with @@ -369,18 +368,18 @@ let find_equal_formal_path tenv e prop = | None -> None ) | _ -> - None ) + None ) ) fields ~init:None | _ -> - None ) + None ) ) prop.Prop.sigma ~init:None in match find_in_sigma e [] with | Some vfs -> Some vfs - | None -> + | None -> ( match get_objc_null tenv prop e with | Some (Apred (Aobjc_null, [_; vfs])) -> Some vfs | _ -> - None + None ) diff --git a/infer/src/biabduction/Attribute.mli b/infer/src/biabduction/Attribute.mli index 9bc27c9a0..4b4baf680 100644 --- a/infer/src/biabduction/Attribute.mli +++ b/infer/src/biabduction/Attribute.mli @@ -14,7 +14,12 @@ val is_pred : Sil.atom -> bool (** Check whether an atom is used to mark an attribute *) val add : - Tenv.t -> ?footprint:bool -> ?polarity:bool -> Prop.normal Prop.t -> PredSymb.t -> Exp.t list + Tenv.t + -> ?footprint:bool + -> ?polarity:bool + -> Prop.normal Prop.t + -> PredSymb.t + -> Exp.t list -> Prop.normal Prop.t (** Add an attribute associated to the argument expressions *) @@ -22,7 +27,10 @@ val add_or_replace : Tenv.t -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Pro (** Replace an attribute associated to the expression *) val add_or_replace_check_changed : - Tenv.t -> (PredSymb.t -> PredSymb.t -> unit) -> Prop.normal Prop.t -> Sil.atom + Tenv.t + -> (PredSymb.t -> PredSymb.t -> unit) + -> Prop.normal Prop.t + -> Sil.atom -> Prop.normal Prop.t (** Replace an attribute associated to the expression, and call the given function with new and old attributes if they changed. *) @@ -62,7 +70,9 @@ val remove_resource : (** Remove all attributes for the given resource and kind *) val map_resource : - Tenv.t -> Prop.normal Prop.t -> (Exp.t -> PredSymb.res_action -> PredSymb.res_action) + Tenv.t + -> Prop.normal Prop.t + -> (Exp.t -> PredSymb.res_action -> PredSymb.res_action) -> Prop.normal Prop.t (** Apply f to every resource attribute in the prop *) @@ -75,8 +85,15 @@ val nullify_exp_with_objc_null : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Prop.n remove the attribute and conjoin an equality to zero. *) val mark_vars_as_undefined : - Tenv.t -> Prop.normal Prop.t -> ret_exp:Exp.t -> undefined_actuals_by_ref:Exp.t list - -> Typ.Procname.t -> Annot.Item.t -> Location.t -> PredSymb.path_pos -> Prop.normal Prop.t + Tenv.t + -> Prop.normal Prop.t + -> ret_exp:Exp.t + -> undefined_actuals_by_ref:Exp.t list + -> Typ.Procname.t + -> Annot.Item.t + -> Location.t + -> PredSymb.path_pos + -> Prop.normal Prop.t (** mark Exp.Var's or Exp.Lvar's as undefined *) (** type for arithmetic problems *) @@ -87,7 +104,10 @@ type arith_problem = | UminusUnsigned of Exp.t * Typ.t val find_arithmetic_problem : - Tenv.t -> PredSymb.path_pos -> Prop.normal Prop.t -> Exp.t + Tenv.t + -> PredSymb.path_pos + -> Prop.normal Prop.t + -> Exp.t -> arith_problem option * Prop.normal Prop.t (** Look for an arithmetic problem in [exp] *) diff --git a/infer/src/biabduction/BiabductionSummary.ml b/infer/src/biabduction/BiabductionSummary.ml index 34ffd6f4f..05ed3c12a 100644 --- a/infer/src/biabduction/BiabductionSummary.ml +++ b/infer/src/biabduction/BiabductionSummary.ml @@ -34,11 +34,11 @@ module Jprop = struct let rec sorted_gen_free_vars tenv = let open Sequence.Generator in function - | Prop (_, p) -> - Prop.dfs_sort tenv p |> Prop.sorted_gen_free_vars - | Joined (_, p, jp1, jp2) -> - Prop.dfs_sort tenv p |> Prop.sorted_gen_free_vars - >>= fun () -> sorted_gen_free_vars tenv jp1 >>= fun () -> sorted_gen_free_vars tenv jp2 + | Prop (_, p) -> + Prop.dfs_sort tenv p |> Prop.sorted_gen_free_vars + | Joined (_, p, jp1, jp2) -> + Prop.dfs_sort tenv p |> Prop.sorted_gen_free_vars + >>= fun () -> sorted_gen_free_vars tenv jp1 >>= fun () -> sorted_gen_free_vars tenv jp2 let rec normalize tenv = function @@ -60,7 +60,7 @@ module Jprop = struct let pp_short pe f jp = Prop.pp_prop pe f (to_prop jp) (** Dump the toplevel prop *) - let d_shallow (jp: Prop.normal t) = L.add_print_with_pe pp_short jp + let d_shallow (jp : Prop.normal t) = L.add_print_with_pe pp_short jp (** Get identifies of the jprop *) let get_id = function Prop (n, _) -> n | Joined (n, _, _, _) -> n @@ -84,17 +84,17 @@ module Jprop = struct (** dump a joined prop list, the boolean indicates whether to print toplevel props only *) - let d_list ~(shallow: bool) (jplist: Prop.normal t list) = + let d_list ~(shallow : bool) (jplist : Prop.normal t list) = L.add_print_with_pe (pp_list ~shallow) jplist let rec gen_free_vars = let open Sequence.Generator in function - | Prop (_, p) -> - Prop.gen_free_vars p - | Joined (_, p, jp1, jp2) -> - Prop.gen_free_vars p >>= fun () -> gen_free_vars jp1 >>= fun () -> gen_free_vars jp2 + | Prop (_, p) -> + Prop.gen_free_vars p + | Joined (_, p, jp1, jp2) -> + Prop.gen_free_vars p >>= fun () -> gen_free_vars jp1 >>= fun () -> gen_free_vars jp2 let free_vars jp = Sequence.Generator.run (gen_free_vars jp) @@ -109,23 +109,23 @@ module Jprop = struct Joined (n, p', jp1', jp2') - let filter (f: 'a t -> 'b option) jpl = + let filter (f : 'a t -> 'b option) jpl = let rec do_filter acc = function | [] -> acc | (Prop _ as jp) :: jpl -> ( match f jp with Some x -> do_filter (x :: acc) jpl | None -> do_filter acc jpl ) - | (Joined (_, _, jp1, jp2) as jp) :: jpl -> + | (Joined (_, _, jp1, jp2) as jp) :: jpl -> ( match f jp with | Some x -> do_filter (x :: acc) jpl | None -> - do_filter acc (jpl @ [jp1; jp2]) + do_filter acc (jpl @ [jp1; jp2]) ) in do_filter [] jpl - let rec map (f: 'a Prop.t -> 'b Prop.t) = function + let rec map (f : 'a Prop.t -> 'b Prop.t) = function | Prop (n, p) -> Prop (n, f p) | Joined (n, p, jp1, jp2) -> @@ -178,7 +178,7 @@ end = struct let tospecs specs = specs - let gen_free_vars tenv (spec: Prop.normal spec) = + let gen_free_vars tenv (spec : Prop.normal spec) = let open Sequence.Generator in Jprop.sorted_gen_free_vars tenv spec.pre >>= fun () -> @@ -196,13 +196,15 @@ end = struct (** Convert spec into normal form w.r.t. variable renaming *) - let normalize tenv (spec: Prop.normal spec) : Prop.normal spec = + let normalize tenv (spec : Prop.normal spec) : Prop.normal spec = let idlist = free_vars tenv spec |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let count = ref 0 in let sub = Sil.subst_of_list (List.map - ~f:(fun id -> incr count ; (id, Exp.Var (Ident.create_normal Ident.name_spec !count))) + ~f:(fun id -> + incr count ; + (id, Exp.Var (Ident.create_normal Ident.name_spec !count)) ) idlist) in spec_sub tenv sub spec @@ -229,7 +231,7 @@ let normalized_specs_to_specs = NormSpec.tospecs type phase = FOOTPRINT | RE_EXECUTION [@@deriving compare] -let equal_phase = [%compare.equal : phase] +let equal_phase = [%compare.equal: phase] let string_of_phase = function FOOTPRINT -> "FOOTPRINT" | RE_EXECUTION -> "RE_EXECUTION" @@ -264,7 +266,7 @@ let pp_spec pe num_opt fmt spec = (** Dump a spec *) -let d_spec (spec: 'a spec) = +let d_spec (spec : 'a spec) = L.add_print (pp_spec (if Config.write_html then Pp.html Blue else Pp.text) None) spec diff --git a/infer/src/biabduction/Buckets.ml b/infer/src/biabduction/Buckets.ml index cca42136a..5410a0159 100644 --- a/infer/src/biabduction/Buckets.ml +++ b/infer/src/biabduction/Buckets.ml @@ -23,8 +23,7 @@ let check_nested_loop path pos_opt = match !loop_visits_log with | true :: true :: _ -> if verbose then L.d_strln "in nested loop" ; - true - (* last two loop visits were entering loops *) + true (* last two loop visits were entering loops *) | _ -> false in @@ -77,7 +76,7 @@ let check_access access_opt de_opt = let process_formal_letref = function | Sil.Load (id, Exp.Lvar pvar, _, _) -> let is_java_this = Language.curr_language_is Java && Pvar.is_this pvar in - if not is_java_this && is_formal pvar then Some id else None + if (not is_java_this) && is_formal pvar then Some id else None | _ -> None in @@ -147,8 +146,8 @@ let check_access access_opt de_opt = find_bucket n false | Some (Localise.Last_accessed (_, is_nullable)) when is_nullable -> Some Localise.BucketLevel.b1 - | _ -> - match de_opt with Some (DecompiledExp.Dconst _) -> Some Localise.BucketLevel.b1 | _ -> None + | _ -> ( + match de_opt with Some (DecompiledExp.Dconst _) -> Some Localise.BucketLevel.b1 | _ -> None ) let classify_access desc access_opt de_opt is_nullable = diff --git a/infer/src/biabduction/Buckets.mli b/infer/src/biabduction/Buckets.mli index 5df13b61a..f1c98ab22 100644 --- a/infer/src/biabduction/Buckets.mli +++ b/infer/src/biabduction/Buckets.mli @@ -11,6 +11,9 @@ open! IStd (** Classify bugs into buckets *) val classify_access : - Localise.error_desc -> Localise.access option -> DecompiledExp.t option -> bool + Localise.error_desc + -> Localise.access option + -> DecompiledExp.t option + -> bool -> Localise.error_desc (** Classify the bucket of an error desc using Location.access and nullable information *) diff --git a/infer/src/biabduction/BuiltinDefn.ml b/infer/src/biabduction/BuiltinDefn.ml index 5a66b79c6..af0e3cb3b 100644 --- a/infer/src/biabduction/BuiltinDefn.ml +++ b/infer/src/biabduction/BuiltinDefn.ml @@ -15,8 +15,8 @@ module L = Logging type t = Builtin.registered (** model va_arg as always returning 0 *) -let execute___builtin_va_arg {Builtin.pdesc; tenv; prop_; path; args; loc; exe_env} - : Builtin.ret_typ = +let execute___builtin_va_arg {Builtin.pdesc; tenv; prop_; path; args; loc; exe_env} : + Builtin.ret_typ = match args with | [_; _; (lexp3, typ3)] -> let instr' = Sil.Store (lexp3, typ3, Exp.zero, loc) in @@ -97,8 +97,8 @@ let execute___require_allocated_array {Builtin.tenv; pdesc; prop_; path; args} : raise (Exceptions.Wrong_argument_number __POS__) -let execute___get_array_length {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} - : Builtin.ret_typ = +let execute___get_array_length {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} : + Builtin.ret_typ = match args with | [(lexp, typ)] -> ( match add_array_to_prop tenv pdesc prop_ lexp typ with @@ -116,7 +116,7 @@ let execute___set_array_length {Builtin.tenv; pdesc; prop_; path; args} : Builti match add_array_to_prop tenv pdesc prop_ lexp typ with | None -> [] - | Some (_, prop_a) -> + | Some (_, prop_a) -> ( (* Invariant: prop_a has an array pointed to by lexp *) let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop__ = check_arith_norm_exp tenv pname lexp prop_a in @@ -133,7 +133,7 @@ let execute___set_array_length {Builtin.tenv; pdesc; prop_; path; args} : Builti [(Prop.normalize tenv prop', path)] | _ -> [] - (* by construction of prop_a this case is impossible *) ) + (* by construction of prop_a this case is impossible *) ) ) | _ -> raise (Exceptions.Wrong_argument_number __POS__) @@ -163,7 +163,7 @@ let create_type tenv n_lexp typ prop = with | Some _ -> prop - | None -> + | None -> ( let mhpred = match typ.Typ.desc with | Typ.Tptr (typ', _) -> @@ -200,7 +200,7 @@ let create_type tenv n_lexp typ prop = let prop'' = Prop.normalize tenv prop'' in prop'' | None -> - prop + prop ) in let sil_is_null = Exp.BinOp (Binop.Eq, n_lexp, Exp.zero) in let sil_is_nonnull = Exp.UnOp (Unop.LNot, sil_is_null, None) in @@ -221,7 +221,7 @@ let execute___get_type_of {Builtin.pdesc; tenv; prop_; path; ret_id_typ; args} : let hpred_opt = List.find_map ~f:(function - | Sil.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None) + | Sil.Hpointsto (e, _, texp) when Exp.equal e n_lexp -> Some texp | _ -> None) prop.Prop.sigma in match hpred_opt with @@ -256,8 +256,8 @@ let replace_ptsto_texp tenv prop root_e texp = Prop.normalize tenv prop'' -let execute___instanceof_cast ~instof {Builtin.pdesc; tenv; prop_; path; ret_id_typ; args} - : Builtin.ret_typ = +let execute___instanceof_cast ~instof {Builtin.pdesc; tenv; prop_; path; ret_id_typ; args} : + Builtin.ret_typ = match args with | [(val1_, typ1); (texp2_, _)] -> let pname = Procdesc.get_proc_name pdesc in @@ -280,8 +280,7 @@ let execute___instanceof_cast ~instof {Builtin.pdesc; tenv; prop_; path; ret_id_ ~f:(function Sil.Hpointsto (e1, _, _) -> Exp.equal e1 val1 | _ -> false) prop.Prop.sigma |> Option.map ~f:(function - | Sil.Hpointsto (_, _, texp1) - -> ( + | Sil.Hpointsto (_, _, texp1) -> ( let pos_type_opt, neg_type_opt = Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2 in @@ -372,8 +371,8 @@ let execute___set_file_attribute {Builtin.tenv; pdesc; prop_; path; args; loc} : (** Set the resource attribute of the first real argument of method as ignore, the first argument is assumed to be "this" *) -let execute___method_set_ignore_attribute {Builtin.tenv; pdesc; prop_; path; args; loc} - : Builtin.ret_typ = +let execute___method_set_ignore_attribute {Builtin.tenv; pdesc; prop_; path; args; loc} : + Builtin.ret_typ = match args with | [_; (lexp, _)] -> let pname = Procdesc.get_proc_name pdesc in @@ -442,7 +441,7 @@ let execute_abort {Builtin.proc_name} : Builtin.ret_typ = let execute_exit {Builtin.prop_; path} : Builtin.ret_typ = SymExec.diverge prop_ path -let execute_free_ tenv mk ?(mark_as_freed= true) loc acc iter = +let execute_free_ tenv mk ?(mark_as_freed = true) loc acc iter = match Prop.prop_iter_current tenv iter with | Sil.Hpointsto (lexp, _, _), [] -> let prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in @@ -470,7 +469,7 @@ let execute_free_ tenv mk ?(mark_as_freed= true) loc acc iter = (* should not happen *) -let execute_free_nonzero_ mk ?(mark_as_freed= true) pdesc tenv instr prop lexp typ loc = +let execute_free_nonzero_ mk ?(mark_as_freed = true) pdesc tenv instr prop lexp typ loc = try match Prover.is_root tenv prop lexp lexp with | None -> @@ -497,8 +496,8 @@ let execute_free_nonzero_ mk ?(mark_as_freed= true) pdesc tenv instr prop lexp t raise (Exceptions.Array_of_pointsto __POS__) ) -let execute_free mk ?(mark_as_freed= true) {Builtin.pdesc; instr; tenv; prop_; path; args; loc} - : Builtin.ret_typ = +let execute_free mk ?(mark_as_freed = true) {Builtin.pdesc; instr; tenv; prop_; path; args; loc} : + Builtin.ret_typ = match args with | [(lexp, typ)] -> let pname = Procdesc.get_proc_name pdesc in @@ -533,8 +532,8 @@ let execute_free mk ?(mark_as_freed= true) {Builtin.pdesc; instr; tenv; prop_; p This should behave correctly most of the time. *) let execute_free_cf mk = execute_free mk ~mark_as_freed:false -let execute_alloc mk can_return_null {Builtin.pdesc; tenv; prop_; path; ret_id_typ; args; loc} - : Builtin.ret_typ = +let execute_alloc mk can_return_null {Builtin.pdesc; tenv; prop_; path; ret_id_typ; args; loc} : + Builtin.ret_typ = let pname = Procdesc.get_proc_name pdesc in let rec evaluate_char_sizeof e = match e with @@ -607,10 +606,10 @@ let execute_alloc mk can_return_null {Builtin.pdesc; tenv; prop_; path; ret_id_t else [(prop_alloc, path)] -let execute___cxx_typeid ({Builtin.pdesc; tenv; prop_; args; loc; exe_env} as r) : Builtin.ret_typ = +let execute___cxx_typeid ({Builtin.pdesc; tenv; prop_; args; loc; exe_env} as r) : Builtin.ret_typ + = match args with - | type_info_exp :: rest - -> ( + | type_info_exp :: rest -> ( let res = execute_alloc PredSymb.Mnew false {r with args= [type_info_exp]} in match rest with | [(field_exp, _); (lexp, typ_)] -> @@ -635,11 +634,10 @@ let execute___cxx_typeid ({Builtin.pdesc; tenv; prop_; args; loc; exe_env} as r) raise (Exceptions.Wrong_argument_number __POS__) -let execute_pthread_create ({Builtin.tenv; pdesc; prop_; path; args; exe_env} as builtin_args) - : Builtin.ret_typ = +let execute_pthread_create ({Builtin.tenv; pdesc; prop_; path; args; exe_env} as builtin_args) : + Builtin.ret_typ = match args with - | [_; _; start_routine; arg] - -> ( + | [_; _; start_routine; arg] -> ( let routine_name = Prop.exp_normalize_prop tenv prop_ (fst start_routine) in let routine_arg = Prop.exp_normalize_prop tenv prop_ (fst arg) in let pname = @@ -659,7 +657,7 @@ let execute_pthread_create ({Builtin.tenv; pdesc; prop_; path; args; exe_env} as Sil.d_exp routine_name ; L.d_strln ", skipping call." ; [(prop_, path)] - | Some pname -> + | Some pname -> ( L.d_strln ("pthread_create: calling function " ^ Typ.Procname.to_string pname) ; match Ondemand.analyze_proc_name ~caller_pdesc:pdesc pname with | None -> @@ -667,15 +665,15 @@ let execute_pthread_create ({Builtin.tenv; pdesc; prop_; path; args; exe_env} as [(prop_, path)] | Some callee_summary -> SymExec.proc_call exe_env callee_summary - {builtin_args with args= [(routine_arg, snd arg)]} ) + {builtin_args with args= [(routine_arg, snd arg)]} ) ) | _ -> raise (Exceptions.Wrong_argument_number __POS__) let execute_skip {Builtin.prop_; path} : Builtin.ret_typ = [(prop_, path)] -let execute_scan_function skip_n_arguments ({Builtin.args; ret_id_typ} as call_args) - : Builtin.ret_typ = +let execute_scan_function skip_n_arguments ({Builtin.args; ret_id_typ} as call_args) : + Builtin.ret_typ = match args with | _ when List.length args >= skip_n_arguments -> let varargs = ref args in @@ -686,11 +684,10 @@ let execute_scan_function skip_n_arguments ({Builtin.args; ret_id_typ} as call_a raise (Exceptions.Wrong_argument_number __POS__) -let execute__unwrap_exception {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} - : Builtin.ret_typ = +let execute__unwrap_exception {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} : + Builtin.ret_typ = match args with - | [(ret_exn, _)] - -> ( + | [(ret_exn, _)] -> ( let pname = Procdesc.get_proc_name pdesc in let n_ret_exn, prop = check_arith_norm_exp tenv pname ret_exn prop_ in match n_ret_exn with @@ -703,8 +700,8 @@ let execute__unwrap_exception {Builtin.tenv; pdesc; prop_; path; ret_id_typ; arg raise (Exceptions.Wrong_argument_number __POS__) -let execute_return_first_argument {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} - : Builtin.ret_typ = +let execute_return_first_argument {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} : + Builtin.ret_typ = match args with | (arg1_, _) :: _ -> let pname = Procdesc.get_proc_name pdesc in @@ -715,17 +712,16 @@ let execute_return_first_argument {Builtin.tenv; pdesc; prop_; path; ret_id_typ; raise (Exceptions.Wrong_argument_number __POS__) -let execute___split_get_nth {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} : Builtin.ret_typ = +let execute___split_get_nth {Builtin.tenv; pdesc; prop_; path; ret_id_typ; args} : Builtin.ret_typ + = match args with - | [(lexp1, _); (lexp2, _); (lexp3, _)] - -> ( + | [(lexp1, _); (lexp2, _); (lexp3, _)] -> ( let pname = Procdesc.get_proc_name pdesc in let n_lexp1, prop__ = check_arith_norm_exp tenv pname lexp1 prop_ in let n_lexp2, prop___ = check_arith_norm_exp tenv pname lexp2 prop__ in let n_lexp3, prop = check_arith_norm_exp tenv pname lexp3 prop___ in match (n_lexp1, n_lexp2, n_lexp3) with - | Exp.Const (Const.Cstr str1), Exp.Const (Const.Cstr str2), Exp.Const (Const.Cint n_sil) - -> ( + | Exp.Const (Const.Cstr str1), Exp.Const (Const.Cstr str2), Exp.Const (Const.Cint n_sil) -> ( let n = IntLit.to_int_exn n_sil in try let parts = Str.split (Str.regexp_string str2) str1 in @@ -771,7 +767,8 @@ let execute___infer_fail {Builtin.pdesc; tenv; prop_; path; args; loc; exe_env} (* translate builtin assertion failure *) -let execute___assert_fail {Builtin.pdesc; tenv; prop_; path; args; loc; exe_env} : Builtin.ret_typ = +let execute___assert_fail {Builtin.pdesc; tenv; prop_; path; args; loc; exe_env} : Builtin.ret_typ + = let error_str = match List.length args with | 4 -> diff --git a/infer/src/biabduction/Dom.ml b/infer/src/biabduction/Dom.ml index a22e3f40e..88c82df36 100644 --- a/infer/src/biabduction/Dom.ml +++ b/infer/src/biabduction/Dom.ml @@ -461,7 +461,7 @@ end = struct let rec f_eqs_entry ((e1, e2, e) as entry) eqs_acc t_seen = function | [] -> (eqs_acc, t_seen) - | ((e1', e2', e') as entry') :: t_rest' -> + | ((e1', e2', e') as entry') :: t_rest' -> ( match List.find ~f:(fun n -> add_and_chk_eq e1 e1' n && add_and_chk_eq e2 e2' n) minus2_to_2 |> Option.map ~f:(fun n -> @@ -473,7 +473,7 @@ end = struct res | None -> let t_seen' = entry' :: t_seen in - f_eqs_entry entry eqs_acc t_seen' t_rest' + f_eqs_entry entry eqs_acc t_seen' t_rest' ) in let rec f_eqs eqs_acc t_acc = function | [] -> @@ -588,26 +588,26 @@ end = struct let res = ref [] in let f v = match (v, side) with - | (Exp.BinOp (Binop.PlusA, e1', Exp.Const (Const.Cint i)), e2, e'), Lhs when Exp.equal e e1' -> + | (Exp.BinOp (Binop.PlusA, e1', Exp.Const (Const.Cint i)), e2, e'), Lhs when Exp.equal e e1' + -> let c' = Exp.int (IntLit.neg i) in let v' = (e1', Exp.BinOp (Binop.PlusA, e2, c'), Exp.BinOp (Binop.PlusA, e', c')) in res := v' :: !res - | (e1, Exp.BinOp (Binop.PlusA, e2', Exp.Const (Const.Cint i)), e'), Rhs when Exp.equal e e2' -> + | (e1, Exp.BinOp (Binop.PlusA, e2', Exp.Const (Const.Cint i)), e'), Rhs when Exp.equal e e2' + -> let c' = Exp.int (IntLit.neg i) in let v' = (Exp.BinOp (Binop.PlusA, e1, c'), e2', Exp.BinOp (Binop.PlusA, e', c')) in res := v' :: !res | _ -> () in - List.iter ~f !tbl ; - List.rev !res + List.iter ~f !tbl ; List.rev !res (* Return the triple whose side is [e], if it exists unique *) let lookup' todo side e : Exp.t = match e with - | Exp.Var id when can_rename id - -> ( + | Exp.Var id when can_rename id -> ( let r = lookup_side' side e in match r with | [((_, _, id) as t)] -> @@ -630,7 +630,7 @@ end = struct let lookup_list_todo side l = List.map ~f:(lookup_todo side) l - let to_subst_proj (side: side) vars = + let to_subst_proj (side : side) vars = let renaming_restricted = List.filter ~f:(function _, _, Exp.Var i -> Ident.HashQueue.mem vars i | _ -> assert false) @@ -655,7 +655,7 @@ end = struct else Sil.exp_subst_of_list sub_list_side - let to_subst_emb (side: side) = + let to_subst_emb (side : side) = let renaming_restricted = let pick_id_case (e1, e2, _) = match select side e1 e2 with Exp.Var i -> can_rename i | _ -> false @@ -696,8 +696,7 @@ end = struct let get_others_deep side = function - | Exp.BinOp (op, e, e') - -> ( + | Exp.BinOp (op, e, e') -> ( let others = get_others_direct_or_induced side e in let others' = get_others_direct_or_induced side e' in match (others, others') with @@ -747,10 +746,10 @@ end = struct when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> build_other_atoms (fun e0 -> Prop.mk_neq tenv e0 e') side e | Sil.Apred (a, (Var id as e) :: es) - when not (Ident.is_normal id) && List.for_all ~f:exp_contains_only_normal_ids es -> + when (not (Ident.is_normal id)) && List.for_all ~f:exp_contains_only_normal_ids es -> build_other_atoms (fun e0 -> Prop.mk_pred tenv a (e0 :: es)) side e | Sil.Anpred (a, (Var id as e) :: es) - when not (Ident.is_normal id) && List.for_all ~f:exp_contains_only_normal_ids es -> + when (not (Ident.is_normal id)) && List.for_all ~f:exp_contains_only_normal_ids es -> build_other_atoms (fun e0 -> Prop.mk_npred tenv a (e0 :: es)) side e | Sil.Aeq ((Exp.Var id as e), e') when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> @@ -792,7 +791,7 @@ end = struct in let e = if - not (Exp.free_vars e1 |> Sequence.exists ~f:can_rename) + (not (Exp.free_vars e1 |> Sequence.exists ~f:can_rename)) && not (Exp.free_vars e2 |> Sequence.exists ~f:can_rename) then if Exp.equal e1 e2 then e1 else ( L.d_strln "failure reason 13" ; raise Sil.JoinFail ) @@ -879,7 +878,7 @@ let ident_same_kind_primed_footprint id1 id2 = (Ident.is_primed id1 && Ident.is_primed id2) || (Ident.is_footprint id1 && Ident.is_footprint id2) -let ident_partial_join (id1: Ident.t) (id2: Ident.t) = +let ident_partial_join (id1 : Ident.t) (id2 : Ident.t) = match (Ident.is_normal id1, Ident.is_normal id2) with | true, true -> if Ident.equal id1 id2 then Exp.Var id1 @@ -895,7 +894,7 @@ let ident_partial_join (id1: Ident.t) (id2: Ident.t) = Rename.extend e1 e2 Rename.ExtFresh -let ident_partial_meet (id1: Ident.t) (id2: Ident.t) = +let ident_partial_meet (id1 : Ident.t) (id2 : Ident.t) = match (Ident.is_normal id1, Ident.is_normal id2) with | true, true -> if Ident.equal id1 id2 then Exp.Var id1 @@ -930,7 +929,7 @@ let const_partial_join c1 c2 = else ( L.d_strln "failure reason 19" ; raise Sil.JoinFail ) -let rec exp_partial_join (e1: Exp.t) (e2: Exp.t) : Exp.t = +let rec exp_partial_join (e1 : Exp.t) (e2 : Exp.t) : Exp.t = (* L.d_str "exp_partial_join "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) match (e1, e2) with | Exp.Var id1, Exp.Var id2 -> @@ -964,8 +963,7 @@ let rec exp_partial_join (e1: Exp.t) (e2: Exp.t) : Exp.t = Exp.Cast (t1, e1'') | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) -> if not (Unop.equal unop1 unop2) then ( L.d_strln "failure reason 23" ; raise Sil.JoinFail ) - else Exp.UnOp (unop1, exp_partial_join e1 e2, topt1) - (* should be topt1 = topt2 *) + else Exp.UnOp (unop1, exp_partial_join e1 e2, topt1) (* should be topt1 = topt2 *) | Exp.BinOp (Binop.PlusPI, e1, e1'), Exp.BinOp (Binop.PlusPI, e2, e2') -> let e1'' = exp_partial_join e1 e2 in let e2'' = @@ -987,8 +985,7 @@ let rec exp_partial_join (e1: Exp.t) (e2: Exp.t) : Exp.t = else e1 | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) -> if not (Typ.Fieldname.equal f1 f2) then ( L.d_strln "failure reason 26" ; raise Sil.JoinFail ) - else Exp.Lfield (exp_partial_join e1 e2, f1, t1) - (* should be t1 = t2 *) + else Exp.Lfield (exp_partial_join e1 e2, f1, t1) (* should be t1 = t2 *) | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') -> let e1'' = exp_partial_join e1 e2 in let e2'' = exp_partial_join e1' e2' in @@ -1033,7 +1030,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: Typ.t) (t2: Typ.t) = +and typ_partial_join (t1 : Typ.t) (t2 : Typ.t) = match (t1.desc, t2.desc) with | Typ.Tptr (t1, pk1), Typ.Tptr (t2, pk2) when Typ.equal_ptr_kind pk1 pk2 && Typ.equal_quals t1.quals t2.quals -> @@ -1058,7 +1055,7 @@ and typ_partial_join (t1: Typ.t) (t2: Typ.t) = raise Sil.JoinFail -let rec exp_partial_meet (e1: Exp.t) (e2: Exp.t) : Exp.t = +let rec exp_partial_meet (e1 : Exp.t) (e2 : Exp.t) : Exp.t = match (e1, e2) with | Exp.Var id1, Exp.Var id2 -> ident_partial_meet id1 id2 @@ -1077,8 +1074,7 @@ let rec exp_partial_meet (e1: Exp.t) (e2: Exp.t) : Exp.t = Exp.Cast (t1, e1'') | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) -> if not (Unop.equal unop1 unop2) then ( L.d_strln "failure reason 31" ; raise Sil.JoinFail ) - else Exp.UnOp (unop1, exp_partial_meet e1 e2, topt1) - (* should be topt1 = topt2 *) + else Exp.UnOp (unop1, exp_partial_meet e1 e2, topt1) (* should be topt1 = topt2 *) | Exp.BinOp (binop1, e1, e1'), Exp.BinOp (binop2, e2, e2') -> if not (Binop.equal binop1 binop2) then ( L.d_strln "failure reason 32" ; raise Sil.JoinFail ) else @@ -1096,8 +1092,7 @@ let rec exp_partial_meet (e1: Exp.t) (e2: Exp.t) : Exp.t = else e1 | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) -> if not (Typ.Fieldname.equal f1 f2) then ( L.d_strln "failure reason 36" ; raise Sil.JoinFail ) - else Exp.Lfield (exp_partial_meet e1 e2, f1, t1) - (* should be t1 = t2 *) + else Exp.Lfield (exp_partial_meet e1 e2, f1, t1) (* should be t1 = t2 *) | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') -> let e1'' = exp_partial_meet e1 e2 in let e2'' = exp_partial_meet e1' e2' in @@ -1112,7 +1107,7 @@ let exp_list_partial_meet = List.map2_exn ~f:exp_partial_meet (** {2 Join and Meet for Strexp} *) -let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.strexp = +let rec strexp_partial_join mode (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : Sil.strexp = let rec f_fld_se_list inst mode acc fld_se_list1 fld_se_list2 = match (fld_se_list1, fld_se_list2) with | [], [] -> @@ -1123,7 +1118,7 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S L.d_strln "failure reason 42" ; raise Sil.JoinFail | JoinState.Post -> Sil.Estruct (List.rev acc, inst) ) - | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' -> + | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' -> ( let comparison = Typ.Fieldname.compare fld1 fld2 in if Int.equal comparison 0 then let strexp' = strexp_partial_join mode se1 se2 in @@ -1136,7 +1131,7 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S | JoinState.Post -> if comparison < 0 then f_fld_se_list inst mode acc fld_se_list1' fld_se_list2 else if comparison > 0 then f_fld_se_list inst mode acc fld_se_list1 fld_se_list2' - else assert false + else assert false ) (* This case should not happen. *) in let rec f_idx_se_list inst len idx_se_list_acc idx_se_list1 idx_se_list2 = @@ -1170,7 +1165,7 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S raise Sil.JoinFail -let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.strexp = +let rec strexp_partial_meet (strexp1 : Sil.strexp) (strexp2 : Sil.strexp) : Sil.strexp = let construct side rev_list ref_list = let construct_offset_se (off, se) = (off, strexp_construct_fresh side se) in let acc = List.map ~f:construct_offset_se ref_list in @@ -1249,25 +1244,25 @@ let kind_meet k1 k2 = Sil.Lseg_PE -let hpara_partial_join tenv (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara = +let hpara_partial_join tenv (hpara1 : Sil.hpara) (hpara2 : Sil.hpara) : Sil.hpara = if Match.hpara_match_with_impl tenv true hpara2 hpara1 then hpara1 else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then hpara2 else ( L.d_strln "failure reason 53" ; raise Sil.JoinFail ) -let hpara_partial_meet tenv (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara = +let hpara_partial_meet tenv (hpara1 : Sil.hpara) (hpara2 : Sil.hpara) : Sil.hpara = if Match.hpara_match_with_impl tenv true hpara2 hpara1 then hpara2 else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then hpara1 else ( L.d_strln "failure reason 54" ; raise Sil.JoinFail ) -let hpara_dll_partial_join tenv (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll = +let hpara_dll_partial_join tenv (hpara1 : Sil.hpara_dll) (hpara2 : Sil.hpara_dll) : Sil.hpara_dll = if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then hpara1 else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then hpara2 else ( L.d_strln "failure reason 55" ; raise Sil.JoinFail ) -let hpara_dll_partial_meet tenv (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll = +let hpara_dll_partial_meet tenv (hpara1 : Sil.hpara_dll) (hpara2 : Sil.hpara_dll) : Sil.hpara_dll = if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then hpara2 else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then hpara1 else ( L.d_strln "failure reason 56" ; raise Sil.JoinFail ) @@ -1275,8 +1270,8 @@ let hpara_dll_partial_meet tenv (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) (** {2 Join and Meet for hpred} *) -let hpred_partial_join tenv mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) - (hpred2: Sil.hpred) : Sil.hpred = +let hpred_partial_join tenv mode (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Sil.hpred) + (hpred2 : Sil.hpred) : Sil.hpred = let e1, e2, e = todo in match (hpred1, hpred2) with | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) -> @@ -1294,7 +1289,7 @@ let hpred_partial_join tenv mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpre let hpara' = hpara_dll_partial_join tenv para1 para2 in let iF', iB' = if fwd1 && fwd2 then (e, exp_partial_join iB1 iB2) - else if not fwd1 && not fwd2 then (exp_partial_join iF1 iF2, e) + else if (not fwd1) && not fwd2 then (exp_partial_join iF1 iF2, e) else ( L.d_strln "failure reason 57" ; raise Sil.JoinFail ) in let oF' = exp_partial_join oF1 oF2 in @@ -1305,8 +1300,8 @@ let hpred_partial_join tenv mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpre assert false -let hpred_partial_meet tenv (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2: Sil.hpred) - : Sil.hpred = +let hpred_partial_meet tenv (todo : Exp.t * Exp.t * Exp.t) (hpred1 : Sil.hpred) + (hpred2 : Sil.hpred) : Sil.hpred = let e1, e2, e = todo in match (hpred1, hpred2) with | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) when Exp.equal te1 te2 -> @@ -1325,7 +1320,7 @@ let hpred_partial_meet tenv (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (h let hpara' = hpara_dll_partial_meet tenv para1 para2 in let iF', iB' = if fwd1 && fwd2 then (e, exp_partial_meet iB1 iB2) - else if not fwd1 && not fwd2 then (exp_partial_meet iF1 iF2, e) + else if (not fwd1) && not fwd2 then (exp_partial_meet iF1 iF2, e) else ( L.d_strln "failure reason 59" ; raise Sil.JoinFail ) in let oF' = exp_partial_meet oF1 oF2 in @@ -1338,7 +1333,7 @@ let hpred_partial_meet tenv (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (h (** {2 Join and Meet for Sigma} *) -let find_hpred_by_address tenv (e: Exp.t) (sigma: Prop.sigma) : Sil.hpred option * Prop.sigma = +let find_hpred_by_address tenv (e : Exp.t) (sigma : Prop.sigma) : Sil.hpred option * Prop.sigma = let is_root_for_e e' = match Prover.is_root tenv Prop.prop_emp e' e with None -> false | Some _ -> true in @@ -1360,7 +1355,7 @@ let find_hpred_by_address tenv (e: Exp.t) (sigma: Prop.sigma) : Sil.hpred option f [] sigma -let same_pred (hpred1: Sil.hpred) (hpred2: Sil.hpred) : bool = +let same_pred (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : bool = match (hpred1, hpred2) with | Sil.Hpointsto _, Sil.Hpointsto _ -> true @@ -1375,7 +1370,7 @@ let same_pred (hpred1: Sil.hpred) (hpred2: Sil.hpred) : bool = (* check that applying renaming to the lhs / rhs of [sigma_new] * gives [sigma] and that the renaming is injective *) -let sigma_renaming_check (lhs: side) (sigma: Prop.sigma) (sigma_new: Prop.sigma) = +let sigma_renaming_check (lhs : side) (sigma : Prop.sigma) (sigma_new : Prop.sigma) = (* apply the lhs / rhs of the renaming to sigma, * and check that the renaming of primed vars is injective *) let fav_sigma = Prop.sigma_free_vars sigma_new |> Ident.hashqueue_of_sequence in @@ -1388,8 +1383,8 @@ let sigma_renaming_check_lhs = sigma_renaming_check Lhs let sigma_renaming_check_rhs = sigma_renaming_check Rhs -let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) - (sigma2_in: Prop.sigma) : Prop.sigma * Prop.sigma * Prop.sigma = +let rec sigma_partial_join' tenv mode (sigma_acc : Prop.sigma) (sigma1_in : Prop.sigma) + (sigma2_in : Prop.sigma) : Prop.sigma * Prop.sigma * Prop.sigma = let lookup_and_expand side e e' = match (Rename.get_others side e, side) with | None, _ -> @@ -1404,7 +1399,8 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s | Sil.Hlseg (_, hpara, root, next, shared) -> let next' = do_side side exp_partial_join next opposite in let shared' = Rename.lookup_list side shared in - CheckJoin.add side root next ; Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared') + CheckJoin.add side root next ; + Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared') | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iF e -> let oF' = do_side side exp_partial_join oF opposite in let shared' = Rename.lookup_list side shared in @@ -1451,7 +1447,7 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s (* Drop the part of 'other' sigma corresponding to 'target' sigma if possible. 'side' describes that target is Lhs or Rhs. 'todo' describes the start point. *) - let cut_sigma side todo (target: Prop.sigma) (other: Prop.sigma) = + let cut_sigma side todo (target : Prop.sigma) (other : Prop.sigma) = let list_is_empty l = if l <> [] then ( L.d_strln "failure reason 61" ; raise Sil.JoinFail ) in let x = Todo.take () in Todo.push todo ; @@ -1512,13 +1508,13 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s sigma_partial_join' tenv mode sigma_acc sigma1 sigma2 | Some (Sil.Hlseg (k, _, _, _, _) as lseg), None | Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg), None -> - if not Config.nelseg || Sil.equal_lseg_kind k Sil.Lseg_PE then + if (not Config.nelseg) || Sil.equal_lseg_kind k Sil.Lseg_PE then let sigma_acc' = join_list_and_non Lhs e lseg e1 e2 :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2 else ( L.d_strln "failure reason 62" ; raise Sil.JoinFail ) | None, Some (Sil.Hlseg (k, _, _, _, _) as lseg) | None, Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg) -> - if not Config.nelseg || Sil.equal_lseg_kind k Sil.Lseg_PE then + if (not Config.nelseg) || Sil.equal_lseg_kind k Sil.Lseg_PE then let sigma_acc' = join_list_and_non Rhs e lseg e2 e1 :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2 else ( L.d_strln "failure reason 63" ; raise Sil.JoinFail ) @@ -1567,17 +1563,17 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s | Some (Sil.Hpointsto _), Some (Sil.Hpointsto _) -> assert false (* Should be handled by a guarded case *) - with Todo.Empty -> + with Todo.Empty -> ( match (sigma1_in, sigma2_in) with | _ :: _, _ :: _ -> L.d_strln "todo is empty, but the sigmas are not" ; raise Sil.JoinFail | _ -> - (sigma_acc, sigma1_in, sigma2_in) + (sigma_acc, sigma1_in, sigma2_in) ) -let sigma_partial_join tenv mode (sigma1: Prop.sigma) (sigma2: Prop.sigma) - : Prop.sigma * Prop.sigma * Prop.sigma = +let sigma_partial_join tenv mode (sigma1 : Prop.sigma) (sigma2 : Prop.sigma) : + Prop.sigma * Prop.sigma * Prop.sigma = CheckJoin.init mode sigma1 sigma2 ; let lost_little = CheckJoin.lost_little in let s1, s2, s3 = sigma_partial_join' tenv mode [] sigma1 sigma2 in @@ -1588,8 +1584,8 @@ let sigma_partial_join tenv mode (sigma1: Prop.sigma) (sigma2: Prop.sigma) ~finally:CheckJoin.final -let rec sigma_partial_meet' tenv (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) - (sigma2_in: Prop.sigma) : Prop.sigma = +let rec sigma_partial_meet' tenv (sigma_acc : Prop.sigma) (sigma1_in : Prop.sigma) + (sigma2_in : Prop.sigma) : Prop.sigma = try let todo_curr = Todo.pop () in let e1, e2, e = todo_curr in @@ -1626,16 +1622,16 @@ let rec sigma_partial_meet' tenv (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) sigma_partial_meet' tenv (hpred' :: sigma_acc) sigma1 sigma2 | Some _, Some _ -> L.d_strln "failure reason 65" ; raise Sil.JoinFail - with Todo.Empty -> + with Todo.Empty -> ( match (sigma1_in, sigma2_in) with | [], [] -> sigma_acc | _, _ -> L.d_strln "todo is empty, but the sigmas are not" ; - raise Sil.JoinFail + raise Sil.JoinFail ) -let sigma_partial_meet tenv (sigma1: Prop.sigma) (sigma2: Prop.sigma) : Prop.sigma = +let sigma_partial_meet tenv (sigma1 : Prop.sigma) (sigma2 : Prop.sigma) : Prop.sigma = sigma_partial_meet' tenv [] sigma1 sigma2 @@ -1650,8 +1646,8 @@ let widening_bottom = (** {2 Join and Meet for Pi} *) -let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) (pi1: Prop.pi) - (pi2: Prop.pi) : Prop.pi = +let pi_partial_join tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.exposed Prop.t) + (pi1 : Prop.pi) (pi2 : Prop.pi) : Prop.pi = let get_array_len prop = (* find some array length in the prop, to be used as heuritic for upper bound in widening *) let len_list = ref [] in @@ -1686,7 +1682,7 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop let bound = widening_top in let a' = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e, Exp.int bound)) in Some a' - | _ -> + | _ -> ( match Prop.atom_const_lt_exp a with | None -> None @@ -1695,7 +1691,7 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop if IntLit.leq IntLit.minus_one n then IntLit.minus_one else widening_bottom in let a' = Prop.mk_inequality tenv (Exp.BinOp (Binop.Lt, Exp.int bound, e)) in - Some a' + Some a' ) in let is_stronger_le e n a = match Prop.atom_exp_le_const a with @@ -1733,7 +1729,7 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop match Rename.get_other_atoms tenv side a with | None -> None - | Some (a_res, a_op) -> + | Some (a_res, 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 @@ -1748,6 +1744,7 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop else Some a_res ) | Some (e, n) -> if List.exists ~f:(is_stronger_le e n) pi_op then widening_atom a_res else Some a_res + ) in let handle_atom_with_widening len p_op pi_op atom_list a = (* find a join for the atom, if it fails apply widening heuristing and try again *) @@ -1756,8 +1753,8 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop match widening_atom a with | None -> atom_list - | Some a' -> - match join_atom len p_op pi_op a' with None -> atom_list | Some a' -> a' :: atom_list ) + | Some a' -> ( + match join_atom len p_op pi_op a' with None -> atom_list | Some a' -> a' :: atom_list ) ) | Some a' -> a' :: atom_list in @@ -1779,8 +1776,8 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop atom_list_combined -let pi_partial_meet tenv (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop.t) - : Prop.normal Prop.t = +let pi_partial_meet tenv (p : Prop.normal Prop.t) (ep1 : 'a Prop.t) (ep2 : 'b Prop.t) : + Prop.normal Prop.t = let sub1 = Rename.to_subst_emb Lhs in let sub2 = Rename.to_subst_emb Rhs in let dom1 = Ident.idlist_to_idset (Sil.sub_domain sub1) in @@ -1804,7 +1801,7 @@ let pi_partial_meet tenv (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop. (** {2 Join and Meet for Prop} *) -let eprop_partial_meet tenv (ep1: 'a Prop.t) (ep2: 'b Prop.t) : 'c Prop.t = +let eprop_partial_meet tenv (ep1 : 'a Prop.t) (ep2 : 'b Prop.t) : 'c Prop.t = SymOp.pay () ; (* pay one symop *) let sigma1 = ep1.Prop.sigma in @@ -1843,8 +1840,8 @@ let prop_partial_meet tenv p1 p2 = with Sil.JoinFail -> None -let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) - : Prop.normal Prop.t = +let eprop_partial_join' tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.exposed Prop.t) : + Prop.normal Prop.t = SymOp.pay () ; (* pay one symop *) let sigma1 = ep1.Prop.sigma in @@ -1907,8 +1904,8 @@ let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed L.d_strln "leftovers not empty" ; raise Sil.JoinFail -let footprint_partial_join' tenv (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.t) - : Prop.normal Prop.t * Prop.normal Prop.t = +let footprint_partial_join' tenv (p1 : Prop.normal Prop.t) (p2 : Prop.normal Prop.t) : + Prop.normal Prop.t * Prop.normal Prop.t = if not !Config.footprint then (p1, p2) else let fp1 = Prop.extract_footprint p1 in @@ -1940,8 +1937,7 @@ let prop_partial_join pname tenv mode p1 p2 = else None in match res_by_implication_only with - | None - -> ( + | None -> ( if !Config.footprint then JoinState.set_footprint true ; Rename.init () ; FreshVarExp.init () ; @@ -1961,8 +1957,8 @@ let prop_partial_join pname tenv mode p1 p2 = res_by_implication_only -let eprop_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) - : Prop.normal Prop.t = +let eprop_partial_join tenv mode (ep1 : Prop.exposed Prop.t) (ep2 : Prop.exposed Prop.t) : + Prop.normal Prop.t = Rename.init () ; FreshVarExp.init () ; Todo.init () ; @@ -1977,7 +1973,7 @@ let list_reduce name dd f list = let rec element_list_reduce acc (x, p1) = function | [] -> ((x, p1), List.rev acc) - | (y, p2) :: ys -> + | (y, p2) :: ys -> ( L.d_strln ("COMBINE[" ^ name ^ "] ....") ; L.d_str "ENTRY1: " ; L.d_ln () ; @@ -1997,7 +1993,7 @@ let list_reduce name dd f list = L.d_strln "RESULT:" ; dd x' ; L.d_ln () ; - element_list_reduce acc (x', p1) ys + element_list_reduce acc (x', p1) ys ) in let rec reduce acc = function | [] -> @@ -2042,11 +2038,13 @@ let jprop_list_add_ids jplist = let seq_number = ref 0 in let rec do_jprop = function | BiabductionSummary.Jprop.Prop (_, p) -> - incr seq_number ; BiabductionSummary.Jprop.Prop (!seq_number, p) + incr seq_number ; + BiabductionSummary.Jprop.Prop (!seq_number, p) | BiabductionSummary.Jprop.Joined (_, p, jp1, jp2) -> let jp1' = do_jprop jp1 in let jp2' = do_jprop jp2 in - incr seq_number ; BiabductionSummary.Jprop.Joined (!seq_number, p, jp1', jp2') + incr seq_number ; + BiabductionSummary.Jprop.Joined (!seq_number, p, jp1', jp2') in List.map ~f:(fun (p, path) -> (do_jprop p, path)) jplist @@ -2069,8 +2067,8 @@ let pathset_collapse tenv pset = (List.map ~f:(fun (p, path) -> (BiabductionSummary.Jprop.to_prop p, path)) plist') -let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) - : Paths.PathSet.t * Paths.PathSet.t = +let pathset_join pname tenv (pset1 : Paths.PathSet.t) (pset2 : Paths.PathSet.t) : + Paths.PathSet.t * Paths.PathSet.t = let mode = JoinState.Post in let pset_to_plist pset = let f_list p pa acc = (p, pa) :: acc in @@ -2081,7 +2079,7 @@ let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) let rec join_proppath_plist ppalist2_acc ((p2, pa2) as ppa2) = function | [] -> (ppa2, List.rev ppalist2_acc) - | ((p2', pa2') as ppa2') :: ppalist2_rest -> + | ((p2', pa2') as ppa2') :: ppalist2_rest -> ( L.d_strln ".... JOIN ...." ; L.d_strln "JOIN SYM HEAP1: " ; Prop.d_prop p2 ; @@ -2101,7 +2099,7 @@ let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) Prop.d_prop p2'' ; L.d_ln () ; L.d_ln () ; - join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest + join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest ) in let rec join ppalist1_cur ppalist2_acc = function | [] -> diff --git a/infer/src/biabduction/Dom.mli b/infer/src/biabduction/Dom.mli index ddbb51afd..e3ae79ad8 100644 --- a/infer/src/biabduction/Dom.mli +++ b/infer/src/biabduction/Dom.mli @@ -13,7 +13,10 @@ open! IStd (** {2 Join Operators} *) val pathset_join : - Typ.Procname.t -> Tenv.t -> Paths.PathSet.t -> Paths.PathSet.t + Typ.Procname.t + -> Tenv.t + -> Paths.PathSet.t + -> Paths.PathSet.t -> Paths.PathSet.t * Paths.PathSet.t (** Join two pathsets *) diff --git a/infer/src/biabduction/JoinState.ml b/infer/src/biabduction/JoinState.ml index 36bb9a587..a33e680bc 100644 --- a/infer/src/biabduction/JoinState.ml +++ b/infer/src/biabduction/JoinState.ml @@ -11,7 +11,7 @@ open! IStd type mode = Pre | Post [@@deriving compare] -let equal_mode = [%compare.equal : mode] +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/biabduction/Match.ml b/infer/src/biabduction/Match.ml index eac509679..f64f93093 100644 --- a/infer/src/biabduction/Match.ml +++ b/infer/src/biabduction/Match.ml @@ -72,12 +72,12 @@ let rec exp_match e1 sub vars e2 : (Sil.exp_subst * Ident.t list) option = exp_match e1' sub vars e2' | Exp.Lfield _, _ | _, Exp.Lfield _ -> None - | Exp.Lindex (base1, idx1), Exp.Lindex (base2, idx2) -> + | Exp.Lindex (base1, idx1), Exp.Lindex (base2, idx2) -> ( match exp_match base1 sub vars base2 with | None -> None | Some (sub', vars') -> - exp_match idx1 sub' vars' idx2 + exp_match idx1 sub' vars' idx2 ) let exp_list_match es1 sub vars es2 = @@ -107,12 +107,12 @@ let rec strexp_match sexp1 sub vars sexp2 : (Sil.exp_subst * Ident.t list) optio fsel_match fsel1 sub vars fsel2 | Sil.Estruct _, _ | _, Sil.Estruct _ -> None - | Sil.Earray (len1, isel1, _), Sil.Earray (len2, isel2, _) -> + | Sil.Earray (len1, isel1, _), Sil.Earray (len2, isel2, _) -> ( match exp_match len1 sub vars len2 with | Some (sub', vars') -> isel_match isel1 sub' vars' isel2 | None -> - None + None ) (** Checks fsel1 = fsel2[sub ++ sub'] for some sub' with @@ -124,8 +124,8 @@ and fsel_match fsel1 sub vars fsel2 = | [], _ -> None | _, [] -> - if Config.abs_struct <= 0 then None else Some (sub, vars) - (* This can lead to great information loss *) + if Config.abs_struct <= 0 then None + else Some (sub, vars) (* This can lead to great information loss *) | (fld1, se1') :: fsel1', (fld2, se2') :: fsel2' -> let n = Typ.Fieldname.compare fld1 fld2 in if Int.equal n 0 then @@ -168,7 +168,7 @@ and isel_match isel1 sub vars isel2 = (* extends substitution sub by creating a new substitution for vars *) -let sub_extend_with_ren (sub: Sil.exp_subst) vars = +let sub_extend_with_ren (sub : Sil.exp_subst) vars = let f id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in let renaming_for_vars = Sil.exp_subst_of_list (List.map ~f vars) in Sil.sub_join sub renaming_for_vars @@ -181,15 +181,15 @@ let rec execute_with_backtracking = function None | [f] -> f () - | f :: fs -> + | f :: fs -> ( let res_f = f () in - match res_f with None -> execute_with_backtracking fs | Some _ -> res_f + match res_f with None -> execute_with_backtracking fs | Some _ -> res_f ) -let rec instantiate_to_emp p condition (sub: Sil.exp_subst) vars = function +let rec instantiate_to_emp p condition (sub : Sil.exp_subst) vars = function | [] -> if condition p sub then Some (sub, p) else None - | hpat :: hpats -> + | hpat :: hpats -> ( if not hpat.flag then None else match hpat.hpred with @@ -197,8 +197,7 @@ let rec instantiate_to_emp p condition (sub: Sil.exp_subst) vars = function | Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) | Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) -> None - | Sil.Hlseg (_, _, e1, e2, _) - -> ( + | Sil.Hlseg (_, _, e1, e2, _) -> ( let fully_instantiated = not (List.exists ~f:(fun id -> Exp.ident_mem e1 id) vars) in if not fully_instantiated then None else @@ -208,7 +207,7 @@ let rec instantiate_to_emp p condition (sub: Sil.exp_subst) vars = function None | Some (sub_new, vars_leftover) -> instantiate_to_emp p condition sub_new vars_leftover hpats ) - | Sil.Hdllseg (_, _, iF, oB, oF, iB, _) -> + | Sil.Hdllseg (_, _, iF, oB, oF, iB, _) -> ( let fully_instantiated = not (List.exists ~f:(fun id -> Exp.ident_mem iF id || Exp.ident_mem oB id) vars) in @@ -220,7 +219,7 @@ let rec instantiate_to_emp p condition (sub: Sil.exp_subst) vars = function | None -> None | Some (sub_new, vars_leftover) -> - instantiate_to_emp p condition sub_new vars_leftover hpats + instantiate_to_emp p condition sub_new vars_leftover hpats ) ) (* This function has to be changed in order to @@ -317,8 +316,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = exp_list_match es1 sub vars es2 in match hpat.hpred with - | Sil.Hpointsto (lexp2, strexp2, te2) - -> ( + | Sil.Hpointsto (lexp2, strexp2, te2) -> ( let filter = gen_filter_pointsto lexp2 strexp2 te2 in match (Prop.prop_iter_find iter filter, hpats) with | None, _ -> @@ -327,8 +325,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = do_empty_hpats iter_cur () | Some iter_cur, _ -> execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) - | Sil.Hlseg (k2, para2, e_start2, e_end2, es_shared2) - -> ( + | Sil.Hlseg (k2, para2, e_start2, e_end2, es_shared2) -> ( let filter = gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 in let do_emp_lseg _ = let fully_instantiated_start2 = @@ -397,7 +394,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = | Some iter_cur, _ -> (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) - | Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> + | Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> ( let filter = gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 in let do_emp_dllseg _ = let fully_instantiated_iFoB2 = @@ -426,7 +423,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = match exp_match iF2' sub vars iB2 with | None -> None - | Some (sub_new, vars_leftover) -> + | Some (sub_new, vars_leftover) -> ( let para2_exist_vars, para2_inst = Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 es_shared2 in @@ -454,7 +451,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res in Some (sub_res', p_leftover) | Some _ -> - None + None ) in match (Prop.prop_iter_find iter filter, hpats) with | None, _ when not hpat.flag -> @@ -466,7 +463,7 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = | Some iter_cur, [] -> do_empty_hpats iter_cur () | Some iter_cur, _ -> - execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] + execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) and prop_match_with_impl_sub tenv p condition sub vars hpat hpats = @@ -502,7 +499,7 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 = match sigma2 with | [] -> if List.is_empty sigma1 then true else false - | hpred2 :: sigma2 -> + | hpred2 :: sigma2 -> ( let hpat2, hpats2 = let hpred2_ren, sigma2_ren = (Sil.hpred_sub (`Exp sub) hpred2, Prop.sigma_sub (`Exp sub) sigma2) @@ -520,7 +517,7 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 = | Some (_, p1') when Prop.prop_is_emp p1' -> true | _ -> - false + false ) with Invalid_argument _ -> false @@ -578,7 +575,7 @@ let sigma_remove_hpred eq sigma e = type iso_mode = Exact | LFieldForget | RFieldForget [@@deriving compare] -let equal_iso_mode = [%compare.equal : iso_mode] +let equal_iso_mode = [%compare.equal: iso_mode] let rec generate_todos_from_strexp mode todos sexp1 sexp2 = match (sexp1, sexp2) with @@ -594,7 +591,7 @@ let rec generate_todos_from_strexp mode todos sexp1 sexp2 = | Sil.Estruct _, _ -> None | Sil.Earray (len1, iel1, _), Sil.Earray (len2, iel2, _) -> - if not (Exp.equal len1 len2) || List.length iel1 <> List.length iel2 then None + if (not (Exp.equal len1 len2)) || List.length iel1 <> List.length iel2 then None else generate_todos_from_iel mode todos iel1 iel2 | Sil.Earray _, _ -> None @@ -653,7 +650,7 @@ let corres_extend_front e1 e2 corres = let corres_extensible corres e1 e2 = let predicate (e1', e2') = Exp.equal e1 e1' || Exp.equal e2 e2' in - not (List.exists ~f:predicate corres) && not (Exp.equal e1 e2) + (not (List.exists ~f:predicate corres)) && not (Exp.equal e1 e2) let corres_related corres e1 e2 = @@ -694,8 +691,7 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm assert false | Some new_corres -> generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo ) - | (e1, e2) :: todos' when corres_extensible corres e1 e2 - -> ( + | (e1, e2) :: todos' when corres_extensible corres e1 e2 -> ( let hpredo1, hpredo2, new_sigma_todo = update e1 e2 sigma_todo in match (hpredo1, hpredo2) with | None, None -> ( @@ -731,8 +727,7 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo ) | ( Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1) - , Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) - -> ( + , Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) -> ( if k1 <> k2 || not (hpara_iso tenv para1 para2) then None else try @@ -751,14 +746,13 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm in let new_todos = let shared12 = List.zip_exn shared1 shared2 in - (root1, root2) :: (next1, next2) :: shared12 @ todos' + ((root1, root2) :: (next1, next2) :: shared12) @ todos' in generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo with Invalid_argument _ -> None ) | ( Some (Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1) - , Some (Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ) - -> ( + , Some (Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ) -> ( if k1 <> k2 || not (hpara_dll_iso tenv para1 para2) then None else try @@ -777,7 +771,7 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm in let new_todos = let shared12 = List.zip_exn shared1 shared2 in - (iF1, iF2) :: (oB1, oB2) :: (oF1, oF2) :: (iB1, iB2) :: shared12 @ todos' + ((iF1, iF2) :: (oB1, oB2) :: (oF1, oF2) :: (iB1, iB2) :: shared12) @ todos' in generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo diff --git a/infer/src/biabduction/Match.mli b/infer/src/biabduction/Match.mli index 2731908ad..68a0a25c7 100644 --- a/infer/src/biabduction/Match.mli +++ b/infer/src/biabduction/Match.mli @@ -28,7 +28,12 @@ type hpred_pat = {hpred: Sil.hpred; flag: bool} type sidecondition = Prop.normal Prop.t -> Sil.exp_subst -> bool val prop_match_with_impl : - Tenv.t -> Prop.normal Prop.t -> sidecondition -> Ident.t list -> hpred_pat -> hpred_pat list + Tenv.t + -> Prop.normal Prop.t + -> sidecondition + -> Ident.t list + -> hpred_pat + -> hpred_pat list -> (Sil.exp_subst * Prop.normal Prop.t) option (** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that @@ -37,7 +42,10 @@ val prop_match_with_impl : Using the flag [field], we can control the strength of |-. *) val find_partial_iso : - Tenv.t -> (Exp.t -> Exp.t -> bool) -> (Exp.t * Exp.t) list -> (Exp.t * Exp.t) list + Tenv.t + -> (Exp.t -> Exp.t -> bool) + -> (Exp.t * Exp.t) list + -> (Exp.t * Exp.t) list -> Sil.hpred list -> ((Exp.t * Exp.t) list * Sil.hpred list * Sil.hpred list * Sil.hpred list) option (** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma. @@ -62,7 +70,12 @@ val hpara_create : passed as arguments to hpara. Both of them are returned as a result. *) val hpara_dll_create : - Tenv.t -> (Exp.t * Exp.t) list -> Sil.hpred list -> Exp.t -> Exp.t -> Exp.t + Tenv.t + -> (Exp.t * Exp.t) list + -> Sil.hpred list + -> Exp.t + -> Exp.t + -> Exp.t -> Sil.hpara_dll * Exp.t list (** [hpara_dll_create] takes a correspondence, and a sigma, a root, a blink and a flink for the first part of this correspondence. Then, diff --git a/infer/src/biabduction/Paths.ml b/infer/src/biabduction/Paths.ml index f21845870..90857336d 100644 --- a/infer/src/biabduction/Paths.ml +++ b/infer/src/biabduction/Paths.ml @@ -144,7 +144,7 @@ end = struct let start node = Pstart (node, get_dummy_stats ()) - let extend (node: Procdesc.Node.t) exn_opt session path = + let extend (node : Procdesc.Node.t) exn_opt session path = Pnode (node, exn_opt, session, path, get_dummy_stats (), None) @@ -199,58 +199,59 @@ end = struct satisfying [f] was found. Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. Since this breaks the invariant, it must be followed by reset_stats. *) - let rec compute_stats do_calls (f: Procdesc.Node.t -> bool) = + let rec compute_stats do_calls (f : Procdesc.Node.t -> bool) = let nodes_found stats = stats.max_length > 0 in function - | Pstart (node, stats) -> - if stats_is_dummy stats then ( - let found = f node in - stats.max_length <- (if found then 1 else 0) ; - stats.linear_num <- 1.0 ) - | Pnode (node, _, _, path, stats, _) -> - if stats_is_dummy stats then ( - compute_stats do_calls f path ; - let stats1 = get_stats path in - let found = - f node || nodes_found stats1 - (* the order is important as f has side-effects *) - in - stats.max_length <- (if found then 1 + stats1.max_length else 0) ; - stats.linear_num <- stats1.linear_num ) - | Pjoin (path1, path2, stats) -> - if stats_is_dummy stats then ( - compute_stats do_calls f path1 ; - compute_stats do_calls f path2 ; - let stats1, stats2 = (get_stats path1, get_stats path2) in - stats.max_length <- max stats1.max_length stats2.max_length ; - stats.linear_num <- stats1.linear_num +. stats2.linear_num ) - | Pcall (path1, _, ExecCompleted path2, stats) -> - if stats_is_dummy stats then ( - let stats2 = - match do_calls with - | true -> - compute_stats do_calls f path2 ; get_stats path2 - | false -> - {max_length= 0; linear_num= 0.0} - in - let stats1 = - let f' = - if nodes_found stats2 then fun _ -> true - (* already found in call, no need to search before the call *) - else f - in - compute_stats do_calls f' path1 ; get_stats path1 + | Pstart (node, stats) -> + if stats_is_dummy stats then ( + let found = f node in + stats.max_length <- (if found then 1 else 0) ; + stats.linear_num <- 1.0 ) + | Pnode (node, _, _, path, stats, _) -> + if stats_is_dummy stats then ( + compute_stats do_calls f path ; + let stats1 = get_stats path in + let found = + f node || nodes_found stats1 + (* the order is important as f has side-effects *) + in + stats.max_length <- (if found then 1 + stats1.max_length else 0) ; + stats.linear_num <- stats1.linear_num ) + | Pjoin (path1, path2, stats) -> + if stats_is_dummy stats then ( + compute_stats do_calls f path1 ; + compute_stats do_calls f path2 ; + let stats1, stats2 = (get_stats path1, get_stats path2) in + stats.max_length <- max stats1.max_length stats2.max_length ; + stats.linear_num <- stats1.linear_num +. stats2.linear_num ) + | Pcall (path1, _, ExecCompleted path2, stats) -> + if stats_is_dummy stats then ( + let stats2 = + match do_calls with + | true -> + compute_stats do_calls f path2 ; get_stats path2 + | false -> + {max_length= 0; linear_num= 0.0} + in + let stats1 = + let f' = + if nodes_found stats2 then fun _ -> true + (* already found in call, no need to search before the call *) + else f in - stats.max_length <- stats1.max_length + stats2.max_length ; - stats.linear_num <- stats1.linear_num ) - | Pcall (path, _, ExecSkipped _, stats) -> - if stats_is_dummy stats then ( - let stats1 = compute_stats do_calls f path ; get_stats path in - stats.max_length <- stats1.max_length ; - stats.linear_num <- stats1.linear_num ) + compute_stats do_calls f' path1 ; get_stats path1 + in + stats.max_length <- stats1.max_length + stats2.max_length ; + stats.linear_num <- stats1.linear_num ) + | Pcall (path, _, ExecSkipped _, stats) -> + if stats_is_dummy stats then ( + let stats1 = compute_stats do_calls f path ; get_stats path in + stats.max_length <- stats1.max_length ; + stats.linear_num <- stats1.linear_num ) end (* End of module Invariant *) + (** fold over each node in the path, excluding calls, once *) let fold_all_nodes_nocalls path ~init ~f = let acc = ref init in @@ -284,8 +285,8 @@ end = struct restricting to those where [filter] holds of some element. If a node is reached via an exception, pass the exception information to [f] on the previous node *) - let iter_shortest_sequence_filter (f: int -> t -> int -> Typ.Name.t option -> unit) - (filter: Procdesc.Node.t -> bool) (path: t) : unit = + let iter_shortest_sequence_filter (f : int -> t -> int -> Typ.Name.t option -> unit) + (filter : Procdesc.Node.t -> bool) (path : t) : unit = let rec doit level session path prev_exn_opt = match path with | Pstart _ -> @@ -318,8 +319,8 @@ end = struct Do not iterate past the last occurrence of the given position. [f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *) - let iter_shortest_sequence (f: int -> t -> int -> Typ.Name.t option -> unit) - (pos_opt: PredSymb.path_pos option) (path: t) : unit = + let iter_shortest_sequence (f : int -> t -> int -> Typ.Name.t option -> unit) + (pos_opt : PredSymb.path_pos option) (path : t) : unit = let filter node = match pos_opt with | None -> @@ -385,9 +386,12 @@ end = struct Invariant.compute_stats true (fun _ -> true) path ; let node, repetitions = repetitions path in let str = - "linear paths: " ^ string_of_float (Invariant.get_stats path).linear_num ^ " max length: " - ^ string_of_int (Invariant.get_stats path).max_length ^ " has repetitions: " - ^ string_of_int repetitions ^ " of node " ^ string_of_int (Procdesc.Node.get_id node :> int) + "linear paths: " + ^ string_of_float (Invariant.get_stats path).linear_num + ^ " max length: " + ^ string_of_int (Invariant.get_stats path).max_length + ^ " has repetitions: " ^ string_of_int repetitions ^ " of node " + ^ string_of_int (Procdesc.Node.get_id node :> int) in Invariant.reset_stats path ; str @@ -431,7 +435,7 @@ end = struct if n > 0 then raise Caml.Not_found ; let num = PathMap.find path !delayed in F.fprintf fmt "P%d" num - with Caml.Not_found -> + with Caml.Not_found -> ( match path with | Pstart (node, _) -> F.fprintf fmt "n%a" Procdesc.Node.pp node @@ -442,13 +446,12 @@ end = struct | Pcall (path1, _, ExecCompleted path2, _) -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 | Pcall (path, _, ExecSkipped (reason, _), _) -> - F.fprintf fmt "(%a: %s)" (doit (n - 1)) path reason + F.fprintf fmt "(%a: %s)" (doit (n - 1)) path reason ) in let print_delayed () = if not (PathMap.is_empty !delayed) then ( let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in - F.fprintf fmt "where@\n" ; - PathMap.iter f !delayed ) + F.fprintf fmt "where@\n" ; PathMap.iter f !delayed ) in add_delayed path ; doit 0 fmt path ; print_delayed () @@ -474,8 +477,7 @@ end = struct in trace := Errlog.make_trace_element (level + 1) loc definition_descr [] :: !trace ) loc_opt - | _, Some curr_node - -> ( + | _, Some curr_node -> ( let curr_loc = Procdesc.Node.get_loc curr_node in match Procdesc.Node.get_kind curr_node with | Procdesc.Node.Join_node -> @@ -535,8 +537,9 @@ end = struct in iter_shortest_sequence g pos_opt path ; let equal lt1 lt2 = - [%compare.equal : int * Location.t] - (lt1.Errlog.lt_level, lt1.Errlog.lt_loc) (lt2.Errlog.lt_level, lt2.Errlog.lt_loc) + [%compare.equal: int * Location.t] + (lt1.Errlog.lt_level, lt1.Errlog.lt_loc) + (lt2.Errlog.lt_level, lt2.Errlog.lt_loc) in let relevant lt = lt.Errlog.lt_node_tags <> [] in IList.remove_irrelevant_duplicates ~equal ~f:relevant (List.rev !trace) @@ -635,7 +638,7 @@ end = struct (** It's the caller's responsibility to ensure that [Prop.prop_rename_primed_footprint_vars] was called on the prop *) - let add_renamed_prop (p: Prop.normal Prop.t) (path: Path.t) (ps: t) : t = + let add_renamed_prop (p : Prop.normal Prop.t) (path : Path.t) (ps : t) : t = let path_new = try let path_old = PropMap.find p ps in @@ -645,7 +648,7 @@ end = struct PropMap.add p path_new ps - let union (ps1: t) (ps2: t) : t = PropMap.fold add_renamed_prop ps1 ps2 + let union (ps1 : t) (ps2 : t) : t = PropMap.fold add_renamed_prop ps1 ps2 (** check if the nodes in path p1 are a subset of those in p2 (not trace subset) *) let path_nodes_subset p1 p2 = @@ -657,7 +660,7 @@ end = struct (** difference between pathsets for the differential fixpoint *) - let diff (ps1: t) (ps2: t) : t = + let diff (ps1 : t) (ps2 : t) : t = let res = ref ps1 in let rem p path = try @@ -702,13 +705,13 @@ end = struct iter f ps - let d (ps: t) = + let d (ps : t) = let pp pe fmt ps = F.fprintf fmt "%a@\n" (pp pe) ps in L.add_print_with_pe pp ps (** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *) - let from_renamed_list (pl: ('a Prop.t * Path.t) list) : t = + let from_renamed_list (pl : ('a Prop.t * Path.t) list) : t = List.fold ~f:(fun ps (p, pa) -> add_renamed_prop p pa ps) ~init:empty pl end diff --git a/infer/src/biabduction/Paths.mli b/infer/src/biabduction/Paths.mli index 82887ba04..007dd948e 100644 --- a/infer/src/biabduction/Paths.mli +++ b/infer/src/biabduction/Paths.mli @@ -31,10 +31,10 @@ module Path : sig val curr_node : t -> Procdesc.Node.t option (** return the current node of the path *) - val d : t -> unit [@@warning "-32"] + val d : t -> unit [@@warning "-32"] (** dump a path *) - val d_stats : t -> unit [@@warning "-32"] + val d_stats : t -> unit [@@warning "-32"] (** dump statistics of the path *) val extend : Procdesc.Node.t -> Typ.Name.t option -> session -> t -> t @@ -71,7 +71,7 @@ module PathSet : sig val add_renamed_prop : Prop.normal Prop.t -> Path.t -> t -> t (** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *) - val d : t -> unit [@@warning "-32"] + val d : t -> unit [@@warning "-32"] (** dump the pathset *) val diff : t -> t -> t diff --git a/infer/src/biabduction/Prop.ml b/infer/src/biabduction/Prop.ml index a2693240b..194f1650e 100644 --- a/infer/src/biabduction/Prop.ml +++ b/infer/src/biabduction/Prop.ml @@ -33,9 +33,9 @@ type pi = Sil.atom list [@@deriving compare] type sigma = Sil.hpred list [@@deriving compare] -let equal_pi = [%compare.equal : pi] +let equal_pi = [%compare.equal: pi] -let equal_sigma = [%compare.equal : sigma] +let equal_sigma = [%compare.equal: sigma] module Core : sig (** the kind 'a should range over [normal] and [exposed] *) @@ -51,7 +51,12 @@ module Core : sig (** Proposition [true /\ emp]. *) val set : - ?sub:Sil.exp_subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sigma -> 'a t + ?sub:Sil.exp_subst + -> ?pi:pi + -> ?sigma:sigma + -> ?pi_fp:pi + -> ?sigma_fp:sigma + -> 'a t -> exposed t (** Set individual fields of the prop. *) @@ -79,25 +84,25 @@ end = struct let prop_emp : normal t = {sub= Sil.exp_sub_empty; pi= []; sigma= []; pi_fp= []; sigma_fp= []} let set ?sub ?pi ?sigma ?pi_fp ?sigma_fp p = - let set_ p ?(sub= p.sub) ?(pi= p.pi) ?(sigma= p.sigma) ?(pi_fp= p.pi_fp) - ?(sigma_fp= p.sigma_fp) () = + let set_ p ?(sub = p.sub) ?(pi = p.pi) ?(sigma = p.sigma) ?(pi_fp = p.pi_fp) + ?(sigma_fp = p.sigma_fp) () = {sub; pi; sigma; pi_fp; sigma_fp} in set_ p ?sub ?pi ?sigma ?pi_fp ?sigma_fp () - let unsafe_cast_to_normal (p: exposed t) : normal t = (p :> normal t) + let unsafe_cast_to_normal (p : exposed t) : normal t = (p :> normal t) - let unsafe_cast_to_sorted (p: exposed t) : sorted t = (p :> sorted t) + let unsafe_cast_to_sorted (p : exposed t) : sorted t = (p :> sorted t) end include Core (** {2 Basic Functions for Propositions} *) -let expose (p: _ t) : exposed t = Obj.magic p +let expose (p : _ t) : exposed t = Obj.magic p -let expose_sorted (p: sorted t) : exposed t = Obj.magic p +let expose_sorted (p : sorted t) : exposed t = Obj.magic p (** {1 Functions for Comparison} *) @@ -126,7 +131,7 @@ let pp_texp_simple pe = (** Pretty print a pointsto representing a stack variable as an equality *) -let pp_hpred_stackvar pe0 f (hpred: Sil.hpred) = +let pp_hpred_stackvar pe0 f (hpred : Sil.hpred) = let pe, changed = Sil.color_pre_wrapper pe0 f hpred in ( match hpred with | Hpointsto (Exp.Lvar pvar, se, te) -> @@ -153,7 +158,7 @@ let pp_sub pe f = function (** Dump a substitution. *) -let d_sub (sub: Sil.subst) = L.add_print_with_pe pp_sub sub +let d_sub (sub : Sil.subst) = L.add_print_with_pe pp_sub sub let pp_sub_entry pe0 f entry = let pe, changed = Sil.color_pre_wrapper pe0 f entry in @@ -175,7 +180,7 @@ let pp_pi pe = (** Dump a pi. *) -let d_pi (pi: pi) = L.add_print_with_pe pp_pi pi +let d_pi (pi : pi) = L.add_print_with_pe pp_pi pi (** Pretty print a sigma. *) let pp_sigma pe = Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred pe) @@ -185,7 +190,7 @@ let pp_sigma pe = Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred pe) let sigma_get_stack_nonstack only_local_vars sigma = let hpred_is_stack_var = function | Sil.Hpointsto (Lvar pvar, _, _) -> - not only_local_vars || Pvar.is_local pvar + (not only_local_vars) || Pvar.is_local pvar | _ -> false in @@ -208,7 +213,7 @@ let pp_sigma_simple pe env fmt sigma = (** Dump a sigma. *) -let d_sigma (sigma: sigma) = L.add_print_with_pe pp_sigma sigma +let d_sigma (sigma : sigma) = L.add_print_with_pe pp_sigma sigma (** Dump a pi and a sigma *) let d_pi_sigma pi sigma = @@ -219,7 +224,7 @@ let d_pi_sigma pi sigma = let pi_of_subst sub = List.map ~f:(fun (id1, e2) -> Sil.Aeq (Var id1, e2)) (Sil.sub_to_list sub) (** Return the pure part of [prop]. *) -let get_pure (p: 'a t) : pi = pi_of_subst p.sub @ p.pi +let get_pure (p : 'a t) : pi = pi_of_subst p.sub @ p.pi (* Same with get_pure, except that when we have both "x = t" and "y = t" where t is a primed ident, * we add "x = y" to the result. This is crucial for the normalizer, as it tend to drop "x = t" before @@ -236,9 +241,11 @@ let get_pure_extended p = with Caml.Not_found -> (atoms, Ident.Map.add pid id primed_map) in match base_atom with - | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id0 && not (Ident.is_primed id1) -> + | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id0 && not (Ident.is_primed id1) + -> extend_atoms id1 id0 - | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id1 && not (Ident.is_primed id0) -> + | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id1 && not (Ident.is_primed id0) + -> extend_atoms id0 id1 | _ -> acc ) @@ -270,7 +277,7 @@ let pp_hpara_dll_simple pe_ env n f pred = (** Create an environment mapping (ident) expressions to the program variables containing them *) -let create_pvar_env (sigma: sigma) : Exp.t -> Exp.t = +let create_pvar_env (sigma : sigma) : Exp.t -> Exp.t = let env = ref [] in let filter = function | Sil.Hpointsto (Lvar pvar, Eexp (Var v, _), _) -> @@ -280,8 +287,8 @@ let create_pvar_env (sigma: sigma) : Exp.t -> Exp.t = in List.iter ~f:filter sigma ; let find e = - List.find ~f:(fun (e1, _) -> Exp.equal e1 e) !env |> Option.map ~f:snd - |> Option.value ~default:e + List.find ~f:(fun (e1, _) -> Exp.equal e1 e) !env + |> Option.map ~f:snd |> Option.value ~default:e in find @@ -345,7 +352,7 @@ let pp_prop pe0 f prop = let pp_prop_with_typ pe f p = pp_prop {pe with opt= SIM_WITH_TYP} f p (** Dump a proposition. *) -let d_prop (prop: 'a t) = L.add_print_with_pe pp_prop prop +let d_prop (prop : 'a t) = L.add_print_with_pe pp_prop prop (** Print a list of propositions, prepending each one with the given string *) let pp_proplist_with_typ pe f plist = @@ -361,7 +368,7 @@ let pp_proplist_with_typ pe f plist = (** dump a proplist *) -let d_proplist_with_typ (pl: 'a t list) = L.add_print_with_pe pp_proplist_with_typ pl +let d_proplist_with_typ (pl : 'a t list) = L.add_print_with_pe pp_proplist_with_typ pl (** {1 Functions for computing free non-program variables} *) @@ -407,7 +414,7 @@ let non_pure_free_vars prop = Sequence.Generator.run (non_pure_gen_free_vars pro (** {2 Functions for Subsitition} *) -let pi_sub (subst: Sil.subst) pi = +let pi_sub (subst : Sil.subst) pi = let f = Sil.atom_sub subst in List.map ~f pi @@ -418,7 +425,7 @@ let sigma_sub subst sigma = (** Return [true] if the atom is an inequality *) -let atom_is_inequality (atom: Sil.atom) = +let atom_is_inequality (atom : Sil.atom) = match atom with | Aeq (BinOp ((Le | Lt), _, _), Const (Cint i)) when IntLit.isone i -> true @@ -427,7 +434,7 @@ let atom_is_inequality (atom: Sil.atom) = (** If the atom is [e<=n] return [e,n] *) -let atom_exp_le_const (atom: Sil.atom) = +let atom_exp_le_const (atom : Sil.atom) = match atom with | Aeq (BinOp (Le, e1, Const (Cint n)), Const (Cint i)) when IntLit.isone i -> Some (e1, n) @@ -436,7 +443,7 @@ let atom_exp_le_const (atom: Sil.atom) = (** If the atom is [n Some (n, e1) @@ -455,7 +462,7 @@ let rec pp_path f = function (** create a strexp of the given type, populating the structures if [struct_init_mode] is [Fld_init] *) -let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst : Sil.strexp = +let rec create_strexp_of_type ~path tenv struct_init_mode (typ : Typ.t) len inst : Sil.strexp = let init_value () = let create_fresh_var () = let fresh_id = @@ -470,8 +477,7 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst match (typ.desc, len) with | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), None -> Eexp (init_value (), inst) - | Tstruct name, _ - -> ( + | Tstruct name, _ -> ( if List.exists ~f:(fun (n, _) -> Typ.Name.equal n name) path then L.die InternalError "Ill-founded recursion in [create_strexp_of_type]: a sub-element of struct %a is also \ @@ -503,11 +509,11 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst assert false -let create_strexp_of_type tenv struct_init_mode (typ: Typ.t) len inst : Sil.strexp = +let create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Sil.strexp = create_strexp_of_type ~path:[] tenv struct_init_mode (typ : Typ.t) len inst -let replace_array_contents (hpred: Sil.hpred) esel : Sil.hpred = +let replace_array_contents (hpred : Sil.hpred) esel : Sil.hpred = match hpred with | Hpointsto (root, Sil.Earray (len, [], inst), te) -> Hpointsto (root, Earray (len, esel, inst), te) @@ -516,7 +522,7 @@ let replace_array_contents (hpred: Sil.hpred) esel : Sil.hpred = (** remove duplicate atoms and redundant inequalities from a sorted pi *) -let rec pi_sorted_remove_redundant (pi: pi) = +let rec pi_sorted_remove_redundant (pi : pi) = match pi with | (Aeq (BinOp (Le, e1, Const (Cint n1)), Const (Cint i1)) as a1) :: Aeq (BinOp (Le, e2, Const (Cint n2)), Const (Cint i2)) :: rest @@ -540,7 +546,7 @@ let rec pi_sorted_remove_redundant (pi: pi) = (** find the unsigned expressions in sigma (immediately inside a pointsto, for now) *) let sigma_get_unsigned_exps sigma = let uexps = ref [] in - let do_hpred (hpred: Sil.hpred) = + let do_hpred (hpred : Sil.hpred) = match hpred with | Hpointsto (_, Eexp (e, _), Sizeof {typ= {desc= Tint ik}}) when Typ.ikind_is_unsigned ik -> uexps := e :: !uexps @@ -553,14 +559,14 @@ let sigma_get_unsigned_exps sigma = (** Collapse consecutive indices that should be added. For instance, this function reduces x[1][1] to x[2]. The [typ] argument is used to ensure the soundness of this collapsing. *) -let exp_collapse_consecutive_indices_prop (typ: Typ.t) exp = - let typ_is_base (typ1: Typ.t) = +let exp_collapse_consecutive_indices_prop (typ : Typ.t) exp = + let typ_is_base (typ1 : Typ.t) = match typ1.desc with Tint _ | Tfloat _ | Tstruct _ | Tvoid | Tfun _ -> true | _ -> false in let typ_is_one_step_from_base = match typ.desc with Tptr (t, _) | Tarray {elt= t} -> typ_is_base t | _ -> false in - let rec exp_remove (e0: Exp.t) = + let rec exp_remove (e0 : Exp.t) = match e0 with | Lindex (Lindex (base, e1), e2) -> let e0' : Exp.t = Lindex (base, BinOp (PlusA, e1, e2)) in @@ -574,7 +580,7 @@ let exp_collapse_consecutive_indices_prop (typ: Typ.t) exp = (** {2 Compaction} *) (** Return a compact representation of the prop *) -let prop_compact sh (prop: normal t) : normal t = +let prop_compact sh (prop : normal t) : normal t = let sigma' = List.map ~f:(Sil.hpred_compact sh) prop.sigma in unsafe_cast_to_normal (set prop ~sigma:sigma') @@ -587,12 +593,12 @@ let prop_is_emp p = match p.sigma with [] -> true | _ -> false (** {2 Functions for changing and generating propositions} *) (** Conjoin a heap predicate by separating conjunction. *) -let prop_hpred_star (p: 'a t) (h: Sil.hpred) : exposed t = +let prop_hpred_star (p : 'a t) (h : Sil.hpred) : exposed t = let sigma' = h :: p.sigma in set p ~sigma:sigma' -let prop_sigma_star (p: 'a t) (sigma: sigma) : exposed t = +let prop_sigma_star (p : 'a t) (sigma : sigma) : exposed t = let sigma' = sigma @ p.sigma in set p ~sigma:sigma' @@ -608,7 +614,7 @@ module Normalize = struct cell iF or iB. *) let sigma_remove_emptylseg sigma = let alloc_set = - let rec f_alloc set (sigma1: sigma) = + let rec f_alloc set (sigma1 : sigma) = match sigma1 with | [] -> set @@ -621,7 +627,7 @@ module Normalize = struct in f_alloc Exp.Set.empty sigma in - let rec f eqs_zero sigma_passed (sigma1: sigma) = + let rec f eqs_zero sigma_passed (sigma1 : sigma) = match sigma1 with | [] -> (List.rev eqs_zero, List.rev sigma_passed) @@ -643,7 +649,7 @@ module Normalize = struct let sigma_intro_nonemptylseg e1 e2 sigma = - let rec f sigma_passed (sigma1: sigma) = + let rec f sigma_passed (sigma1 : sigma) = match sigma1 with | [] -> List.rev sigma_passed @@ -655,8 +661,10 @@ module Normalize = struct | (Hlseg _ as hpred) :: sigma' -> f (hpred :: sigma_passed) sigma' | Hdllseg (Lseg_PE, para, iF, oB, oF, iB, shared) :: sigma' - when (Exp.equal e1 iF && Exp.equal e2 oF) || (Exp.equal e2 iF && Exp.equal e1 oF) - || (Exp.equal e1 iB && Exp.equal e2 oB) || (Exp.equal e2 iB && Exp.equal e1 oB) -> + when (Exp.equal e1 iF && Exp.equal e2 oF) + || (Exp.equal e2 iF && Exp.equal e1 oF) + || (Exp.equal e1 iB && Exp.equal e2 oB) + || (Exp.equal e2 iB && Exp.equal e1 oB) -> f (Sil.Hdllseg (Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' | (Hdllseg _ as hpred) :: sigma' -> f (hpred :: sigma_passed) sigma' @@ -668,9 +676,9 @@ module Normalize = struct let ( ++ ) = IntLit.add - let sym_eval ?(destructive= false) tenv abs e = + let sym_eval ?(destructive = false) tenv abs e = let lookup = Tenv.lookup tenv in - let rec eval (e: Exp.t) : Exp.t = + let rec eval (e : Exp.t) : Exp.t = (* L.d_str " ["; Sil.d_exp e; L.d_str"] "; *) match e with | Var _ -> @@ -776,8 +784,7 @@ module Normalize = struct Exp.one | e1', e2' -> Exp.ne e1' e2' ) - | BinOp (LAnd, e1, e2) - -> ( + | BinOp (LAnd, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -791,8 +798,7 @@ module Normalize = struct e1' | _ -> BinOp (LAnd, e1', e2') ) - | BinOp (LOr, e1, e2) - -> ( + | BinOp (LOr, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -815,13 +821,12 @@ module Normalize = struct (* progress: convert inner +I to +A *) let e2' : Exp.t = BinOp (PlusA, e12, e2) in eval (Exp.BinOp (PlusPI, e11, e2')) - | BinOp ((PlusA as oplus), e1, e2) | BinOp ((PlusPI as oplus), e1, e2) - -> ( + | BinOp ((PlusA as oplus), e1, e2) | BinOp ((PlusPI as oplus), e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in let isPlusA = Binop.equal oplus Binop.PlusA in let ominus = if isPlusA then Binop.MinusA else Binop.MinusPI in - let ( +++ ) (x: Exp.t) (y: Exp.t) : Exp.t = + let ( +++ ) (x : Exp.t) (y : Exp.t) : Exp.t = match (x, y) with | _, Const (Cint i) when IntLit.iszero i -> x @@ -830,7 +835,7 @@ module Normalize = struct | _ -> BinOp (oplus, x, y) in - let ( --- ) (x: Exp.t) (y: Exp.t) : Exp.t = + let ( --- ) (x : Exp.t) (y : Exp.t) : Exp.t = match (x, y) with | _, Const (Cint i) when IntLit.iszero i -> x @@ -884,8 +889,7 @@ module Normalize = struct if abs && isPlusA then Exp.get_undefined false else if abs && not isPlusA then e1' +++ Exp.get_undefined false else e1' +++ e2' ) - | BinOp ((MinusA as ominus), e1, e2) | BinOp ((MinusPI as ominus), e1, e2) - -> ( + | BinOp ((MinusA as ominus), e1, e2) | BinOp ((MinusPI as ominus), e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in let isMinusA = Binop.equal ominus Binop.MinusA in @@ -915,8 +919,7 @@ module Normalize = struct if abs then Exp.get_undefined false else e1' --- e2' ) | BinOp (MinusPP, e1, e2) -> if abs then Exp.get_undefined false else BinOp (MinusPP, eval e1, eval e2) - | BinOp (Mult, e1, e2) - -> ( + | BinOp (Mult, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -942,8 +945,7 @@ module Normalize = struct BinOp (Mult, e1', e2') | _, _ -> if abs then Exp.get_undefined false else BinOp (Mult, e1', e2') ) - | BinOp (Div, e1, e2) - -> ( + | BinOp (Div, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -969,8 +971,7 @@ module Normalize = struct Const (Cint len) | _ -> if abs then Exp.get_undefined false else BinOp (Div, e1', e2') ) - | BinOp (Mod, e1, e2) - -> ( + | BinOp (Mod, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -984,8 +985,7 @@ module Normalize = struct Exp.int (IntLit.rem n m) | _ -> if abs then Exp.get_undefined false else BinOp (Mod, e1', e2') ) - | BinOp (Shiftlt, e1, e2) - -> ( + | BinOp (Shiftlt, e1, e2) -> ( if abs then Exp.get_undefined false else match (e1, e2) with @@ -1000,8 +1000,7 @@ module Normalize = struct e1 | _ -> BinOp (Shiftlt, eval e1, eval e2) ) - | BinOp (Shiftrt, e1, e2) - -> ( + | BinOp (Shiftrt, e1, e2) -> ( if abs then Exp.get_undefined false else match (e1, e2) with @@ -1014,8 +1013,7 @@ module Normalize = struct e1 | _ -> BinOp (Shiftrt, eval e1, eval e2) ) - | BinOp (BAnd, e1, e2) - -> ( + | BinOp (BAnd, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -1027,8 +1025,7 @@ module Normalize = struct Exp.int (IntLit.logand i1 i2) | _ -> if abs then Exp.get_undefined false else BinOp (BAnd, e1', e2') ) - | BinOp (BOr, e1, e2) - -> ( + | BinOp (BOr, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -1040,8 +1037,7 @@ module Normalize = struct Exp.int (IntLit.logor i1 i2) | _ -> if abs then Exp.get_undefined false else BinOp (BOr, e1', e2') ) - | BinOp (BXor, e1, e2) - -> ( + | BinOp (BXor, e1, e2) -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with @@ -1084,7 +1080,7 @@ module Normalize = struct sym_eval ?destructive tenv abstract_expressions exp' - let texp_normalize tenv sub (exp: Exp.t) : Exp.t = + let texp_normalize tenv sub (exp : Exp.t) : Exp.t = match exp with | Sizeof {dynamic_length= None} -> exp @@ -1101,10 +1097,9 @@ module Normalize = struct (** Turn an inequality expression into an atom *) - let mk_inequality tenv (e: Exp.t) : Sil.atom = + let mk_inequality tenv (e : Exp.t) : Sil.atom = match e with - | BinOp (Le, base, Const (Cint n)) - -> ( + | BinOp (Le, base, Const (Cint n)) -> ( (* base <= n case *) let nbase = exp_normalize_noabs tenv Sil.sub_empty base in match nbase with @@ -1131,8 +1126,7 @@ module Normalize = struct Aeq (new_e, Exp.one) | _ -> Aeq (e, Exp.one) ) - | BinOp (Lt, Const (Cint n), base) - -> ( + | BinOp (Lt, Const (Cint n), base) -> ( (* n < base case *) let nbase = exp_normalize_noabs tenv Sil.sub_empty base in match nbase with @@ -1164,10 +1158,10 @@ module Normalize = struct (** Normalize an inequality *) - let inequality_normalize tenv (a: Sil.atom) = + let inequality_normalize tenv (a : Sil.atom) = (* turn an expression into a triple (pos,neg,off) of positive and negative occurrences, and integer offset representing inequality [sum(pos) - sum(neg) + off <= 0] *) - let rec exp_to_posnegoff (e: Exp.t) = + let rec exp_to_posnegoff (e : Exp.t) = match e with | Const (Cint n) -> ([], [], n) @@ -1244,7 +1238,7 @@ module Normalize = struct are only of the form [e <= n] and [n < e]. *) let atom_normalize tenv sub a0 = let a = Sil.atom_sub sub a0 in - let rec normalize_eq (eq: Exp.t * Exp.t) = + let rec normalize_eq (eq : Exp.t * Exp.t) = match eq with | BinOp (PlusA, e1, Const (Cint n1)), Const (Cint n2) (* e1+n1==n2 ---> e1==n2-n1 *) @@ -1274,7 +1268,7 @@ module Normalize = struct | _ -> eq in - let handle_unary_negation (e1: Exp.t) (e2: Exp.t) = + let handle_unary_negation (e1 : Exp.t) (e2 : Exp.t) = match (e1, e2) with | (UnOp (LNot, e1', _), Const (Cint i) | Const (Cint i), UnOp (LNot, e1', _)) when IntLit.iszero i -> @@ -1310,7 +1304,7 @@ module Normalize = struct if atom_is_inequality a' then inequality_normalize tenv a' else a' - let normalize_and_strengthen_atom tenv (p: normal t) (a: Sil.atom) : Sil.atom = + let normalize_and_strengthen_atom tenv (p : normal t) (a : Sil.atom) : Sil.atom = let a' = atom_normalize tenv (`Exp p.sub) a in match a' with | Aeq (BinOp (Le, Var id, Const (Cint n)), Const (Cint i)) when IntLit.isone i -> @@ -1327,7 +1321,7 @@ module Normalize = struct a' - let rec strexp_normalize tenv sub (se: Sil.strexp) : Sil.strexp = + let rec strexp_normalize tenv sub (se : Sil.strexp) : Sil.strexp = match se with | Eexp (e, inst) -> let e' = exp_normalize tenv sub e in @@ -1338,30 +1332,28 @@ module Normalize = struct se | _ :: _ -> let fld_cnts' = - IList.map_changed fld_cnts - ~equal:[%compare.equal : Typ.Fieldname.t * Sil.strexp] + IList.map_changed fld_cnts ~equal:[%compare.equal: Typ.Fieldname.t * Sil.strexp] ~f:(fun ((fld, cnt) as x) -> let cnt' = strexp_normalize tenv sub cnt in if phys_equal cnt cnt' then x else (fld, cnt') ) in if phys_equal fld_cnts fld_cnts' - && List.is_sorted ~compare:[%compare : Typ.Fieldname.t * Sil.strexp] fld_cnts + && List.is_sorted ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] fld_cnts then se else let fld_cnts'' = - List.sort ~compare:[%compare : Typ.Fieldname.t * Sil.strexp] fld_cnts' + List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] fld_cnts' in Estruct (fld_cnts'', inst) ) - | Earray (len, idx_cnts, inst) -> + | Earray (len, idx_cnts, inst) -> ( let len' = exp_normalize_noabs tenv sub len in match idx_cnts with | [] -> if Exp.equal len len' then se else Earray (len', idx_cnts, inst) | _ :: _ -> let idx_cnts' = - IList.map_changed idx_cnts - ~equal:[%compare.equal : Exp.t * Sil.strexp] + IList.map_changed idx_cnts ~equal:[%compare.equal: Exp.t * Sil.strexp] ~f:(fun ((idx, cnt) as x) -> let idx' = exp_normalize tenv sub idx in let cnt' = strexp_normalize tenv sub cnt in @@ -1369,11 +1361,11 @@ module Normalize = struct in if phys_equal idx_cnts idx_cnts' - && List.is_sorted ~compare:[%compare : Exp.t * Sil.strexp] idx_cnts + && List.is_sorted ~compare:[%compare: Exp.t * Sil.strexp] idx_cnts then se else - let idx_cnts'' = List.sort ~compare:[%compare : Exp.t * Sil.strexp] idx_cnts' in - Earray (len', idx_cnts'', inst) + let idx_cnts'' = List.sort ~compare:[%compare: Exp.t * Sil.strexp] idx_cnts' in + Earray (len', idx_cnts'', inst) ) (** Exp.Construct a pointsto. *) @@ -1385,7 +1377,7 @@ module Normalize = struct (** Construct a points-to predicate for an expression using either the provided expression [name] as base for fresh identifiers. If [struct_init_mode] is [Fld_init], initialize the fields of structs with fresh variables. *) - let mk_ptsto_exp tenv struct_init_mode (exp, (te: Exp.t), expo) inst : Sil.hpred = + let mk_ptsto_exp tenv struct_init_mode (exp, (te : Exp.t), expo) inst : Sil.hpred = let default_strexp () : Sil.strexp = match te with | Sizeof {typ; dynamic_length} -> @@ -1465,7 +1457,7 @@ module Normalize = struct List.map ~f:process_closures_in_the_heap sigma - let rec hpred_normalize tenv sub (hpred: Sil.hpred) : Sil.hpred = + let rec hpred_normalize tenv sub (hpred : Sil.hpred) : Sil.hpred = let replace_hpred hpred' = L.d_strln "found array with sizeof(..) size" ; L.d_str "converting original hpred: " ; @@ -1477,8 +1469,7 @@ module Normalize = struct hpred' in match hpred with - | Hpointsto (root, cnt, te) - -> ( + | Hpointsto (root, cnt, te) -> ( let normalized_root = exp_normalize tenv sub root in let normalized_cnt = strexp_normalize tenv sub cnt in let normalized_te = texp_normalize tenv sub te in @@ -1536,13 +1527,13 @@ module Normalize = struct Hdllseg (k, norm_para, norm_e1, norm_e2, norm_e3, norm_e4, norm_elist) - and hpara_normalize tenv (para: Sil.hpara) = + and hpara_normalize tenv (para : Sil.hpara) = let normalized_body = List.map ~f:(hpred_normalize tenv Sil.sub_empty) para.body in let sorted_body = List.sort ~compare:Sil.compare_hpred normalized_body in {para with body= sorted_body} - and hpara_dll_normalize tenv (para: Sil.hpara_dll) = + and hpara_dll_normalize tenv (para : Sil.hpara_dll) = let normalized_body = List.map ~f:(hpred_normalize tenv Sil.sub_empty) para.body_dll in let sorted_body = List.sort ~compare:Sil.compare_hpred normalized_body in {para with body_dll= sorted_body} @@ -1550,7 +1541,8 @@ module Normalize = struct let sigma_normalize tenv sub sigma = let sigma' = - List.map ~f:(hpred_normalize tenv sub) sigma |> make_captured_in_closures_consistent + List.map ~f:(hpred_normalize tenv sub) sigma + |> make_captured_in_closures_consistent |> List.stable_sort ~compare:Sil.compare_hpred in if equal_sigma sigma sigma' then sigma else sigma' @@ -1559,7 +1551,7 @@ module Normalize = struct let pi_tighten_ineq tenv pi = let ineq_list, nonineq_list = List.partition_tf ~f:atom_is_inequality pi in let diseq_list = - let get_disequality_info acc (a: Sil.atom) = + let get_disequality_info acc (a : Sil.atom) = match a with | Aneq (Const (Cint n), e) | Aneq (e, Const (Cint n)) -> (e, n) :: acc @@ -1614,13 +1606,13 @@ module Normalize = struct in let nonineq_list' = List.filter - ~f:(fun (a: Sil.atom) -> + ~f:(fun (a : Sil.atom) -> match a with | Aneq (Const (Cint n), e) | Aneq (e, Const (Cint n)) -> - not - (List.exists - ~f:(fun (e', n') -> Exp.equal e e' && IntLit.lt n' n) - le_list_tightened) + (not + (List.exists + ~f:(fun (e', n') -> Exp.equal e e' && IntLit.lt n' n) + le_list_tightened)) && not (List.exists ~f:(fun (n', e') -> Exp.equal e e' && IntLit.leq n n') @@ -1650,14 +1642,14 @@ module Normalize = struct let filter_useful_atom : Sil.atom -> bool = let unsigned_exps = lazy (sigma_get_unsigned_exps sigma) in function - | Aneq ((Var _ as e), Const (Cint n)) when IntLit.isnegative n -> - not (List.exists ~f:(Exp.equal e) (Lazy.force unsigned_exps)) - | Aneq (e1, e2) -> - not (syntactically_different (e1, e2)) - | Aeq (Const c1, Const c2) -> - not (Const.equal c1 c2) - | _ -> - true + | Aneq ((Var _ as e), Const (Cint n)) when IntLit.isnegative n -> + not (List.exists ~f:(Exp.equal e) (Lazy.force unsigned_exps)) + | Aneq (e1, e2) -> + not (syntactically_different (e1, e2)) + | Aeq (Const c1, Const c2) -> + not (Const.equal c1 c2) + | _ -> + true in let pi' = List.stable_sort ~compare:Sil.compare_atom @@ -1676,8 +1668,10 @@ module Normalize = struct let fav = pi_free_vars npi |> Sequence.filter ~f:Ident.is_primed |> Ident.hashqueue_of_sequence in - sigma_free_vars nsigma |> Sequence.filter ~f:Ident.is_primed - |> Ident.hashqueue_of_sequence ~init:fav |> Ident.HashQueue.keys + sigma_free_vars nsigma + |> Sequence.filter ~f:Ident.is_primed + |> Ident.hashqueue_of_sequence ~init:fav + |> Ident.HashQueue.keys in (* only keep primed vars *) let npi', nsigma' = @@ -1699,13 +1693,13 @@ module Normalize = struct (** This function assumes that if (x,Exp.Var(y)) in sub, then compare x y = 1 *) let sub_normalize sub = - let f (id, e) = not (Ident.is_primed id) && not (Exp.ident_mem e id) in + let f (id, e) = (not (Ident.is_primed id)) && not (Exp.ident_mem e id) in let sub' = Sil.sub_filter_pair ~f sub in if Sil.equal_exp_subst sub sub' then sub else sub' (** Conjoin a pure atomic predicate by normal conjunction. *) - let rec prop_atom_and tenv ?(footprint= false) (p: normal t) a : normal t = + let rec prop_atom_and tenv ?(footprint = false) (p : normal t) a : normal t = let a' = normalize_and_strengthen_atom tenv p a in if List.mem ~equal:Sil.equal_atom p.pi a' then p else @@ -1754,7 +1748,7 @@ module Normalize = struct (** normalize a prop *) - let normalize tenv (eprop: 'a t) : normal t = + let normalize tenv (eprop : 'a t) : normal t = let p0 = unsafe_cast_to_normal (set prop_emp ~sigma:(sigma_normalize tenv Sil.sub_empty eprop.sigma)) in @@ -1777,7 +1771,7 @@ let lexp_normalize_prop tenv p lexp = let nroot = exp_normalize_prop tenv p root in let noffsets = List.map - ~f:(fun (n: Sil.offset) -> + ~f:(fun (n : Sil.offset) -> match n with Off_fld _ -> n | Off_index e -> Sil.Off_index (exp_normalize_prop tenv p e) ) offsets in @@ -1830,17 +1824,17 @@ let mk_dllseg tenv k para exp_iF exp_oB exp_oF exp_iB exps_shared : Sil.hpred = (** Construct a points-to predicate for a single program variable. If [expand_structs] is [Fld_init], initialize the fields of structs with fresh variables. *) -let mk_ptsto_lvar tenv expand_structs inst ((pvar: Pvar.t), texp, expo) : Sil.hpred = +let mk_ptsto_lvar tenv expand_structs inst ((pvar : Pvar.t), texp, expo) : Sil.hpred = Normalize.mk_ptsto_exp tenv expand_structs (Lvar pvar, texp, expo) inst (** Conjoin [exp1]=[exp2] with a symbolic heap [prop]. *) -let conjoin_eq tenv ?(footprint= false) exp1 exp2 prop = +let conjoin_eq tenv ?(footprint = false) exp1 exp2 prop = Normalize.prop_atom_and tenv ~footprint prop (Aeq (exp1, exp2)) (** Conjoin [exp1!=exp2] with a symbolic heap [prop]. *) -let conjoin_neq tenv ?(footprint= false) exp1 exp2 prop = +let conjoin_neq tenv ?(footprint = false) exp1 exp2 prop = Normalize.prop_atom_and tenv ~footprint prop (Aneq (exp1, exp2)) @@ -1861,7 +1855,7 @@ let prop_reset_inst inst_map prop = let extract_footprint p = set prop_emp ~pi:p.pi_fp ~sigma:p.sigma_fp (** Extract the (footprint,current) pair *) -let extract_spec (p: normal t) : normal t * normal t = +let extract_spec (p : normal t) : normal t * normal t = let pre = extract_footprint p in let post = set p ~pi_fp:[] ~sigma_fp:[] in (unsafe_cast_to_normal pre, unsafe_cast_to_normal post) @@ -1909,7 +1903,7 @@ let sigma_dfs_sort tenv sigma = ExpStack.init start_lexps in let final () = ExpStack.final () in - let rec handle_strexp (se: Sil.strexp) = + let rec handle_strexp (se : Sil.strexp) = match se with | Eexp (e, _) -> ExpStack.push e @@ -1918,14 +1912,15 @@ let sigma_dfs_sort tenv sigma = | Earray (_, idx_se_list, _) -> List.iter ~f:(fun (_, se) -> handle_strexp se) idx_se_list in - let rec handle_e visited seen e (sigma: sigma) = + let rec handle_e visited seen e (sigma : sigma) = match sigma with | [] -> (visited, List.rev seen) - | hpred :: cur -> + | hpred :: cur -> ( match hpred with | Hpointsto (e', se, _) when Exp.equal e e' -> - handle_strexp se ; (hpred :: visited, List.rev_append cur seen) + handle_strexp se ; + (hpred :: visited, List.rev_append cur seen) | Hlseg (_, _, root, next, shared) when Exp.equal e root -> List.iter ~f:ExpStack.push (next :: shared) ; (hpred :: visited, List.rev_append cur seen) @@ -1933,7 +1928,7 @@ let sigma_dfs_sort tenv sigma = List.iter ~f:ExpStack.push (oB :: oF :: shared) ; (hpred :: visited, List.rev_append cur seen) | _ -> - handle_e visited (hpred :: seen) e cur + handle_e visited (hpred :: seen) e cur ) in let rec handle_sigma visited = function | [] -> @@ -1962,7 +1957,7 @@ let dfs_sort tenv p : sorted t = unsafe_cast_to_sorted p' -let rec strexp_get_array_indices acc (se: Sil.strexp) = +let rec strexp_get_array_indices acc (se : Sil.strexp) = match se with | Eexp _ -> acc @@ -1975,7 +1970,7 @@ let rec strexp_get_array_indices acc (se: Sil.strexp) = List.fold ~f:strexp_get_array_indices ~init:acc_new se_list -let hpred_get_array_indices acc (hpred: Sil.hpred) = +let hpred_get_array_indices acc (hpred : Sil.hpred) = match hpred with | Hpointsto (_, se, _) -> strexp_get_array_indices acc se @@ -1989,7 +1984,7 @@ let sigma_get_array_indices sigma = let compute_reindexing_from_indices list = - let get_id_offset (e: Exp.t) = + let get_id_offset (e : Exp.t) = match e with | BinOp (PlusA, Var id, Const (Cint offset)) -> if Ident.is_primed id then Some (id, offset) else None @@ -2025,7 +2020,7 @@ let compute_reindexing_from_indices list = Sil.exp_subst_of_list reindexing -let apply_reindexing tenv (exp_subst: Sil.exp_subst) prop = +let apply_reindexing tenv (exp_subst : Sil.exp_subst) prop = let subst = `Exp exp_subst in let nsigma = Normalize.sigma_normalize tenv subst prop.sigma in let npi = Normalize.pi_normalize tenv subst nsigma prop.pi in @@ -2049,7 +2044,7 @@ let prop_rename_array_indices tenv prop = if !Config.footprint then prop else let indices = sigma_get_array_indices prop.sigma in - let not_same_base_lt_offsets (e1: Exp.t) (e2: Exp.t) = + let not_same_base_lt_offsets (e1 : Exp.t) (e2 : Exp.t) = match (e1, e2) with | BinOp (PlusA, e1', Const (Cint n1')), BinOp (PlusA, e2', Const (Cint n2')) -> not (Exp.equal e1' e2' && IntLit.lt n1' n2') @@ -2099,7 +2094,7 @@ let ident_captured_ren ren id = try idlist_assoc id ren with Caml.Not_found -> i (* If not defined in ren, id should be mapped to itself *) -let rec exp_captured_ren ren (e: Exp.t) : Exp.t = +let rec exp_captured_ren ren (e : Exp.t) : Exp.t = match e with | Var id -> Var (ident_captured_ren ren id) @@ -2132,7 +2127,7 @@ let rec exp_captured_ren ren (e: Exp.t) : Exp.t = Lindex (e1', e2') -let atom_captured_ren ren (a: Sil.atom) : Sil.atom = +let atom_captured_ren ren (a : Sil.atom) : Sil.atom = match a with | Aeq (e1, e2) -> Aeq (exp_captured_ren ren e1, exp_captured_ren ren e2) @@ -2144,7 +2139,7 @@ let atom_captured_ren ren (a: Sil.atom) : Sil.atom = Anpred (a, List.map ~f:(fun e -> exp_captured_ren ren e) es) -let rec strexp_captured_ren ren (se: Sil.strexp) : Sil.strexp = +let rec strexp_captured_ren ren (se : Sil.strexp) : Sil.strexp = match se with | Eexp (e, inst) -> Eexp (exp_captured_ren ren e, inst) @@ -2160,7 +2155,7 @@ let rec strexp_captured_ren ren (se: Sil.strexp) : Sil.strexp = Earray (len', List.map ~f idx_se_list, inst) -and hpred_captured_ren ren (hpred: Sil.hpred) : Sil.hpred = +and hpred_captured_ren ren (hpred : Sil.hpred) : Sil.hpred = match hpred with | Hpointsto (base, se, te) -> let base' = exp_captured_ren ren base in @@ -2183,7 +2178,7 @@ and hpred_captured_ren ren (hpred: Sil.hpred) : Sil.hpred = Hdllseg (k, para', e1', e2', e3', e4', elist') -and hpara_ren (para: Sil.hpara) : Sil.hpara = +and hpara_ren (para : Sil.hpara) : Sil.hpara = let av = Sil.hpara_shallow_free_vars para |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in @@ -2196,7 +2191,7 @@ and hpara_ren (para: Sil.hpara) : Sil.hpara = {root; next; svars; evars; body} -and hpara_dll_ren (para: Sil.hpara_dll) : Sil.hpara_dll = +and hpara_dll_ren (para : Sil.hpara_dll) : Sil.hpara_dll = let av = Sil.hpara_dll_shallow_free_vars para |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in @@ -2217,7 +2212,7 @@ let sigma_captured_ren ren sigma = List.map ~f:(hpred_captured_ren ren) sigma let sub_captured_ren ren sub = Sil.sub_map (ident_captured_ren ren) (exp_captured_ren ren) sub (** Canonicalize the names of primed variables and footprint vars. *) -let prop_rename_primed_footprint_vars tenv (p: normal t) : normal t = +let prop_rename_primed_footprint_vars tenv (p : normal t) : normal t = let p = prop_rename_array_indices tenv p in let bound_vars = let filter id = Ident.is_footprint id || Ident.is_primed id in @@ -2244,7 +2239,7 @@ let prop_rename_primed_footprint_vars tenv (p: normal t) : normal t = (** Apply subsitution to prop. *) -let prop_sub subst (prop: 'a t) : exposed t = +let prop_sub subst (prop : 'a t) : exposed t = let pi = pi_sub subst (prop.pi @ pi_of_subst prop.sub) in let sigma = sigma_sub subst prop.sigma in let pi_fp = pi_sub subst prop.pi_fp in @@ -2253,13 +2248,13 @@ let prop_sub subst (prop: 'a t) : exposed t = (** Apply renaming substitution to a proposition. *) -let prop_ren_sub tenv (ren_sub: Sil.exp_subst) (prop: normal t) : normal t = +let prop_ren_sub tenv (ren_sub : Sil.exp_subst) (prop : normal t) : normal t = Normalize.normalize tenv (prop_sub (`Exp ren_sub) prop) (** Existentially quantify the [ids] in [prop]. [ids] should not contain any primed variables. If [ids_queue] is passed then the function uses it instead of [ids] for membership tests. *) -let exist_quantify tenv ?ids_queue ids (prop: normal t) : normal t = +let exist_quantify tenv ?ids_queue ids (prop : normal t) : normal t = assert (not (List.exists ~f:Ident.is_primed ids)) ; (* sanity check *) if List.is_empty ids then prop @@ -2289,7 +2284,7 @@ let exist_quantify tenv ?ids_queue ids (prop: normal t) : normal t = (** Apply the substitution [fe] to all the expressions in the prop. *) -let prop_expmap (fe: Exp.t -> Exp.t) prop = +let prop_expmap (fe : Exp.t -> Exp.t) prop = let f (e, sil_opt) = (fe e, sil_opt) in let pi = List.map ~f:(Sil.atom_expmap fe) prop.pi in let sigma = List.map ~f:(Sil.hpred_expmap f) prop.sigma in @@ -2307,10 +2302,11 @@ let prop_normal_vars_to_primed_vars tenv p = (** convert the primed vars to normal vars. *) -let prop_primed_vars_to_normal_vars tenv (prop: normal t) : normal t = +let prop_primed_vars_to_normal_vars tenv (prop : normal t) : normal t = let ids = - free_vars prop |> Sequence.filter ~f:Ident.is_primed |> Ident.hashqueue_of_sequence - |> Ident.HashQueue.keys + free_vars prop + |> Sequence.filter ~f:Ident.is_primed + |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let ren_sub = Sil.exp_subst_of_list @@ -2431,8 +2427,8 @@ let rec prop_iter_find iter filter = match filter iter.pit_curr with | Some st -> Some {iter with pit_state= st} - | None -> - match prop_iter_next iter with None -> None | Some iter' -> prop_iter_find iter' filter + | None -> ( + match prop_iter_next iter with None -> None | Some iter' -> prop_iter_find iter' filter ) (** Set the state of the iterator *) @@ -2448,7 +2444,7 @@ let prop_iter_make_id_primed tenv id iter = let rec split pairs_unpid pairs_pid = function | [] -> (List.rev pairs_unpid, List.rev pairs_pid) - | (eq :: eqs_cur: pi) -> + | (eq :: eqs_cur : pi) -> ( match eq with | Aeq (Var id1, e1) when Exp.ident_mem e1 id1 -> L.internal_error "@[<2>#### ERROR: an assumption of the analyzer broken ####@\n" ; @@ -2461,7 +2457,7 @@ let prop_iter_make_id_primed tenv id iter = | Aeq (Var id1, e1) -> split ((id1, e1) :: pairs_unpid) pairs_pid eqs_cur | _ -> - assert false + assert false ) in let rec get_eqs acc = function | [] | [_] -> @@ -2528,7 +2524,7 @@ let prop_iter_get_footprint_sigma iter = iter.pit_sigma_fp (** Replace the sigma part of the footprint *) let prop_iter_replace_footprint_sigma iter sigma = {iter with pit_sigma_fp= sigma} -let rec strexp_gc_fields (se: Sil.strexp) = +let rec strexp_gc_fields (se : Sil.strexp) = match se with | Eexp _ -> Some se @@ -2538,13 +2534,13 @@ let rec strexp_gc_fields (se: Sil.strexp) = let fselo' = List.filter ~f:(function _, Some _ -> true | _ -> false) fselo in List.map ~f:(function f, seo -> (f, unSome seo)) fselo' in - if [%compare.equal : (Typ.Fieldname.t * Sil.strexp) list] fsel fsel' then Some se + if [%compare.equal: (Typ.Fieldname.t * Sil.strexp) list] fsel fsel' then Some se else Some (Sil.Estruct (fsel', inst)) | Earray _ -> Some se -let hpred_gc_fields (hpred: Sil.hpred) : Sil.hpred = +let hpred_gc_fields (hpred : Sil.hpred) : Sil.hpred = match hpred with | Hpointsto (e, se, te) -> ( match strexp_gc_fields se with @@ -2590,7 +2586,7 @@ end = struct and hpara_dll_size hpara_dll = sigma_size hpara_dll.Sil.body_dll - and hpred_size (hpred: Sil.hpred) = + and hpred_size (hpred : Sil.hpred) = match hpred with | Hpointsto _ -> ptsto_weight diff --git a/infer/src/biabduction/PropUtil.ml b/infer/src/biabduction/PropUtil.ml index 76e666c42..f0ef7db11 100644 --- a/infer/src/biabduction/PropUtil.ml +++ b/infer/src/biabduction/PropUtil.ml @@ -6,12 +6,12 @@ *) open! IStd -let get_name_of_local (curr_f: Procdesc.t) (var_data: ProcAttributes.var_data) = +let get_name_of_local (curr_f : Procdesc.t) (var_data : ProcAttributes.var_data) = Pvar.mk var_data.name (Procdesc.get_proc_name curr_f) (* returns a list of local static variables (ie local variables defined static) in a proposition *) -let get_name_of_objc_static_locals (curr_f: Procdesc.t) p = +let get_name_of_objc_static_locals (curr_f : Procdesc.t) p = let pname = Typ.Procname.to_string (Procdesc.get_proc_name curr_f) in let local_static e = match e with @@ -74,7 +74,8 @@ let remove_abduced_retvars tenv p = let exps' = List.fold ~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc) - ~init:exps (exp1 :: exp2 :: exp3 :: exp4 :: exp_l) + ~init:exps + (exp1 :: exp2 :: exp3 :: exp4 :: exp_l) in (reach', exps') | _ -> @@ -101,10 +102,10 @@ let remove_abduced_retvars tenv p = in List.filter ~f:(function - | Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) -> - exp_contains lhs || exp_contains rhs - | Sil.Apred (_, es) | Sil.Anpred (_, es) -> - List.exists ~f:exp_contains es) + | Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) -> + exp_contains lhs || exp_contains rhs + | Sil.Apred (_, es) | Sil.Anpred (_, es) -> + List.exists ~f:exp_contains es) pi in (Sil.HpredSet.elements reach_hpreds, reach_pi) @@ -133,7 +134,7 @@ let remove_abduced_retvars tenv p = Prop.normalize tenv (Prop.set p' ~pi:pi_reach ~sigma:sigma_reach) -let remove_locals tenv (curr_f: Procdesc.t) p = +let remove_locals tenv (curr_f : Procdesc.t) p = let names_of_locals = List.map ~f:(get_name_of_local curr_f) (Procdesc.get_locals curr_f) in let names_of_locals' = match !Language.curr_language with @@ -149,14 +150,14 @@ let remove_locals tenv (curr_f: Procdesc.t) p = (removed, remove_abduced_retvars tenv p') -let remove_formals tenv (curr_f: Procdesc.t) p = +let remove_formals tenv (curr_f : Procdesc.t) p = let pname = Procdesc.get_proc_name curr_f in let formal_vars = List.map ~f:(fun (n, _) -> Pvar.mk n pname) (Procdesc.get_formals curr_f) in Attribute.deallocate_stack_vars tenv p formal_vars (** remove the return variable from the prop *) -let remove_ret tenv (curr_f: Procdesc.t) (p: Prop.normal Prop.t) = +let remove_ret tenv (curr_f : Procdesc.t) (p : Prop.normal Prop.t) = let pname = Procdesc.get_proc_name curr_f in let name_of_ret = Procdesc.get_ret_var curr_f in let _, p' = Attribute.deallocate_stack_vars tenv p [Pvar.to_callee pname name_of_ret] in @@ -164,20 +165,20 @@ let remove_ret tenv (curr_f: Procdesc.t) (p: Prop.normal Prop.t) = (** remove locals and return variable from the prop *) -let remove_locals_ret tenv (curr_f: Procdesc.t) p = +let remove_locals_ret tenv (curr_f : Procdesc.t) p = snd (remove_locals tenv curr_f (remove_ret tenv curr_f p)) (** Remove locals and formal parameters from the prop. Return the list of stack variables whose address was still present after deallocation. *) -let remove_locals_formals tenv (curr_f: Procdesc.t) p = +let remove_locals_formals tenv (curr_f : Procdesc.t) p = let pvars1, p1 = remove_locals tenv curr_f p in let pvars2, p2 = remove_formals tenv curr_f p1 in (pvars1 @ pvars2, p2) (** remove seed vars from a prop *) -let remove_seed_vars tenv (prop: 'a Prop.t) : Prop.normal Prop.t = +let remove_seed_vars tenv (prop : 'a Prop.t) : Prop.normal Prop.t = let hpred_not_seed = function | Sil.Hpointsto (Exp.Lvar pv, _, _) -> not (Pvar.is_seed pv) diff --git a/infer/src/biabduction/Propgraph.ml b/infer/src/biabduction/Propgraph.ml index 0927e782e..827ee92c7 100644 --- a/infer/src/biabduction/Propgraph.ml +++ b/infer/src/biabduction/Propgraph.ml @@ -70,7 +70,8 @@ let get_edges footprint_part g = let hpreds = get_sigma footprint_part g in let atoms = get_pi footprint_part g in let subst_entries = get_subl footprint_part g in - List.map ~f:(fun hpred -> Ehpred hpred) hpreds @ List.map ~f:(fun a -> Eatom a) atoms + List.map ~f:(fun hpred -> Ehpred hpred) hpreds + @ List.map ~f:(fun a -> Eatom a) atoms @ List.map ~f:(fun entry -> Esub_entry entry) subst_entries @@ -88,7 +89,7 @@ let edge_equal e1 e2 = (** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e], searching the footprint part if [footprint_part] is true. *) -let contains_edge (footprint_part: bool) (g: _ t) (e: edge) = +let contains_edge (footprint_part : bool) (g : _ t) (e : edge) = List.exists ~f:(fun e' -> edge_equal e e') (get_edges footprint_part g) @@ -101,12 +102,12 @@ type 'a diff = ; diff_cmap_foot: Pp.colormap (** colormap for the footprint part *) } (** Compute the subobjects in [e2] which are different from those in [e1] *) -let compute_exp_diff (e1: Exp.t) (e2: Exp.t) : Obj.t list = +let compute_exp_diff (e1 : Exp.t) (e2 : Exp.t) : Obj.t list = if Exp.equal e1 e2 then [] else [Obj.repr e2] (** Compute the subobjects in [se2] which are different from those in [se1] *) -let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list = +let rec compute_sexp_diff (se1 : Sil.strexp) (se2 : Sil.strexp) : Obj.t list = match (se1, se2) with | Sil.Eexp (e1, _), Sil.Eexp (e2, _) -> if Exp.equal e1 e2 then [] else [Obj.repr se2] @@ -151,7 +152,7 @@ and compute_esel_diff esel1 esel2 : Obj.t list = (** Compute the subobjects in [newedge] which are different from those in [oldedge] *) -let compute_edge_diff (oldedge: edge) (newedge: edge) : Obj.t list = +let compute_edge_diff (oldedge : edge) (newedge : edge) : Obj.t list = match (oldedge, newedge) with | Ehpred (Sil.Hpointsto (_, se1, e1)), Ehpred (Sil.Hpointsto (_, se2, e2)) -> compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2 @@ -195,7 +196,7 @@ let compute_diff default_color oldgraph newgraph : _ diff = () in List.iter ~f:build_changed newedges ; - let colormap (o: Obj.t) = + let colormap (o : Obj.t) = if List.exists ~f:(fun x -> phys_equal x o) !changed then Pp.Red else default_color in (!changed, colormap) @@ -224,7 +225,7 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist = let add_base_stack prop = if extract_stack then Prop.set prop ~sigma:(base_stack @ prop.Prop.sigma) else Prop.expose prop in - let update_pe_diff (prop: _ Prop.t) : Pp.env = + let update_pe_diff (prop : _ Prop.t) : Pp.env = if Config.print_using_diff then let diff = compute_diff Blue (from_prop base_prop) (from_prop prop) in let cmap_norm = diff_get_colormap false diff in @@ -235,8 +236,7 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist = let rec pp_seq_newline n f = function | [] -> () - | [x_] - -> ( + | [x_] -> ( let pe = update_pe_diff x_ in let x = add_base_stack x_ in match pe.kind with @@ -244,7 +244,7 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist = F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x | HTML -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x ) - | _x :: l -> + | _x :: l -> ( let pe = update_pe_diff _x in let x = add_base_stack _x in match pe.kind with @@ -255,12 +255,12 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist = | HTML -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) - l + l ) in pp_seq_newline 1 f plist (** dump a propset *) -let d_proplist (p: 'a Prop.t) (pl: 'b Prop.t list) = +let d_proplist (p : 'a Prop.t) (pl : 'b Prop.t list) = let pp pe = pp_proplist pe "PROP" (p, false) in L.add_print_with_pe pp pl diff --git a/infer/src/biabduction/Prover.ml b/infer/src/biabduction/Prover.ml index 55450afbc..887321bbe 100644 --- a/infer/src/biabduction/Prover.ml +++ b/infer/src/biabduction/Prover.ml @@ -34,7 +34,7 @@ let rec remove_redundancy have_same_key acc = function else remove_redundancy have_same_key (x :: acc) l -let rec is_java_class tenv (typ: Typ.t) = +let rec is_java_class tenv (typ : Typ.t) = match typ.desc with | Tstruct name -> Typ.Name.Java.is_class name @@ -85,7 +85,7 @@ module DiffConstr : sig end = struct type t = Exp.t * Exp.t * IntLit.t [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let to_leq (e1, e2, n) = (Exp.BinOp (Binop.MinusA, e1, e2), Exp.int n) @@ -145,7 +145,7 @@ end = struct let sort_then_remove_redundancy constraints = let constraints_sorted = List.sort ~compare constraints in let have_same_key (e1, e2, _) (f1, f2, _) = - [%compare.equal : Exp.t * Exp.t] (e1, e2) (f1, f2) + [%compare.equal: Exp.t * Exp.t] (e1, e2) (f1, f2) in remove_redundancy have_same_key [] constraints_sorted @@ -166,7 +166,7 @@ end = struct | constr :: rest, constr' :: rest' -> let e1, e2, n = constr in let f1, f2, m = constr' in - let c1 = [%compare : Exp.t * Exp.t] (e1, e2) (f1, f2) in + let c1 = [%compare: Exp.t * Exp.t] (e1, e2) (f1, f2) in if Int.equal c1 0 && IntLit.lt n m then combine acc_todos acc_seen constraints_new rest' else if Int.equal c1 0 then combine acc_todos acc_seen rest constraints_old else if c1 < 0 then combine (constr :: acc_todos) (constr :: acc_seen) rest constraints_old @@ -365,27 +365,27 @@ end = struct let rec umap_improve_by_difference_constraints umap = function | [] -> umap - | constr :: constrs_rest -> + | constr :: constrs_rest -> ( try let e1, e2, n = DiffConstr.to_triple constr (* e1 - e2 <= n *) in let upper2 = Exp.Map.find e2 umap in let new_upper1 = upper2 ++ n in let new_umap = umap_add umap e1 new_upper1 in umap_improve_by_difference_constraints new_umap constrs_rest - with Caml.Not_found -> umap_improve_by_difference_constraints umap constrs_rest + with Caml.Not_found -> umap_improve_by_difference_constraints umap constrs_rest ) in let rec lmap_improve_by_difference_constraints lmap = function | [] -> lmap - | constr :: constrs_rest -> - (* e2 - e1 > -n-1 *) + | constr :: constrs_rest -> ( try + (* e2 - e1 > -n-1 *) let e1, e2, n = DiffConstr.to_triple constr (* e2 - e1 > -n-1 *) in let lower1 = Exp.Map.find e1 lmap in let new_lower2 = lower1 -- n -- IntLit.one in let new_lmap = lmap_add lmap e2 new_lower2 in lmap_improve_by_difference_constraints new_lmap constrs_rest - with Caml.Not_found -> lmap_improve_by_difference_constraints lmap constrs_rest + with Caml.Not_found -> lmap_improve_by_difference_constraints lmap constrs_rest ) in let leqs_res = let umap = umap_create_from_leqs Exp.Map.empty leqs in @@ -509,16 +509,16 @@ end = struct (* [e <= n' <= n |- e <= n] *) List.exists ~f:(function - | e', Exp.Const (Const.Cint n') -> Exp.equal e e' && IntLit.leq n' n | _, _ -> false) + | e', Exp.Const (Const.Cint n') -> Exp.equal e e' && IntLit.leq n' n | _, _ -> false) leqs | Exp.Const (Const.Cint n), e -> (* [ n-1 <= n' < e |- n <= e] *) List.exists ~f:(function - | Exp.Const (Const.Cint n'), e' -> - Exp.equal e e' && IntLit.leq (n -- IntLit.one) n' - | _, _ -> - false) + | Exp.Const (Const.Cint n'), e' -> + Exp.equal e e' && IntLit.leq (n -- IntLit.one) n' + | _, _ -> + false) lts | _ -> Exp.equal e1 e2 @@ -534,16 +534,16 @@ end = struct (* [n <= n' < e |- n < e] *) List.exists ~f:(function - | Exp.Const (Const.Cint n'), e' -> Exp.equal e e' && IntLit.leq n n' | _, _ -> false) + | Exp.Const (Const.Cint n'), e' -> Exp.equal e e' && IntLit.leq n n' | _, _ -> false) lts | e, Exp.Const (Const.Cint n) -> (* [e <= n' <= n-1 |- e < n] *) List.exists ~f:(function - | e', Exp.Const (Const.Cint n') -> - Exp.equal e e' && IntLit.leq n' (n -- IntLit.one) - | _, _ -> - false) + | e', Exp.Const (Const.Cint n') -> + Exp.equal e e' && IntLit.leq n' (n -- IntLit.one) + | _, _ -> + false) leqs | _ -> false @@ -604,7 +604,8 @@ end = struct let inconsistent_neq (e1, e2) = check_le ineq e1 e2 && check_le ineq e2 e1 in let inconsistent_leq (e1, e2) = check_lt ineq e2 e1 in let inconsistent_lt (e1, e2) = check_le ineq e2 e1 in - List.exists ~f:inconsistent_neq neqs || List.exists ~f:inconsistent_leq leqs + List.exists ~f:inconsistent_neq neqs + || List.exists ~f:inconsistent_leq leqs || List.exists ~f:inconsistent_lt lts (* @@ -717,8 +718,7 @@ let check_disequal tenv prop e1 e2 = Const.kind_equal c1 c2 && not (Const.equal c1 c2) | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const (Const.Cint d)) -> if IntLit.iszero d then not (Const.equal c1 c2) (* offset=0 is no offset *) - else Const.equal c1 c2 - (* same base, different offsets *) + else Const.equal c1 c2 (* same base, different offsets *) | ( Exp.BinOp (Binop.PlusA, e1, Exp.Const (Const.Cint d1)) , Exp.BinOp (Binop.PlusA, e2, Exp.Const (Const.Cint d2)) ) -> if Exp.equal e1 e2 then IntLit.neq d1 d2 else false @@ -739,7 +739,7 @@ let check_disequal tenv prop e1 e2 = not (Pvar.equal pv0 pv1) | Exp.Lvar pv, Exp.Var id | Exp.Var id, Exp.Lvar pv -> (* Address of any non-global var must be different from the value of any footprint var *) - not (Pvar.is_global pv) && Ident.is_footprint id + (not (Pvar.is_global pv)) && Ident.is_footprint id | Exp.Lvar _, Exp.Const (Const.Cint _) | Exp.Const (Const.Cint _), Exp.Lvar _ -> (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) (* Assume they are not equal *) @@ -789,7 +789,7 @@ let check_disequal tenv prop e1 e2 = else let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (false, sigma_irrelevant') - | (Sil.Hdllseg (Sil.Lseg_PE, _, iF, _, oF, _, _) as hpred) :: sigma_rest -> + | (Sil.Hdllseg (Sil.Lseg_PE, _, iF, _, oF, _, _) as hpred) :: sigma_rest -> ( match is_root tenv prop iF e with | None -> let sigma_irrelevant' = hpred :: sigma_irrelevant in @@ -803,7 +803,7 @@ let check_disequal tenv prop e1 e2 = Some (false, sigma_irrelevant') else let sigma_rest' = List.rev_append sigma_irrelevant sigma_rest in - f [] oF sigma_rest' + f [] oF sigma_rest' ) in let f_null_check sigma_irrelevant e sigma_rest = if not (Exp.equal e Exp.zero) then f sigma_irrelevant e sigma_rest @@ -814,12 +814,12 @@ let check_disequal tenv prop e1 e2 = match f_null_check [] n_e1 spatial_part with | None -> false - | Some (e1_allocated, spatial_part_leftover) -> + | Some (e1_allocated, spatial_part_leftover) -> ( match f_null_check [] n_e2 spatial_part_leftover with | None -> false - | Some ((e2_allocated: bool), _) -> - e1_allocated || e2_allocated + | Some ((e2_allocated : bool), _) -> + e1_allocated || e2_allocated ) in let check_disequal_expr () = check_expr_disequal n_e1 n_e2 in let neq_pure_part () = check_pi_implies_disequal n_e1 n_e2 in @@ -1041,9 +1041,10 @@ let check_inconsistency_base tenv prop = *) Inequalities.inconsistent ineq in - inconsistent_ptsto () || check_inconsistency_two_hpreds tenv prop - || List.exists ~f:inconsistent_atom pi || inconsistent_inequalities () - || inconsistent_this_self_var () + inconsistent_ptsto () + || check_inconsistency_two_hpreds tenv prop + || List.exists ~f:inconsistent_atom pi + || inconsistent_inequalities () || inconsistent_this_self_var () (** Inconsistency checking. *) @@ -1218,17 +1219,9 @@ end = struct Prop.d_sub sub ; L.d_decrease_indent 1 ; if !missing_pi <> [] && !missing_sigma <> [] then ( - L.d_ln () ; - Prop.d_pi !missing_pi ; - L.d_str "*" ; - L.d_ln () ; - Prop.d_sigma !missing_sigma ) - else if !missing_pi <> [] then ( - L.d_ln () ; - Prop.d_pi !missing_pi ) - else if !missing_sigma <> [] then ( - L.d_ln () ; - Prop.d_sigma !missing_sigma ) ; + L.d_ln () ; Prop.d_pi !missing_pi ; L.d_str "*" ; L.d_ln () ; Prop.d_sigma !missing_sigma ) + else if !missing_pi <> [] then ( L.d_ln () ; Prop.d_pi !missing_pi ) + else if !missing_sigma <> [] then ( L.d_ln () ; Prop.d_sigma !missing_sigma ) ; if !missing_fld <> [] then ( L.d_ln () ; L.d_strln "MISSING FLD: " ; @@ -1333,10 +1326,10 @@ let extend_sub sub v e = (** Extend [sub1] and [sub2] to witnesses that each instance of [e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not possible. *) -let exp_imply tenv calc_missing (subs: subst2) e1_in e2_in : subst2 = +let exp_imply tenv calc_missing (subs : subst2) e1_in e2_in : subst2 = let e1 = Prop.exp_normalize_noabs tenv (`Exp (fst subs)) e1_in in let e2 = Prop.exp_normalize_noabs tenv (`Exp (snd subs)) e2_in in - let var_imply (subs: subst2) v1 v2 : subst2 = + let var_imply (subs : subst2) v1 v2 : subst2 = match (Ident.is_primed v1, Ident.is_primed v2) with | false, false -> if Ident.equal v1 v2 then subs @@ -1502,8 +1495,8 @@ let array_len_imply tenv calc_missing subs len1 len2 indices2 = (** Extend [sub1] and [sub2] to witnesses that each instance of [se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not possible. *) -let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 - : subst2 * Sil.strexp option * Sil.strexp option = +let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 : + subst2 * Sil.strexp option * Sil.strexp option = (* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_str " : "; Typ.d_full typ2; L.d_ln(); *) match (se1, se2) with @@ -1520,8 +1513,7 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 if fld_missing <> [] then Some (Sil.Estruct (fld_missing, inst1)) else None in (subs', fld_frame_opt, fld_missing_opt) - | Sil.Estruct _, Sil.Eexp (e2, _) - -> ( + | Sil.Estruct _, Sil.Eexp (e2, _) -> ( let e2' = Sil.exp_sub (`Exp (snd subs)) e2 in match e2' with | Exp.Var id2 when Ident.is_primed id2 -> @@ -1555,8 +1547,9 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 let g (f, _) = (f, Sil.Eexp (Exp.Var (Ident.create_fresh Ident.knormal), inst)) in List.map ~f:g fsel in - sexp_imply tenv source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 - typ2 + sexp_imply tenv source calc_index_frame calc_missing subs + (Sil.Estruct (fsel', inst')) + se2 typ2 | Sil.Eexp _, Sil.Earray (len, _, inst) | Sil.Estruct _, Sil.Earray (len, _, inst) -> let se1' = Sil.Earray (len, [(Exp.zero, se1)], inst) in sexp_imply tenv source calc_index_frame calc_missing subs se1' se2 typ2 @@ -1575,8 +1568,8 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 raise (Exceptions.Abduction_case_not_implemented __POS__) -and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 - : subst2 * (Typ.Fieldname.t * Sil.strexp) list * (Typ.Fieldname.t * Sil.strexp) list = +and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : + subst2 * (Typ.Fieldname.t * Sil.strexp) list * (Typ.Fieldname.t * Sil.strexp) list = let lookup = Tenv.lookup tenv in match (fsel1, fsel2) with | _, [] -> @@ -1624,8 +1617,8 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 (subs'', fld_frame, (f2, se2) :: fld_missing) -and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 - : subst2 * (Exp.t * Sil.strexp) list * (Exp.t * Sil.strexp) list = +and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 : + subst2 * (Exp.t * Sil.strexp) list * (Exp.t * Sil.strexp) list = let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ2 in match (esel1, esel2) with | _, [] -> @@ -1652,10 +1645,9 @@ and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 (subs'', index_frame, index_missing') -and sexp_imply_nolhs tenv source calc_missing (subs: subst2) se2 typ2 = +and sexp_imply_nolhs tenv source calc_missing (subs : subst2) se2 typ2 = match se2 with - | Sil.Eexp (e2_, _) - -> ( + | Sil.Eexp (e2_, _) -> ( let e2 = Sil.exp_sub (`Exp (snd subs)) e2_ in match e2 with | Exp.Var v2 when Ident.is_primed v2 -> @@ -1708,8 +1700,7 @@ let filter_hpred sub hpred2 hpred1 = else None | Sil.Hlseg (Sil.Lseg_PE, hpara1, e1, f1, el1), Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) -> if Sil.equal_hpred (Sil.Hlseg (Sil.Lseg_NE, hpara1, e1, f1, el1)) hpred2 then Some true - else None - (* return missing disequality *) + else None (* return missing disequality *) | Sil.Hpointsto (e1, _, _), Sil.Hlseg (_, _, e2, _, _) -> if Exp.equal e1 e2 then Some false else None | hpred1, hpred2 -> @@ -1781,7 +1772,7 @@ let expand_hpred_pointer = with | Some se -> se - | None -> + | None -> ( match cnt_texp with | Sizeof ({typ= cnt_typ} as sizeof_data) -> (* type of struct at adr_base is unknown (typically Tvoid), but @@ -1794,7 +1785,7 @@ let expand_hpred_pointer = | _ -> (* type of struct at adr_base and of contents are both unknown: give up *) L.(die InternalError) - "expand_hpred_pointer: Unexpected non-sizeof type in Lfield" + "expand_hpred_pointer: Unexpected non-sizeof type in Lfield" ) in let hpred' = Sil.Hpointsto (adr_base, Estruct ([(fld, cnt)], Sil.inst_none), cnt_texp') @@ -1846,7 +1837,7 @@ module Subtyping_check = struct (** check if t1 is a subtype of t2, in Java *) - let rec check_subtype_java tenv (t1: Typ.t) (t2: Typ.t) = + let rec check_subtype_java tenv (t1 : Typ.t) (t2 : Typ.t) = match (t1.Typ.desc, t2.Typ.desc) with | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) -> Subtype.is_known_subtype tenv cn1 cn2 @@ -1873,7 +1864,7 @@ module Subtyping_check = struct false - let rec case_analysis_type tenv ((t1: Typ.t), st1) ((t2: Typ.t), st2) = + let rec case_analysis_type tenv ((t1 : Typ.t), st1) ((t2 : Typ.t), st2) = match (t1.desc, t2.desc) with | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) -> Subtype.case_analysis tenv (cn1, st1) (cn2, st2) @@ -1948,7 +1939,7 @@ let texp_equal_modulo_subtype_flag texp1 texp2 = match (texp1, texp2) with | ( Exp.Sizeof {typ= t1; dynamic_length= len1; subtype= st1} , Exp.Sizeof {typ= t2; dynamic_length= len2; subtype= st2} ) -> - [%compare.equal : Typ.t * Exp.t option] (t1, len1) (t2, len2) + [%compare.equal: Typ.t * Exp.t option] (t1, len1) (t2, len2) && Subtype.equal_modulo_flag st1 st2 | _ -> Exp.equal texp1 texp2 @@ -1963,7 +1954,8 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing = | Exp.Sizeof {typ= typ1}, Exp.Sizeof {typ= typ2} -> ( match (typ1.desc, typ2.desc) with | (Tstruct _ | Tarray _), (Tstruct _ | Tarray _) -> - is_java_class tenv typ1 || (Typ.is_cpp_class typ1 && Typ.is_cpp_class typ2) + is_java_class tenv typ1 + || (Typ.is_cpp_class typ1 && Typ.is_cpp_class typ2) || (Typ.is_objc_class typ1 && Typ.is_objc_class typ2) | _ -> false ) @@ -2043,9 +2035,8 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 , Sil.Eexp (e2', _) ) when not (is_allocated_lhs e1') -> ( match type_rhs e2' with - | Some sizeof_data2 - -> ( - if not (Typ.equal t1 t2) && Subtyping_check.check_subtype tenv t1 t2 then + | Some sizeof_data2 -> ( + if (not (Typ.equal t1 t2)) && Subtyping_check.check_subtype tenv t1 t2 then let pos_type_opt, _ = Subtyping_check.subtype_case_analysis tenv (Exp.Sizeof {typ= t1; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes}) @@ -2065,11 +2056,10 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 if is_callee && !Config.footprint then add_subtype () -let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 - : subst2 * Prop.normal Prop.t = +let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 : + subst2 * Prop.normal Prop.t = match hpred2 with - | Sil.Hpointsto (e2_, se2, texp2) - -> ( + | Sil.Hpointsto (e2_, se2, texp2) -> ( let e2 = Sil.exp_sub (`Exp (snd subs)) e2_ in ( match e2 with | Exp.Lvar _ -> @@ -2083,11 +2073,11 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 match Prop.prop_iter_create prop1 with | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) - | Some iter1 -> + | Some iter1 -> ( match Prop.prop_iter_find iter1 (filter_ne_lhs (`Exp (fst subs)) e2) with | None -> raise (IMPL_EXC ("lhs does not have e|->", subs, EXC_FALSE_HPRED hpred2)) - | Some iter1' -> + | Some iter1' -> ( match Prop.prop_iter_current tenv iter1' with | Sil.Hpointsto (e1, se1, texp1), _ -> ( try @@ -2173,9 +2163,8 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 in L.d_decrease_indent 1 ; res | _ -> - assert false ) - | Sil.Hlseg (k, para2, e2_, f2_, elist2_) - -> ( + assert false ) ) ) + | Sil.Hlseg (k, para2, e2_, f2_, elist2_) -> ( (* for now ignore implications between PE and NE *) let e2, f2 = (Sil.exp_sub (`Exp (snd subs)) e2_, Sil.exp_sub (`Exp (snd subs)) f2_) in ( match e2 with @@ -2192,7 +2181,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 match Prop.prop_iter_create prop1 with | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) - | Some iter1 -> + | Some iter1 -> ( match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (`Exp (snd subs)) hpred2)) @@ -2207,7 +2196,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 in (* calc_missing is false as we're checking an instantiation of the original list *) L.d_decrease_indent 1 ; res - | Some iter1' -> + | Some iter1' -> ( let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) elist2_ in (* force instantiation of existentials *) let subs' = exp_list_imply tenv calc_missing subs (f2 :: elist2) (f2 :: elist2) in @@ -2239,11 +2228,11 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 in L.d_decrease_indent 1 ; res | Sil.Hdllseg _ -> - assert false ) + assert false ) ) ) | Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) -> d_impl_err ("rhs dllsegPE not implemented", subs, EXC_FALSE_HPRED hpred2) ; raise (Exceptions.Abduction_case_not_implemented __POS__) - | Sil.Hdllseg (_, para2, iF2, oB2, oF2, iB2, elist2) -> + | Sil.Hdllseg (_, para2, iF2, oB2, oF2, iB2, elist2) -> ( (* for now ignore implications between PE and NE *) let iF2, oF2 = (Sil.exp_sub (`Exp (snd subs)) iF2, Sil.exp_sub (`Exp (snd subs)) oF2) in let iB2, oB2 = (Sil.exp_sub (`Exp (snd subs)) iB2, Sil.exp_sub (`Exp (snd subs)) oB2) in @@ -2268,7 +2257,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 match Prop.prop_iter_create prop1 with | None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) - | Some iter1 -> + | Some iter1 -> ( match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (`Exp (snd subs)) hpred2)) @@ -2292,22 +2281,23 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) elist2 in (* force instantiation of existentials *) let subs' = - exp_list_imply tenv calc_missing subs (iF2 :: oB2 :: oF2 :: iB2 :: elist2) + exp_list_imply tenv calc_missing subs + (iF2 :: oB2 :: oF2 :: iB2 :: elist2) (iF2 :: oB2 :: oF2 :: iB2 :: elist2) in let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in - (subs', prop1') + (subs', prop1') ) ) (** Check that [sigma1] implies [sigma2] and return two substitution instantiations for the primed variables of [sigma1] and [sigma2] and a frame. Raise IMPL_FALSE if the implication cannot be proven. *) -and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * Prop.normal Prop.t = +and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * Prop.normal Prop.t + = let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *) - | Sil.Hpointsto (e2_, _, _) - -> ( + | Sil.Hpointsto (e2_, _, _) -> ( let e2 = Sil.exp_sub (`Exp (snd subs)) e2_ in match e2 with | Exp.Const (Const.Cstr s) -> @@ -2390,7 +2380,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * L.d_strln "Final Implication" ; d_impl subs (prop1, Prop.prop_emp) ; (subs, prop1) - | hpred2 :: sigma2' -> + | hpred2 :: sigma2' -> ( L.d_strln "Current Implication" ; d_impl subs (prop1, Prop.normalize tenv (Prop.from_sigma (hpred2 :: sigma2'))) ; L.d_ln () ; @@ -2404,7 +2394,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2' ) in L.d_decrease_indent 1 ; res - with IMPL_EXC _ when calc_missing -> + with IMPL_EXC _ when calc_missing -> ( match is_constant_string_class subs hpred2' with | Some (s, is_string) -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *) @@ -2429,7 +2419,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * subs in ProverState.add_missing_sigma [hpred2'] ; - (subs', prop1) + (subs', prop1) ) in L.d_increase_indent 1 ; let res = @@ -2449,7 +2439,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * (* calc_index_frame=true *) else normal_case hpred2' | _ -> - normal_case hpred2 + normal_case hpred2 ) with IMPL_EXC (s, _, _) when calc_missing -> L.d_strln ("Adding rhs as missing: " ^ s) ; ProverState.add_missing_sigma sigma2 ; @@ -2485,12 +2475,11 @@ 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 = +let rec pre_check_pure_implication tenv calc_missing (subs : subst2) pi1 pi2 = match pi2 with | [] -> subs - | (Sil.Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) - -> ( + | (Sil.Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) -> ( let e2, f2 = (Sil.exp_sub (`Exp (snd subs)) e2_in, Sil.exp_sub (`Exp (snd subs)) f2_in) in if Exp.equal e2 f2 then pre_check_pure_implication tenv calc_missing subs pi1 pi2' else @@ -2509,7 +2498,7 @@ let rec pre_check_pure_implication tenv calc_missing (subs: subst2) pi1 pi2 = imply_atom tenv calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in)) ; pre_check_pure_implication tenv calc_missing subs pi1 pi2' ) | (Sil.Aneq (e, _) | Apred (_, e :: _) | Anpred (_, e :: _)) :: _ - when not calc_missing && match e with Var v -> not (Ident.is_primed v) | _ -> true -> + 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" @@ -2642,7 +2631,7 @@ type implication_result = [Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)] where [sub] is a substitution which instantiates the primed vars of [p1] and [p2], which are assumed to be disjoint. *) -let check_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) = +let check_implication_for_footprint pname tenv p1 (p2 : Prop.exposed Prop.t) = let check_frame_empty = false in let calc_missing = true in match check_implication_base pname tenv check_frame_empty calc_missing p1 p2 with diff --git a/infer/src/biabduction/Rearrange.ml b/infer/src/biabduction/Rearrange.ml index 083aeccab..3b461533d 100644 --- a/infer/src/biabduction/Rearrange.ml +++ b/infer/src/biabduction/Rearrange.ml @@ -77,8 +77,8 @@ let bounds_check tenv pname prop len e = check_bad_index tenv pname prop len e -let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp (t: Typ.t) - (off: Sil.offset list) inst : Sil.atom list * Sil.strexp * Typ.t = +let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp (t : Typ.t) + (off : Sil.offset list) inst : Sil.atom list * Sil.strexp * Typ.t = if Config.trace_rearrange then ( L.d_increase_indent 1 ; L.d_strln "entering create_struct_values" ; @@ -89,10 +89,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp Sil.d_offset_list off ; L.d_ln () ; L.d_ln () ) ; - let new_id () = - incr max_stamp ; - Ident.create kind !max_stamp - in + let new_id () = incr max_stamp ; Ident.create kind !max_stamp in let res = let fail t off pos = L.d_str "create_struct_values type:" ; @@ -135,8 +132,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp let se = Sil.Earray (len, [(e', se')], inst) in let res_t = Typ.mk_array res_t' in (Sil.Aeq (e, e') :: atoms', se, res_t) - | Tarray {elt= t'; length; stride}, off - -> ( + | Tarray {elt= t'; length; stride}, off -> ( let len = match length with None -> Exp.Var (new_id ()) | Some len -> Exp.Const (Const.Cint len) in @@ -161,8 +157,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp (* In this case, we lift t to the t array. *) let t', mk_typ_f = match t.Typ.desc with - | Typ.Tptr (t', _) - -> ( + | Typ.Tptr (t', _) -> ( (t', function desc -> Typ.mk ~default:t desc) ) | _ -> (t, fun desc -> Typ.mk desc) @@ -193,12 +188,9 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp for array accesses. This does not catch the array - bounds errors. If we want to implement the checks for array bounds errors, we need to change this function. *) -let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se (typ: Typ.t) - (off: Sil.offset list) inst = - let new_id () = - incr max_stamp ; - Ident.create kind !max_stamp - in +let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se (typ : Typ.t) + (off : Sil.offset list) inst = + let new_id () = incr max_stamp ; Ident.create kind !max_stamp in match (off, se, typ.desc) with | [], Sil.Eexp _, _ | [], Sil.Estruct _, _ -> [([], se, typ)] @@ -224,8 +216,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp if Typ.Fieldname.equal f1 f then (f1, res_se') else ft1 in let res_fsel' = - List.sort - ~compare:[%compare : Typ.Fieldname.t * Sil.strexp] + List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] (List.map ~f:replace_fse fsel) in let replace_fta ((f1, _, a1) as fta1) = @@ -244,7 +235,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp inst in let res_fsel' = - List.sort ~compare:[%compare : Typ.Fieldname.t * Sil.strexp] ((f, se') :: fsel) + List.sort ~compare:[%compare: Typ.Fieldname.t * Sil.strexp] ((f, se') :: fsel) in let replace_fta (f', t', a') = if Typ.Fieldname.equal f' f then (f, res_typ', a') else (f', t', a') @@ -277,8 +268,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp inst | ( Off_index e :: off' , Sil.Earray (len, esel, inst_arr) - , Tarray {elt= typ'; length= len_for_typ'; stride} ) - -> ( + , Tarray {elt= typ'; length= len_for_typ'; stride} ) -> ( bounds_check tenv pname orig_prop len e (State.get_loc ()) ; match List.find ~f:(fun (e', _) -> Exp.equal e e') esel with | Some (_, se') -> @@ -330,7 +320,7 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in check_sound elem_typ ; let cont_new = - List.sort ~compare:[%compare : Exp.t * Sil.strexp] ((index, elem_se) :: array_cont) + List.sort ~compare:[%compare: Exp.t * Sil.strexp] ((index, elem_se) :: array_cont) in let array_new = Sil.Earray (array_len, cont_new, inst_arr) in let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in @@ -344,7 +334,7 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in check_sound elem_typ ; let cont_new = - List.sort ~compare:[%compare : Exp.t * Sil.strexp] ((index, elem_se) :: array_cont) + List.sort ~compare:[%compare: Exp.t * Sil.strexp] ((index, elem_se) :: array_cont) in let array_new = Sil.Earray (array_len, cont_new, inst_arr) in let typ_new = Typ.mk_array ~default:typ_array elem_typ ?length:typ_array_len in @@ -403,7 +393,7 @@ let laundry_offset_for_footprint max_stamp offs_in = let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se te - (off: Sil.offset list) inst = + (off : Sil.offset list) inst = let typ = Exp.texp_to_typ None te in let off', laundry_atoms = let off', eqs = laundry_offset_for_footprint max_stamp off in @@ -450,8 +440,8 @@ let collect_root_offset exp = (** Exp.Construct a points-to predicate for an expression, to add to a footprint. *) -let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst - : Sil.hpred * Sil.hpred * Sil.atom list = +let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst : + Sil.hpred * Sil.hpred * Sil.atom list = let root, off = collect_root_offset lexp in if not (exp_has_only_footprint_ids root) then if @@ -481,7 +471,8 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst let fun_name = Typ.Procname.from_string_c_fun (Mangled.to_string (Pvar.get_name pvar)) in let fun_exp = Exp.Const (Const.Cfun fun_name) in ( [] - , Prop.mk_ptsto tenv root (Sil.Eexp (fun_exp, inst)) + , Prop.mk_ptsto tenv root + (Sil.Eexp (fun_exp, inst)) (Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype}) ) | _, [], Typ.Tfun _ -> let atoms, se, typ = @@ -602,8 +593,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = let extend_kind = match e with (* Determine whether to extend the footprint part or just the normal part *) - | Exp.Var id - when not (Ident.is_footprint id) -> + | Exp.Var id when not (Ident.is_footprint id) -> Ident.kprimed | Exp.Lvar pvar when Pvar.is_local pvar -> Ident.kprimed @@ -627,12 +617,12 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = let sigma_pto, sigma_rest = List.partition_tf ~f:(function - | Sil.Hpointsto (e', _, _) -> - Exp.equal e e' - | Sil.Hlseg (_, _, e1, _, _) -> - Exp.equal e e1 - | Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) -> - Exp.equal e e_iF || Exp.equal e e_iB) + | Sil.Hpointsto (e', _, _) -> + Exp.equal e e' + | Sil.Hlseg (_, _, e1, _, _) -> + Exp.equal e e1 + | Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) -> + Exp.equal e e_iF || Exp.equal e e_iB) footprint_sigma in let atoms_sigma_list = @@ -708,8 +698,7 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst = in let iter = match Prop.prop_iter_create prop_new with - | None - -> ( + | None -> ( let prop_new' = Prop.normalize tenv (Prop.prop_hpred_star prop_new ptsto) in match Prop.prop_iter_create prop_new' with None -> assert false | Some iter -> iter ) | Some iter -> @@ -730,7 +719,8 @@ let add_guarded_by_constraints tenv prop lexp pdesc = (* don't warn on @GuardedBy("ui_thread") in any form *) let is_ui_thread str = let lowercase_str = String.lowercase str in - String.equal lowercase_str "ui_thread" || String.equal lowercase_str "ui-thread" + String.equal lowercase_str "ui_thread" + || String.equal lowercase_str "ui-thread" || String.equal lowercase_str "uithread" in is_invalid_exp_str str || is_ui_thread str @@ -772,7 +762,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = false in let extract_guarded_by_str item_annot = - let annot_extract_guarded_by_str ((annot: Annot.t), _) = + let annot_extract_guarded_by_str ((annot : Annot.t), _) = if Annotations.annot_ends_with annot Annotations.guarded_by then match annot.parameters with | [guarded_by_str] when not (excluded_guardedby_string guarded_by_str) -> @@ -784,7 +774,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = List.find_map ~f:annot_extract_guarded_by_str item_annot in let extract_suppress_warnings_str item_annot = - let annot_suppress_warnings_str ((annot: Annot.t), _) = + let annot_suppress_warnings_str ((annot : Annot.t), _) = if Annotations.annot_ends_with annot Annotations.suppress_lint then match annot.parameters with [suppr_str] -> Some suppr_str | _ -> None else None @@ -827,8 +817,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc = multiple objects of type T, but let's try to respect the intention *) let match_on_field_type typ flds = match String.rsplit2 guarded_by_str0 ~on:'.' with - | Some (class_part, field_part) - -> ( + | Some (class_part, field_part) -> ( let typ_matches_guarded_by _ {Typ.desc} = match desc with | Typ.Tptr (ptr_typ, _) -> @@ -840,11 +829,11 @@ let add_guarded_by_constraints tenv prop lexp pdesc = | Some (Sil.Eexp (matching_exp, _), _) -> List.find_map ~f:(function - | Sil.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof {typ= fld_typ}) - when Exp.equal lhs_exp matching_exp -> - get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds - | _ -> - None) + | Sil.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof {typ= fld_typ}) + when Exp.equal lhs_exp matching_exp -> + get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds + | _ -> + None) sigma | _ -> None ) @@ -853,16 +842,15 @@ let add_guarded_by_constraints tenv prop lexp pdesc = in List.find_map ~f:(fun hpred -> - match[@warning "-57"] (* FIXME: silenced warning may be legit *) hpred with + (* FIXME: silenced warning may be legit *) + match[@warning "-57"] hpred with | Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof {typ}) | Sil.Hpointsto (_, Sil.Eexp ((Const (Cclass clazz) as lhs_exp), _), Exp.Sizeof {typ}) when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) -> Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ) | Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> ( - match - (* first, try to find a field that exactly matches the guarded-by string *) - get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds - with + (* first, try to find a field that exactly matches the guarded-by string *) + match get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with | None when guarded_by_str_is_this guarded_by_str0 -> (* if the guarded-by string is "OuterClass.this", look for "this$n" for some n. note that this is a bit sketchy when there are mutliple this$n's, but there's @@ -894,7 +882,8 @@ let add_guarded_by_constraints tenv prop lexp pdesc = false in let is_synchronized_on_class guarded_by_str = - guarded_by_str_is_current_class guarded_by_str pname && Procdesc.is_java_synchronized pdesc + guarded_by_str_is_current_class guarded_by_str pname + && Procdesc.is_java_synchronized pdesc && match pname with | Typ.Procname.Java java_pname -> @@ -957,30 +946,31 @@ let add_guarded_by_constraints tenv prop lexp pdesc = let is_accessible_through_local_ref exp = List.exists ~f:(function - | Sil.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) -> - Exp.equal exp rhs_exp - | Sil.Hpointsto (_, Estruct (flds, _), _) -> - List.exists - ~f:(fun (fld, strexp) -> - match strexp with - | Sil.Eexp (rhs_exp, _) -> - Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld) - | _ -> - false ) - flds - | _ -> - false) + | Sil.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) -> + Exp.equal exp rhs_exp + | Sil.Hpointsto (_, Estruct (flds, _), _) -> + List.exists + ~f:(fun (fld, strexp) -> + match strexp with + | Sil.Eexp (rhs_exp, _) -> + Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld) + | _ -> + false ) + flds + | _ -> + false) prop.Prop.sigma in Procdesc.get_access pdesc <> PredSymb.Private - && not (Annotations.pdesc_return_annot_ends_with pdesc Annotations.visibleForTesting) - && not - ( match Procdesc.get_proc_name pdesc with - | Typ.Procname.Java java_pname -> - Typ.Procname.Java.is_access_method java_pname - | _ -> - false ) - && not (is_accessible_through_local_ref lexp) && not guardedby_is_self_referential + && (not (Annotations.pdesc_return_annot_ends_with pdesc Annotations.visibleForTesting)) + && (not + ( match Procdesc.get_proc_name pdesc with + | Typ.Procname.Java java_pname -> + Typ.Procname.Java.is_access_method java_pname + | _ -> + false )) + && (not (is_accessible_through_local_ref lexp)) + && (not guardedby_is_self_referential) && not (proc_has_suppress_guarded_by_annot pdesc) in match find_guarded_by_exp guarded_by_str prop.Prop.sigma with @@ -1002,9 +992,9 @@ let add_guarded_by_constraints tenv prop lexp pdesc = Attribute.add tenv ~footprint:true prop Alocked [guarded_by_exp] | _ -> if - not - ( proc_has_matching_annot pdesc guarded_by_str - || is_synchronized_on_class guarded_by_str ) + (not + ( proc_has_matching_annot pdesc guarded_by_str + || is_synchronized_on_class guarded_by_str )) && should_warn pdesc then (* can't find the object the annotation refers to, and procedure is not annotated. warn *) @@ -1304,7 +1294,7 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p (** find the type at the offset from the given type expression, if any *) let type_at_offset tenv texp off = - let rec strip_offset (off: Sil.offset list) (typ: Typ.t) = + let rec strip_offset (off : Sil.offset list) (typ : Typ.t) = match (off, typ.desc) with | [], _ -> Some typ @@ -1365,8 +1355,8 @@ let check_type_size tenv pname prop texp off typ_from_instr = * only after unrolling some predicates in prop. This function ensures * that the theorem prover cannot prove the inconsistency of any of the * new iters in the result. *) -let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst - : Sil.offset list Prop.prop_iter list = +let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst : + Sil.offset list Prop.prop_iter list = let rec root_typ_of_offsets = function | Sil.Off_fld (f, fld_typ) :: _ -> ( match fld_typ.desc with @@ -1409,10 +1399,10 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst Prop.d_prop (Prop.prop_iter_to_prop tenv iter) ; L.d_ln () ; L.d_ln () ) ; - let default_case_iter (iter': unit Prop.prop_iter) = + let default_case_iter (iter' : unit Prop.prop_iter) = if Config.trace_rearrange then L.d_strln "entering default_case_iter" ; if !Config.footprint then prop_iter_add_hpred_footprint pname tenv prop iter' (lexp, typ) inst - else if Config.array_level >= 1 && not !Config.footprint && Exp.pointer_arith lexp then + else if Config.array_level >= 1 && (not !Config.footprint) && Exp.pointer_arith lexp then rearrange_arith tenv lexp prop else ( pp_rearrangement_error "cannot find predicate with root" prop lexp ; @@ -1438,19 +1428,19 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst let filter = function | Sil.Hpointsto (base, _, _) | Sil.Hlseg (_, _, base, _, _) -> Prover.is_root tenv prop base lexp - | Sil.Hdllseg (_, _, first, _, _, last, _) -> + | Sil.Hdllseg (_, _, first, _, _, last, _) -> ( let result_first = Prover.is_root tenv prop first lexp in match result_first with | None -> Prover.is_root tenv prop last lexp | Some _ -> - result_first + result_first ) in let res = match Prop.prop_iter_find iter filter with | None -> [default_case_iter iter] - | Some iter -> + | Some iter -> ( match Prop.prop_iter_current tenv iter with | Sil.Hpointsto (_, _, texp), off -> if Config.type_size then check_type_size tenv pname prop texp off typ_from_instr ; @@ -1467,7 +1457,7 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist | _, Some _ -> iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist ) - | Sil.Hdllseg (Sil.Lseg_PE, para_dll, e1, e2, e3, e4, elist), _ -> + | Sil.Hdllseg (Sil.Lseg_PE, para_dll, e1, e2, e3, e4, elist), _ -> ( match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with | None, None -> assert false @@ -1476,7 +1466,7 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst e2 e3 e4 elist | _, Some _ -> iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter para_dll e1 - e2 e3 e4 elist + e2 e3 e4 elist ) ) in if Config.trace_rearrange then ( L.d_strln "exiting iter_rearrange, returning results" ; @@ -1503,7 +1493,7 @@ let is_weak_captured_var pdesc var_name = false -let var_has_annotation ?(check_weak_captured_var= false) pdesc is_annotation pvar = +let var_has_annotation ?(check_weak_captured_var = false) pdesc is_annotation pvar = let is_weak_captured_var = is_weak_captured_var pdesc (Pvar.to_string pvar) in let ann_sig = Models.get_modelled_annotated_signature (Procdesc.get_attributes pdesc) in AnnotatedSignature.param_has_annot is_annotation pvar ann_sig @@ -1544,7 +1534,7 @@ let is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp (fld, s (* This returns true if the exp is pointed to only by fields or parameters with a given annotation. In that case it also returns a string representation of the annotation recipient. *) -let is_only_pt_by_fld_or_param_with_annot ?(check_weak_captured_var= false) pdesc tenv prop +let is_only_pt_by_fld_or_param_with_annot ?(check_weak_captured_var = false) pdesc tenv prop deref_exp is_annotation = let obj_str = ref None in let is_pt_by_fld_or_param_with_annot hpred = @@ -1580,7 +1570,7 @@ let is_only_pt_by_fld_or_param_nonnull pdesc tenv prop deref_exp = (** Check for dereference errors: dereferencing 0, a freed value, or an undefined value *) -let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = +let check_dereference_error tenv pdesc (prop : Prop.normal Prop.t) lexp loc = let pname = Procdesc.get_proc_name pdesc in let root = Exp.root_of_lexp lexp in let nullable_var_opt = is_only_pt_by_fld_or_param_nullable pdesc tenv prop root in @@ -1594,8 +1584,8 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = let rec fold_getters = function | [] -> None - | getter :: tl -> - match getter prop exp with Some _ as some_attr -> some_attr | None -> fold_getters tl + | getter :: tl -> ( + match getter prop exp with Some _ as some_attr -> some_attr | None -> fold_getters tl ) in fold_getters relevant_attributes_getters in @@ -1615,28 +1605,28 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = get_relevant_attributes root_no_offset in ( if Prover.check_zero tenv (Exp.root_of_lexp root) || is_deref_of_nullable then - let deref_str = - if is_deref_of_nullable then - match nullable_var_opt with - | Some str -> - if is_weak_captured_var pdesc str then - Localise.deref_str_weak_variable_in_block None str - else Localise.deref_str_nullable None str - | None -> - Localise.deref_str_nullable None "" - else Localise.deref_str_null None - in - let err_desc = - Errdesc.explain_dereference pname tenv ~use_buckets:true ~is_nullable:is_deref_of_nullable - deref_str prop loc - in - if Localise.is_parameter_not_null_checked_desc err_desc then - raise (Exceptions.Parameter_not_null_checked (err_desc, __POS__)) - else if Localise.is_field_not_null_checked_desc err_desc then - raise (Exceptions.Field_not_null_checked (err_desc, __POS__)) - else if Localise.is_empty_vector_access_desc err_desc then - raise (Exceptions.Empty_vector_access (err_desc, __POS__)) - else raise (Exceptions.Null_dereference (err_desc, __POS__)) ) ; + let deref_str = + if is_deref_of_nullable then + match nullable_var_opt with + | Some str -> + if is_weak_captured_var pdesc str then + Localise.deref_str_weak_variable_in_block None str + else Localise.deref_str_nullable None str + | None -> + Localise.deref_str_nullable None "" + else Localise.deref_str_null None + in + let err_desc = + Errdesc.explain_dereference pname tenv ~use_buckets:true ~is_nullable:is_deref_of_nullable + deref_str prop loc + in + if Localise.is_parameter_not_null_checked_desc err_desc then + raise (Exceptions.Parameter_not_null_checked (err_desc, __POS__)) + else if Localise.is_field_not_null_checked_desc err_desc then + raise (Exceptions.Field_not_null_checked (err_desc, __POS__)) + else if Localise.is_empty_vector_access_desc err_desc then + raise (Exceptions.Empty_vector_access (err_desc, __POS__)) + else raise (Exceptions.Null_dereference (err_desc, __POS__)) ) ; match attribute_opt with | Some (Apred (Adangling dk, _)) -> let deref_str = Localise.deref_str_dangling (Some dk) in @@ -1660,8 +1650,7 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = let pname = Procdesc.get_proc_name pdesc in let is_this = function - | Exp.Lvar pvar - -> ( + | Exp.Lvar pvar -> ( let {ProcAttributes.clang_method_kind} = Procdesc.get_attributes pdesc in match clang_method_kind with | ClangMethodKind.OBJC_INSTANCE -> @@ -1726,8 +1715,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = Errdesc.explain_dereference pname tenv ~is_nullable:true deref_str prop loc in match fun_exp with - | Exp.Var id when Ident.is_footprint id - -> ( + | Exp.Var id when Ident.is_footprint id -> ( let e_opt, is_field_deref = is_field_deref () in let warn err_desc = let err_desc = Localise.error_desc_set_bucket err_desc Localise.BucketLevel.b1 in @@ -1752,8 +1740,8 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = (** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. It returns an iterator with [lexp |-> strexp: typ] as current predicate and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) -let rearrange ?(report_deref_errors= true) pdesc tenv lexp typ prop loc - : Sil.offset list Prop.prop_iter list = +let rearrange ?(report_deref_errors = true) pdesc tenv lexp typ prop loc : + Sil.offset list Prop.prop_iter list = let nlexp = match Prop.exp_normalize_prop tenv prop lexp with | Exp.BinOp (Binop.PlusPI, ep, e) -> diff --git a/infer/src/biabduction/Rearrange.mli b/infer/src/biabduction/Rearrange.mli index 137882558..930a2072b 100644 --- a/infer/src/biabduction/Rearrange.mli +++ b/infer/src/biabduction/Rearrange.mli @@ -27,8 +27,14 @@ val check_call_to_objc_block_error : It's used to check that we don't call possibly null blocks *) val rearrange : - ?report_deref_errors:bool -> Procdesc.t -> Tenv.t -> Exp.t -> Typ.t -> Prop.normal Prop.t - -> Location.t -> Sil.offset list Prop.prop_iter list + ?report_deref_errors:bool + -> Procdesc.t + -> Tenv.t + -> Exp.t + -> Typ.t + -> Prop.normal Prop.t + -> Location.t + -> Sil.offset list Prop.prop_iter list (** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. It returns an iterator with [lexp |-> strexp: typ] as current predicate and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) diff --git a/infer/src/biabduction/RetainCycles.ml b/infer/src/biabduction/RetainCycles.ml index f9bf8d3f2..9cf4e066b 100644 --- a/infer/src/biabduction/RetainCycles.ml +++ b/infer/src/biabduction/RetainCycles.ml @@ -7,7 +7,7 @@ open! IStd module MF = MarkupFormatter -let desc_retain_cycle tenv (cycle: RetainCyclesType.t) = +let desc_retain_cycle tenv (cycle : RetainCyclesType.t) = let open RetainCyclesType in Logging.d_strln "Proposition with retain cycle:" ; let do_edge index_ edge = @@ -20,8 +20,7 @@ let desc_retain_cycle tenv (cycle: RetainCyclesType.t) = else MF.monospaced_to_string (Format.sprintf "%s*" typ_str) in match Errdesc.find_outermost_dereference tenv node edge_obj.rc_from.rc_node_exp with - | Some de - -> ( + | Some de -> ( let decomp = DecompiledExp.to_string de in match de with | DecompiledExp.Dretcall _ -> @@ -59,7 +58,7 @@ let desc_retain_cycle tenv (cycle: RetainCyclesType.t) = let edge_is_strong tenv obj_edge = let open RetainCyclesType in (* returns items annotation for field fn in struct t *) - let get_item_annotation (t: Typ.t) fn = + let get_item_annotation (t : Typ.t) fn = match t.desc with | Tstruct name -> ( match Tenv.lookup tenv name with @@ -77,8 +76,8 @@ let edge_is_strong tenv obj_edge = let has_weak_or_unretained_or_assign params = List.exists ~f:(fun att -> - String.equal Config.unsafe_unret att || String.equal Config.weak att - || String.equal Config.assign att ) + String.equal Config.unsafe_unret att + || String.equal Config.weak att || String.equal Config.assign att ) params in let weak_edge_by_type = @@ -92,7 +91,7 @@ let edge_is_strong tenv obj_edge = match get_item_annotation obj_edge.rc_from.rc_node_typ obj_edge.rc_field.rc_field_name with | Some ia -> List.exists - ~f:(fun ((ann: Annot.t), _) -> + ~f:(fun ((ann : Annot.t), _) -> ( String.equal ann.class_name Config.property_attributes || String.equal ann.class_name Config.ivar_attributes ) && has_weak_or_unretained_or_assign ann.parameters ) @@ -205,7 +204,8 @@ let get_cycles found_cycles root tenv prop = found_cycles in match root with - | Sil.Hpointsto (e_root, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) when Sil.is_objc_object root -> + | Sil.Hpointsto (e_root, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) when Sil.is_objc_object root + -> let se_root = {rc_node_exp= e_root; rc_node_typ= te} in (* start dfs with empty path and expr pointing to root *) dfs ~found_cycles ~root_node:se_root ~from_node:se_root ~rev_path:[] ~fields:fl ~visited:[] diff --git a/infer/src/biabduction/RetainCyclesType.ml b/infer/src/biabduction/RetainCyclesType.ml index 45cb9680e..844b58061 100644 --- a/infer/src/biabduction/RetainCyclesType.ml +++ b/infer/src/biabduction/RetainCyclesType.ml @@ -16,22 +16,22 @@ type retain_cycle_edge = Object of retain_cycle_edge_obj | Block of Typ.Procname type t = {rc_head: retain_cycle_edge; rc_elements: retain_cycle_edge list} -let compare_retain_cycle_node (node1: retain_cycle_node) (node2: retain_cycle_node) = +let compare_retain_cycle_node (node1 : retain_cycle_node) (node2 : retain_cycle_node) = Typ.compare node1.rc_node_typ node2.rc_node_typ -let compare_retain_cycle_field (node1: retain_cycle_field) (node2: retain_cycle_field) = +let compare_retain_cycle_field (node1 : retain_cycle_field) (node2 : retain_cycle_field) = Typ.Fieldname.compare node1.rc_field_name node2.rc_field_name -let compare_retain_cycle_edge_obj (obj1: retain_cycle_edge_obj) (obj2: retain_cycle_edge_obj) = +let compare_retain_cycle_edge_obj (obj1 : retain_cycle_edge_obj) (obj2 : retain_cycle_edge_obj) = let obj1_pair = Tuple.T2.create obj1.rc_from obj1.rc_field in let obj2_pair = Tuple.T2.create obj2.rc_from obj2.rc_field in Tuple.T2.compare ~cmp1:compare_retain_cycle_node ~cmp2:compare_retain_cycle_field obj1_pair obj2_pair -let compare_retain_cycle_edge (edge1: retain_cycle_edge) (edge2: retain_cycle_edge) = +let compare_retain_cycle_edge (edge1 : retain_cycle_edge) (edge2 : retain_cycle_edge) = match (edge1, edge2) with | Object edge_obj1, Object edge_obj2 -> compare_retain_cycle_edge_obj edge_obj1 edge_obj2 @@ -43,9 +43,9 @@ let compare_retain_cycle_edge (edge1: retain_cycle_edge) (edge2: retain_cycle_ed -1 -let equal_retain_cycle_edge = [%compare.equal : retain_cycle_edge] +let equal_retain_cycle_edge = [%compare.equal: retain_cycle_edge] -let compare (rc1: t) (rc2: t) = +let compare (rc1 : t) (rc2 : t) = List.compare compare_retain_cycle_edge rc1.rc_elements rc2.rc_elements @@ -94,17 +94,17 @@ let is_exp_null node = match node with Object obj -> Exp.is_null_literal obj.rc_from.rc_node_exp | Block _ -> false -let retain_cycle_node_to_string (node: retain_cycle_node) = +let retain_cycle_node_to_string (node : retain_cycle_node) = Format.sprintf "%s : %s" (Exp.to_string node.rc_node_exp) (Typ.to_string node.rc_node_typ) -let retain_cycle_field_to_string (field: retain_cycle_field) = +let retain_cycle_field_to_string (field : retain_cycle_field) = Format.sprintf "%s[%s]" (Typ.Fieldname.to_string field.rc_field_name) (Sil.inst_to_string field.rc_field_inst) -let retain_cycle_edge_to_string (edge: retain_cycle_edge) = +let retain_cycle_edge_to_string (edge : retain_cycle_edge) = match edge with | Object obj -> Format.sprintf "%s ->{%s}" diff --git a/infer/src/biabduction/State.ml b/infer/src/biabduction/State.ml index e26182554..84ed14ffa 100644 --- a/infer/src/biabduction/State.ml +++ b/infer/src/biabduction/State.ml @@ -102,10 +102,7 @@ let instrs_normalize instrs = in let subst = let count = ref Int.min_value in - let gensym id = - incr count ; - Ident.set_stamp id !count - in + let gensym id = incr count ; Ident.set_stamp id !count in Sil.subst_of_list (List.rev_map ~f:(fun id -> (id, Exp.Var (gensym id))) bound_ids) in let subst_and_add acc instr = Sil.instr_sub subst instr :: acc in @@ -191,7 +188,9 @@ let extract_pre p tenv pdesc abstract_fun = let count = ref 0 in Sil.subst_of_list (List.map - ~f:(fun id -> incr count ; (id, Exp.Var (Ident.create_normal Ident.name_spec !count))) + ~f:(fun id -> + incr count ; + (id, Exp.Var (Ident.create_normal Ident.name_spec !count)) ) idlist) in let _, p' = PropUtil.remove_locals_formals tenv pdesc p in @@ -202,8 +201,8 @@ let extract_pre p tenv pdesc abstract_fun = (** return the normalized precondition extracted form the last prop seen, if any the abstraction function is a parameter to get around module dependencies *) -let get_normalized_pre (abstract_fun: Tenv.t -> Prop.normal Prop.t -> Prop.normal Prop.t) - : Prop.normal Prop.t option = +let get_normalized_pre (abstract_fun : Tenv.t -> Prop.normal Prop.t -> Prop.normal Prop.t) : + Prop.normal Prop.t option = match get_prop_tenv_pdesc () with | None -> None @@ -256,11 +255,18 @@ let mark_instr_fail exn = type log_issue = - Typ.Procname.t -> ?node:Procdesc.Node.t -> ?loc:Location.t -> ?ltr:Errlog.loc_trace - -> ?linters_def_file:string -> ?doc_url:string -> ?access:string -> ?extras:Jsonbug_t.extra - -> exn -> unit - -let process_execution_failures (log_issue: log_issue) pname = + Typ.Procname.t + -> ?node:Procdesc.Node.t + -> ?loc:Location.t + -> ?ltr:Errlog.loc_trace + -> ?linters_def_file:string + -> ?doc_url:string + -> ?access:string + -> ?extras:Jsonbug_t.extra + -> exn + -> unit + +let process_execution_failures (log_issue : log_issue) pname = let do_failure _ fs = (* L.out "Node:%a node_ok:%d node_fail:%d@." Procdesc.Node.pp node fs.node_ok fs.node_fail; *) match (fs.node_ok, fs.first_failure) with @@ -275,15 +281,15 @@ let process_execution_failures (log_issue: log_issue) pname = NodeHash.iter do_failure !gs.failure_map -let set_instr (instr: Sil.instr) = !gs.last_instr <- Some instr +let set_instr (instr : Sil.instr) = !gs.last_instr <- Some instr let set_path path pos_opt = !gs.last_path <- Some (path, pos_opt) let set_prop_tenv_pdesc prop tenv pdesc = !gs.last_prop_tenv_pdesc <- Some (prop, tenv, pdesc) -let set_node (node: Procdesc.Node.t) = +let set_node (node : Procdesc.Node.t) = !gs.last_instr <- None ; !gs.last_node <- node -let set_session (session: int) = !gs.last_session <- session +let set_session (session : int) = !gs.last_session <- session diff --git a/infer/src/biabduction/State.mli b/infer/src/biabduction/State.mli index afa5f1e0a..36e816635 100644 --- a/infer/src/biabduction/State.mli +++ b/infer/src/biabduction/State.mli @@ -72,9 +72,16 @@ val mk_find_duplicate_nodes : Procdesc.t -> Procdesc.Node.t -> Procdesc.NodeSet. and normalized (w.r.t. renaming of let - bound ids) list of instructions. *) type log_issue = - Typ.Procname.t -> ?node:Procdesc.Node.t -> ?loc:Location.t -> ?ltr:Errlog.loc_trace - -> ?linters_def_file:string -> ?doc_url:string -> ?access:string -> ?extras:Jsonbug_t.extra - -> exn -> unit + Typ.Procname.t + -> ?node:Procdesc.Node.t + -> ?loc:Location.t + -> ?ltr:Errlog.loc_trace + -> ?linters_def_file:string + -> ?doc_url:string + -> ?access:string + -> ?extras:Jsonbug_t.extra + -> exn + -> unit val process_execution_failures : log_issue -> Typ.Procname.t -> unit (** Process the failures during symbolic execution of a procedure *) diff --git a/infer/src/biabduction/SymExec.ml b/infer/src/biabduction/SymExec.ml index 4e694ce4c..09f09ae1d 100644 --- a/infer/src/biabduction/SymExec.ml +++ b/infer/src/biabduction/SymExec.ml @@ -20,7 +20,7 @@ let rec fldlist_assoc fld = function if Typ.Fieldname.equal fld fld' then x else fldlist_assoc fld l -let unroll_type tenv (typ: Typ.t) (off: Sil.offset) = +let unroll_type tenv (typ : Typ.t) (off : Sil.offset) = let fail fld_to_string fld = L.d_strln ".... Invalid Field Access ...." ; L.d_str ("Fld : " ^ fld_to_string fld) ; @@ -61,7 +61,7 @@ let unroll_type tenv (typ: Typ.t) (off: Sil.offset) = this function. If the tool follows this protocol, it will never hit the assert false cases for field and array accesses. *) let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist - (f: Exp.t option -> Exp.t) inst lookup_inst = + (f : Exp.t option -> Exp.t) inst lookup_inst = let pp_error () = L.d_strln ".... Invalid Field ...." ; L.d_str "strexp : " ; @@ -109,8 +109,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty lookup_inst | Sil.Off_fld (fld, fld_typ) :: offlist', Sil.Estruct (fsel, inst'), Typ.Tstruct name -> ( match Tenv.lookup tenv name with - | Some ({fields} as struct_typ) - -> ( + | Some ({fields} as struct_typ) -> ( let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in match List.find ~f:(fun fse -> Typ.Fieldname.equal fld (fst fse)) fsel with | Some (_, se') -> @@ -141,8 +140,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty assert false | ( Sil.Off_index idx :: offlist' , Sil.Earray (len, esel, inst1) - , Typ.Tarray {elt= t'; length= len'; stride= stride'} ) - -> ( + , Typ.Tarray {elt= t'; length= len'; stride= stride'} ) -> ( let nidx = Prop.exp_normalize_prop tenv p idx in match List.find ~f:(fun ese -> Prover.check_equal tenv p nidx (fst ese)) esel with | Some (idx_ese', se') -> @@ -260,7 +258,8 @@ let prune_ne tenv ~positive e1 e2 prop = *) let prune_ineq tenv ~is_strict ~positive prop e1 e2 = if Exp.equal e1 e2 then - if (positive && not is_strict) || (not positive && is_strict) then Propset.singleton tenv prop + if (positive && not is_strict) || ((not positive) && is_strict) then + Propset.singleton tenv prop else Propset.empty else (* build the pruning condition and its negation, as explained in @@ -299,15 +298,19 @@ let rec prune tenv ~positive condition prop = prune tenv ~positive:(not positive) condition' prop | Exp.UnOp _ -> assert false - | Exp.BinOp (Binop.Eq, e, Exp.Const (Const.Cint i)) when IntLit.iszero i && not (IntLit.isnull i) -> + | Exp.BinOp (Binop.Eq, e, Exp.Const (Const.Cint i)) when IntLit.iszero i && not (IntLit.isnull i) + -> prune tenv ~positive:(not positive) e prop - | Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), e) when IntLit.iszero i && not (IntLit.isnull i) -> + | Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), e) when IntLit.iszero i && not (IntLit.isnull i) + -> prune tenv ~positive:(not positive) e prop | Exp.BinOp (Binop.Eq, e1, e2) -> prune_ne tenv ~positive:(not positive) e1 e2 prop - | Exp.BinOp (Binop.Ne, e, Exp.Const (Const.Cint i)) when IntLit.iszero i && not (IntLit.isnull i) -> + | Exp.BinOp (Binop.Ne, e, Exp.Const (Const.Cint i)) when IntLit.iszero i && not (IntLit.isnull i) + -> prune tenv ~positive e prop - | Exp.BinOp (Binop.Ne, Exp.Const (Const.Cint i), e) when IntLit.iszero i && not (IntLit.isnull i) -> + | Exp.BinOp (Binop.Ne, Exp.Const (Const.Cint i), e) when IntLit.iszero i && not (IntLit.isnull i) + -> prune tenv ~positive e prop | Exp.BinOp (Binop.Ne, e1, e2) -> prune_ne tenv ~positive e1 e2 prop @@ -392,7 +395,8 @@ let check_constant_string_dereference lexp = Exp.int (IntLit.of_int c) in match lexp with - | Exp.BinOp (Binop.PlusPI, Exp.Const (Const.Cstr s), e) | Exp.Lindex (Exp.Const (Const.Cstr s), e) -> + | Exp.BinOp (Binop.PlusPI, Exp.Const (Const.Cstr s), e) | Exp.Lindex (Exp.Const (Const.Cstr s), e) + -> let value = match e with | Exp.Const (Const.Cint n) @@ -521,12 +525,11 @@ let method_exists right_proc_name methods = let resolve_method tenv class_name proc_name = let found_class = let visited = ref Typ.Name.Set.empty in - let rec resolve (class_name: Typ.Name.t) = + let rec resolve (class_name : Typ.Name.t) = visited := Typ.Name.Set.add class_name !visited ; let right_proc_name = Typ.Procname.replace_class proc_name class_name in match Tenv.lookup tenv class_name with - | Some {methods; supers} when Typ.Name.is_class class_name - -> ( + | Some {methods; supers} when Typ.Name.is_class class_name -> ( if method_exists right_proc_name methods then Some right_proc_name else match supers with @@ -575,8 +578,7 @@ let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Typ.Procna in let get_receiver_typ pname fallback_typ = match pname with - | Typ.Procname.Java pname_java - -> ( + | Typ.Procname.Java pname_java -> ( let name = Typ.Procname.Java.get_class_type_name pname_java in match Tenv.lookup tenv name with | Some _ -> @@ -600,8 +602,7 @@ let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Typ.Procna | _ when not (call_flags.CallFlags.cf_virtual || call_flags.CallFlags.cf_interface) -> (* if this is not a virtual or interface call, there's no need for resolution *) [callee_pname] - | (receiver_exp, actual_receiver_typ) :: _ - -> ( + | (receiver_exp, actual_receiver_typ) :: _ -> ( if !Language.curr_language <> Language.Java then (* default mode for Obj-C/C++/Java virtual calls: resolution only *) [do_resolve callee_pname receiver_exp actual_receiver_typ] @@ -665,7 +666,8 @@ let resolve_pname ~caller_pdesc tenv prop args pname call_flags : Typ.Procname.t in (resolved, other_args) | _ :: other_args - when match_parameters other_args (* Non-virtual call, e.g. constructors or private methods *) -> + when match_parameters other_args (* Non-virtual call, e.g. constructors or private methods *) + -> (pname, other_args) | args when match_parameters args (* Static call *) -> (pname, args) @@ -706,7 +708,7 @@ type resolve_and_analyze_result = (** Resolve the procedure name and run the analysis of the resolved procedure if not already analyzed *) -let resolve_and_analyze tenv ~caller_pdesc ?(has_clang_model= false) prop args callee_proc_name +let resolve_and_analyze tenv ~caller_pdesc ?(has_clang_model = false) prop args callee_proc_name call_flags : resolve_and_analyze_result = (* TODO (#15748878): Fix conflict with method overloading by encoding in the procedure name whether the method is defined or generated by the specialization *) @@ -748,12 +750,13 @@ let call_constructor_url_update_args pname actual_params = Typ.Procname.Java (Typ.Procname.Java.make (Typ.Name.Java.from_string "java.net.URL") - None "" [Typ.Name.Java.Split.java_lang_string] Typ.Procname.Java.Non_Static) + None "" + [Typ.Name.Java.Split.java_lang_string] + Typ.Procname.Java.Non_Static) in if Typ.Procname.equal url_pname pname then match actual_params with - | [this; (Exp.Const (Const.Cstr s), atype)] - -> ( + | [this; (Exp.Const (Const.Cstr s), atype)] -> ( let parts = Str.split (Str.regexp_string "://") s in match parts with | frst :: _ -> @@ -790,7 +793,8 @@ let receiver_self receiver prop = let force_objc_init_return_nil pdesc callee_pname tenv ret_id pre path receiver = let current_pname = Procdesc.get_proc_name pdesc in if - Typ.Procname.is_constructor callee_pname && receiver_self receiver pre && !Config.footprint + Typ.Procname.is_constructor callee_pname + && receiver_self receiver pre && !Config.footprint && Typ.Procname.is_constructor current_pname then let propset = prune_ne tenv ~positive:false (Exp.Var ret_id) Exp.zero pre in @@ -825,7 +829,8 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ in let is_receiver_null = match actual_pars with - | (e, _) :: _ when Exp.equal e Exp.zero || Option.is_some (Attribute.get_objc_null tenv pre e) -> + | (e, _) :: _ when Exp.equal e Exp.zero || Option.is_some (Attribute.get_objc_null tenv pre e) + -> true | _ -> false @@ -852,7 +857,8 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ match force_objc_init_return_nil pdesc callee_pname tenv ret_id pre path receiver with | [] -> if - !Config.footprint && Option.is_none (Attribute.get_undef tenv pre receiver) + !Config.footprint + && Option.is_none (Attribute.get_undef tenv pre receiver) && not (Rearrange.is_only_pt_by_fld_or_param_nonnull pdesc tenv pre receiver) then let res_null = @@ -866,8 +872,7 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ [(prop, path)] in List.append res_null (res ()) - else res () - (* Not known if receiver = 0 and not footprint. Standard tabulation *) + else res () (* Not known if receiver = 0 and not footprint. Standard tabulation *) | res_null -> List.append res_null (res ()) @@ -978,13 +983,12 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal else add_ret_non_null ret_exp typ prop -let execute_load ?(report_deref_errors= true) pname pdesc tenv id rhs_exp typ loc prop_ = +let execute_load ?(report_deref_errors = true) pname pdesc tenv id rhs_exp typ loc prop_ = let execute_load_ acc_in iter = let iter_ren = Prop.prop_iter_make_id_primed tenv id iter in let prop_ren = Prop.prop_iter_to_prop tenv iter_ren in match Prop.prop_iter_current tenv iter_ren with - | Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof_data), offlist - -> ( + | Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof_data), offlist -> ( let contents, new_ptsto, pred_insts_op, lookup_uninitialized = ptsto_lookup pdesc tenv prop_ren (lexp, strexp, sizeof_data) offlist id in @@ -1029,7 +1033,7 @@ let execute_load ?(report_deref_errors= true) pname pdesc tenv id rhs_exp typ lo match check_constant_string_dereference n_rhs_exp' with | Some value -> [Prop.conjoin_eq tenv (Exp.Var id) value prop] - | None -> + | None -> ( try let iter_list = Rearrange.rearrange ~report_deref_errors pdesc tenv n_rhs_exp' typ prop loc @@ -1039,7 +1043,7 @@ let execute_load ?(report_deref_errors= true) pname pdesc tenv id rhs_exp typ lo (* This should normally be a real alarm and should not be caught but currently happens when the normalization drops hpreds of the form ident |-> footprint var. *) let undef = Exp.get_undefined !Config.footprint in - [Prop.conjoin_eq tenv (Exp.Var id) undef prop] + [Prop.conjoin_eq tenv (Exp.Var id) undef prop] ) with Rearrange.ARRAY_ACCESS -> if Int.equal Config.array_level 0 then assert false else @@ -1056,7 +1060,7 @@ let load_ret_annots pname = Annot.Item.empty -let execute_store ?(report_deref_errors= true) pname pdesc tenv lhs_exp typ rhs_exp loc prop_ = +let execute_store ?(report_deref_errors = true) pname pdesc tenv lhs_exp typ rhs_exp loc prop_ = let execute_store_ pdesc tenv rhs_exp acc_in iter = let lexp, strexp, sizeof, offlist = match Prop.prop_iter_current tenv iter with @@ -1121,7 +1125,8 @@ let resolve_and_analyze_no_dynamic_dispatch current_pdesc tenv prop_r n_actual_p let resolve_and_analyze_clang current_pdesc tenv prop_r n_actual_params callee_pname call_flags = if - Config.dynamic_dispatch && not (is_variadic_procname callee_pname) + Config.dynamic_dispatch + && (not (is_variadic_procname callee_pname)) && Typ.Procname.is_objc_method callee_pname || Typ.Procname.is_objc_block callee_pname (* to be extended to other methods *) @@ -1165,7 +1170,7 @@ let resolve_and_analyze_clang current_pdesc tenv prop_r n_actual_params callee_p call_flags -let declare_locals_and_ret tenv pdesc (prop_: Prop.normal Prop.t) = +let declare_locals_and_ret tenv pdesc (prop_ : Prop.normal Prop.t) = let sigma_locals_and_ret = let mk_ptsto pvar typ = let ptsto = @@ -1197,8 +1202,8 @@ let declare_locals_and_ret tenv pdesc (prop_: Prop.normal Prop.t) = (** Execute [instr] with a symbolic heap [prop].*) -let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) path - : (Prop.normal Prop.t * Paths.Path.t) list = +let rec sym_exec exe_env tenv current_pdesc instr_ (prop_ : Prop.normal Prop.t) path : + (Prop.normal Prop.t * Paths.Path.t) list = let current_pname = Procdesc.get_proc_name current_pdesc in State.set_instr instr_ ; (* mark instruction last seen *) @@ -1228,7 +1233,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p | _ -> instr_ in - let skip_call ?(is_objc_instance_method= false) ?(callee_attributes= None) ~reason prop path + let skip_call ?(is_objc_instance_method = false) ?(callee_attributes = None) ~reason prop path callee_pname ret_annots loc ret_id_typ ret_typ actual_args = let skip_res () = let exn = Exceptions.Skip_function (Localise.desc_skip_function callee_pname) in @@ -1312,10 +1317,9 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p match Builtin.get callee_pname with | Some exec_builtin -> exec_builtin (call_args prop_ callee_pname actual_params ret_id_typ loc) - | None -> + | None -> ( match callee_pname with - | Java callee_pname_java when Config.dynamic_dispatch - -> ( + | Java callee_pname_java when Config.dynamic_dispatch -> ( let norm_prop, norm_args' = normalize_params tenv current_pname prop_ actual_params in let norm_args = call_constructor_url_update_args callee_pname norm_args' in let exec_skip_call ~reason skipped_pname ret_annots ret_type = @@ -1332,7 +1336,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p let ret_typ = Typ.Procname.Java.get_return_typ callee_pname_java in let ret_annots = load_ret_annots callee_pname in exec_skip_call ~reason:"unknown method" resolved_pname ret_annots ret_typ - | Some resolved_summary -> + | Some resolved_summary -> ( match reason_to_skip ~callee_desc:(`Summary resolved_summary) with | None -> proc_call exe_env resolved_summary @@ -1341,7 +1345,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p let proc_attrs = Summary.get_attributes resolved_summary in let ret_annots, _ = proc_attrs.ProcAttributes.method_annotation in exec_skip_call ~reason resolved_pname ret_annots proc_attrs.ProcAttributes.ret_type - ) + ) ) | Java callee_pname_java -> let norm_prop, norm_args = normalize_params tenv current_pname prop_ actual_params in let url_handled_args = call_constructor_url_update_args callee_pname norm_args in @@ -1358,7 +1362,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p let ret_typ = Typ.Procname.Java.get_return_typ callee_pname_java in let ret_annots = load_ret_annots callee_pname in exec_skip_call ~reason:"unknown method" ret_annots ret_typ - | Some callee_summary -> + | Some callee_summary -> ( match reason_to_skip ~callee_desc:(`Summary callee_summary) with | None -> let handled_args = call_args norm_prop pname url_handled_args ret_id_typ loc in @@ -1366,10 +1370,10 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p | Some reason -> let proc_attrs = Summary.get_attributes callee_summary in let ret_annots, _ = proc_attrs.ProcAttributes.method_annotation in - exec_skip_call ~reason ret_annots proc_attrs.ProcAttributes.ret_type + exec_skip_call ~reason ret_annots proc_attrs.ProcAttributes.ret_type ) in List.fold ~f:(fun acc pname -> exec_one_pname pname @ acc) ~init:[] resolved_pnames - | _ -> + | _ -> ( (* Generic fun call with known name *) let prop_r, n_actual_params = normalize_params tenv current_pname prop_ actual_params in (* method with block parameters *) @@ -1416,8 +1420,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p `ProcName resolved_pname in match reason_to_skip ~callee_desc with - | Some reason - -> ( + | Some reason -> ( let ret_annots = match resolved_summary_opt with | Some summ -> @@ -1429,8 +1432,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p load_ret_annots resolved_pname in match resolved_pdesc_opt with - | Some resolved_pdesc - -> ( + | Some resolved_pdesc -> ( let attrs = Procdesc.get_attributes resolved_pdesc in let ret_type = attrs.ProcAttributes.ret_type in let model_as_malloc = @@ -1462,7 +1464,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p (Option.value_exn resolved_summary_opt) (call_args prop resolved_pname n_actual_params ret_id_typ loc) in - List.concat_map ~f:do_call sentinel_result ) + List.concat_map ~f:do_call sentinel_result ) ) ) | Sil.Call (ret_id_typ, fun_exp, actual_params, loc, call_flags) -> (* Call via function pointer *) let prop_r, n_actual_params = normalize_params tenv current_pname prop_ actual_params in @@ -1494,13 +1496,12 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p ; proc_name= callee_pname ; loc ; exe_env } ) - | Sil.Nullify (pvar, _) - -> ( + | Sil.Nullify (pvar, _) -> ( let eprop = Prop.expose prop_ in match List.partition_tf ~f:(function - | Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false) + | Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false) eprop.Prop.sigma with | [Sil.Hpointsto (e, se, typ)], sigma' -> @@ -1534,13 +1535,13 @@ and diverge prop path = (** Symbolic execution of a sequence of instructions. If errors occur and [mask_errors] is true, just treat as skip. *) -and instrs ?(mask_errors= false) exe_env tenv pdesc instrs ppl = +and instrs ?(mask_errors = false) exe_env tenv pdesc instrs ppl = let exe_instr instr (p, path) = L.d_str "Executing Generated Instruction " ; Sil.d_instr instr ; L.d_ln () ; try sym_exec exe_env tenv pdesc instr p path with exn -> - IExn.reraise_if exn ~f:(fun () -> not mask_errors || not (SymOp.exn_not_failure exn)) ; + IExn.reraise_if exn ~f:(fun () -> (not mask_errors) || not (SymOp.exn_not_failure exn)) ; let error = Exceptions.recognize_exception exn in let loc = match error.ocaml_pos with @@ -1558,7 +1559,8 @@ and instrs ?(mask_errors= false) exe_env tenv pdesc instrs ppl = Instrs.fold ~f ~init:ppl instrs -and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref callee_pname callee_loc = +and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref callee_pname callee_loc + = let add_actual_by_ref_to_footprint prop (actual, actual_typ, actual_index) = let abduced = match actual with @@ -1597,10 +1599,10 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call let filtered_sigma = List.map ~f:(function - | Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual -> - Sil.Hpointsto (lhs, abduced_strexp, typ_exp) - | hpred -> - hpred) + | Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual -> + Sil.Hpointsto (lhs, abduced_strexp, typ_exp) + | hpred -> + hpred) prop'.Prop.sigma in Prop.normalize tenv (Prop.set prop' ~sigma:filtered_sigma) @@ -1610,7 +1612,7 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call let filtered_sigma = List.filter ~f:(function - | Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true) + | Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual -> false | _ -> true) prop.Prop.sigma in Prop.normalize tenv (Prop.set prop ~sigma:filtered_sigma) @@ -1645,7 +1647,8 @@ and add_constraints_on_actuals_by_ref tenv caller_pdesc prop actuals_by_ref call (** execute a call for an unknown or scan function *) and unknown_or_scan_call ~is_scan ~reason ret_typ ret_annots - {Builtin.tenv; pdesc; prop_= pre; path; ret_id_typ; args; proc_name= callee_pname; loc; instr} = + {Builtin.tenv; pdesc; prop_= pre; path; ret_id_typ; args; proc_name= callee_pname; loc; instr} + = let remove_file_attribute prop = let do_exp p (e, _) = let do_attribute q atom = @@ -1691,7 +1694,8 @@ and unknown_or_scan_call ~is_scan ~reason ret_typ ret_annots match actual with | (Exp.Lvar _ as e), ({Typ.desc= Tptr _} as t) -> Some (e, t, i) - | (Exp.Var _ as e), ({Typ.desc= Tptr _} as t) when should_abduce_param_value callee_pname -> + | (Exp.Var _ as e), ({Typ.desc= Tptr _} as t) when should_abduce_param_value callee_pname + -> Some (e, t, i) | _ -> None ) @@ -1703,8 +1707,9 @@ and unknown_or_scan_call ~is_scan ~reason ret_typ ret_annots let pre_1 = if Typ.Procname.is_java callee_pname then remove_file_attribute pre else pre in let pre_2 = (* TODO(jjb): Should this use the type of ret_id, or ret_type from the procedure type? *) - add_constraints_on_retval tenv pdesc pre_1 (Exp.Var (fst ret_id_typ)) ret_typ - ~has_nonnull_annot callee_pname loc + add_constraints_on_retval tenv pdesc pre_1 + (Exp.Var (fst ret_id_typ)) + ret_typ ~has_nonnull_annot callee_pname loc in add_constraints_on_actuals_by_ref tenv pdesc pre_2 actuals_by_ref callee_pname loc in @@ -1728,7 +1733,7 @@ and unknown_or_scan_call ~is_scan ~reason ret_typ ret_annots [(prop_with_undef_attr, skip_path)] -and check_variadic_sentinel ?(fails_on_nil= false) n_formals (sentinel, null_pos) +and check_variadic_sentinel ?(fails_on_nil = false) n_formals (sentinel, null_pos) {Builtin.pdesc; tenv; prop_; path; args; proc_name; loc; exe_env} = (* from clang's lib/Sema/SemaExpr.cpp: *) (* "nullPos" is the number of formal parameters at the end which *) @@ -1767,7 +1772,7 @@ and check_variadic_sentinel_if_present ({Builtin.prop_; path; proc_name} as buil match Summary.proc_resolve_attributes proc_name with | None -> [(prop_, path)] - | Some callee_attributes -> + | Some callee_attributes -> ( match PredSymb.get_sentinel_func_attribute_value callee_attributes.ProcAttributes.func_attributes with @@ -1775,7 +1780,7 @@ and check_variadic_sentinel_if_present ({Builtin.prop_; path; proc_name} as buil [(prop_, path)] | Some sentinel_arg -> let formals = callee_attributes.ProcAttributes.formals in - check_variadic_sentinel (List.length formals) sentinel_arg builtin_args + check_variadic_sentinel (List.length formals) sentinel_arg builtin_args ) and sym_exec_objc_getter field ret_typ tenv ret_id pdesc pname loc args prop = @@ -1834,8 +1839,8 @@ and sym_exec_objc_accessor callee_pname property_accesor ret_typ tenv ret_id pde f_accessor ret_typ tenv ret_id pdesc cur_pname loc args prop |> List.map ~f:(fun p -> (p, path)) -and sym_exec_alloc_model exe_env pname ret_typ tenv ret_id_typ pdesc loc prop path - : Builtin.ret_typ = +and sym_exec_alloc_model exe_env pname ret_typ tenv ret_id_typ pdesc loc prop path : + Builtin.ret_typ = let alloc_source_function_arg = (Exp.Const (Const.Cfun pname), Typ.mk Tvoid) in let args = let sizeof_exp = @@ -1907,13 +1912,14 @@ and proc_call ?dynamic_dispatch exe_env callee_summary (** perform symbolic execution for a single prop, and check for junk *) and sym_exec_wrapper exe_env handle_exn tenv summary proc_cfg instr - ((prop: Prop.normal Prop.t), path) : Paths.PathSet.t = + ((prop : Prop.normal Prop.t), path) : Paths.PathSet.t = let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in let prop_primed_to_normal p = (* Rename primed vars with fresh normal vars, and return them *) let ids_primed = - Prop.free_vars p |> Sequence.filter ~f:Ident.is_primed |> Ident.hashqueue_of_sequence - |> Ident.HashQueue.keys + Prop.free_vars p + |> Sequence.filter ~f:Ident.is_primed + |> Ident.hashqueue_of_sequence |> Ident.HashQueue.keys in let ids_primed_normal = List.map ~f:(fun id -> (id, Ident.create_fresh Ident.knormal)) ids_primed @@ -1990,7 +1996,7 @@ and sym_exec_wrapper exe_env handle_exn tenv summary proc_cfg instr Paths.PathSet.from_renamed_list results with exn -> IExn.reraise_if exn ~f:(fun () -> - not !Config.footprint || not (Exceptions.handle_exception exn) ) ; + (not !Config.footprint) || not (Exceptions.handle_exception exn) ) ; handle_exn exn ; (* calls State.mark_instr_fail *) Paths.PathSet.empty @@ -1998,13 +2004,14 @@ and sym_exec_wrapper exe_env handle_exn tenv summary proc_cfg instr (** {2 Lifted Abstract Transfer Functions} *) -let node handle_exn exe_env tenv summary proc_cfg (node: ProcCfg.Exceptional.Node.t) - (pset: Paths.PathSet.t) : Paths.PathSet.t = +let node handle_exn exe_env tenv summary proc_cfg (node : ProcCfg.Exceptional.Node.t) + (pset : Paths.PathSet.t) : Paths.PathSet.t = let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in - let exe_instr_prop instr p tr (pset1: Paths.PathSet.t) = + let exe_instr_prop instr p tr (pset1 : Paths.PathSet.t) = let pset2 = if - Tabulation.prop_is_exn pname p && not (Sil.instr_is_auxiliary instr) + Tabulation.prop_is_exn pname p + && (not (Sil.instr_is_auxiliary instr)) && ProcCfg.Exceptional.Node.kind node <> Procdesc.Node.exn_handler_kind (* skip normal instructions if an exception was thrown, unless this is an exception handler node *) diff --git a/infer/src/biabduction/SymExec.mli b/infer/src/biabduction/SymExec.mli index 6aa2bd033..cb2ccf5e7 100644 --- a/infer/src/biabduction/SymExec.mli +++ b/infer/src/biabduction/SymExec.mli @@ -14,13 +14,24 @@ val declare_locals_and_ret : Tenv.t -> Procdesc.t -> Prop.normal Prop.t -> Prop. (** Symbolic execution of the declaration of locals and return value. *) val node : - (exn -> unit) -> Exe_env.t -> Tenv.t -> Summary.t -> ProcCfg.Exceptional.t - -> ProcCfg.Exceptional.Node.t -> Paths.PathSet.t -> Paths.PathSet.t + (exn -> unit) + -> Exe_env.t + -> Tenv.t + -> Summary.t + -> ProcCfg.Exceptional.t + -> ProcCfg.Exceptional.Node.t + -> Paths.PathSet.t + -> Paths.PathSet.t (** Symbolic execution of the instructions of a node, lifted to sets of propositions. *) val instrs : - ?mask_errors:bool -> Exe_env.t -> Tenv.t -> Procdesc.t -> Instrs.not_reversed_t - -> (Prop.normal Prop.t * Paths.Path.t) list -> (Prop.normal Prop.t * Paths.Path.t) list + ?mask_errors:bool + -> Exe_env.t + -> Tenv.t + -> Procdesc.t + -> Instrs.not_reversed_t + -> (Prop.normal Prop.t * Paths.Path.t) list + -> (Prop.normal Prop.t * Paths.Path.t) list (** Symbolic execution of a sequence of instructions. If errors occur and [mask_errors] is true, just treat as skip. *) diff --git a/infer/src/biabduction/SymExecBlocks.ml b/infer/src/biabduction/SymExecBlocks.ml index 25da5c64d..5754d0693 100644 --- a/infer/src/biabduction/SymExecBlocks.ml +++ b/infer/src/biabduction/SymExecBlocks.ml @@ -56,7 +56,7 @@ let resolve_method_with_block_args_and_analyze ~caller_pdesc pname act_params = when Procdesc.is_defined pdesc && Int.equal (List.length (Procdesc.get_formals pdesc)) (List.length act_params) (* only specialize defined methods, and when formals and actuals have the same length *) - -> ( + -> ( (* a list with the same length of the actual params of the function, containing either a Closure or None. *) let block_args = @@ -70,7 +70,7 @@ let resolve_method_with_block_args_and_analyze ~caller_pdesc pname act_params = let pname_with_block_args = let block_name_args = List.filter_map block_args ~f:(function - | Some (cl: Exp.closure) -> + | Some (cl : Exp.closure) -> Some (Typ.Procname.block_name_of_procname cl.name) | None -> None ) diff --git a/infer/src/biabduction/SymExecBlocks.mli b/infer/src/biabduction/SymExecBlocks.mli index 649df8242..090c80771 100644 --- a/infer/src/biabduction/SymExecBlocks.mli +++ b/infer/src/biabduction/SymExecBlocks.mli @@ -8,7 +8,9 @@ open! IStd val resolve_method_with_block_args_and_analyze : - caller_pdesc:Procdesc.t -> Typ.Procname.t -> (Exp.t * Typ.t) list + caller_pdesc:Procdesc.t + -> Typ.Procname.t + -> (Exp.t * Typ.t) list -> (Summary.t * (Exp.t * Typ.t) list) option (* [resolve_method_with_block_args_and_analyze caller_pdesc pname args] create a copy of the method pname if it is defined and it's called with diff --git a/infer/src/biabduction/Tabulation.ml b/infer/src/biabduction/Tabulation.ml index 361bcc80b..91b41cfee 100644 --- a/infer/src/biabduction/Tabulation.ml +++ b/infer/src/biabduction/Tabulation.ml @@ -156,12 +156,15 @@ let spec_rename_vars pname spec = (** Find and number the specs for [proc_name], after renaming their vars, and also return the parameters *) -let spec_find_rename trace_call summary - : (int * Prop.exposed BiabductionSummary.spec) list * Pvar.t list = +let spec_find_rename trace_call summary : + (int * Prop.exposed BiabductionSummary.spec) list * Pvar.t list = let proc_name = Summary.get_proc_name summary in try let count = ref 0 in - let rename_vars spec = incr count ; (!count, spec_rename_vars proc_name spec) in + let rename_vars spec = + incr count ; + (!count, spec_rename_vars proc_name spec) + in let specs = get_specs_from_payload summary in let formals = Summary.get_formals summary in if List.is_empty specs then ( @@ -208,11 +211,13 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ let fav_missing_primed = let filter id = Ident.is_primed id && not (Ident.HashQueue.mem fav_actual_pre id) in let fav = - Prop.sigma_sub (`Exp sub) missing_sigma |> Prop.sigma_free_vars |> Sequence.filter ~f:filter - |> Ident.hashqueue_of_sequence + Prop.sigma_sub (`Exp sub) missing_sigma + |> Prop.sigma_free_vars |> Sequence.filter ~f:filter |> Ident.hashqueue_of_sequence in - Prop.pi_sub (`Exp sub) missing_pi |> Prop.pi_free_vars |> Sequence.filter ~f:filter - |> Ident.hashqueue_of_sequence ~init:fav |> Ident.HashQueue.keys + Prop.pi_sub (`Exp sub) missing_pi + |> Prop.pi_free_vars |> Sequence.filter ~f:filter + |> Ident.hashqueue_of_sequence ~init:fav + |> Ident.HashQueue.keys in let fav_missing_fld = Prop.sigma_sub (`Exp sub) missing_fld |> Prop.sigma_free_vars |> Ident.hashqueue_of_sequence @@ -346,12 +351,12 @@ let rec find_dereference_without_null_check_in_sexp = function and find_dereference_without_null_check_in_sexp_list = function | [] -> None - | se :: sel -> + | se :: sel -> ( match find_dereference_without_null_check_in_sexp se with | None -> find_dereference_without_null_check_in_sexp_list sel | Some x -> - Some x + Some x ) (** Check dereferences implicit in the spec pre. @@ -401,12 +406,12 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo match Attribute.get_resource tenv actual_pre e_sub with | Some (Apred (Aresource ({ra_kind= Rrelease} as ra), _)) -> Some (Deref_freed ra, desc true (Localise.deref_str_freed ra)) - | _ -> + | _ -> ( match Attribute.get_undef tenv actual_pre e_sub with | Some (Apred (Aundef (s, _, loc, pos), _)) -> Some (Deref_undef (s, loc, pos), desc false (Localise.deref_str_undef (s, loc))) | _ -> - None + None ) in let check_hpred = function | Sil.Hpointsto (lexp, se, _) -> @@ -423,13 +428,13 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo match deref_err_list with | [] -> None - | deref_err :: _ -> - match - (* Prefer to report Deref_null over other kinds of deref errors. this + | deref_err :: _ -> ( + (* Prefer to report Deref_null over other kinds of deref errors. this * makes sure we report a NULL_DEREFERENCE instead of a less interesting PRECONDITION_NOT_MET * whenever possible *) - (* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *) + (* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *) + match List.find ~f:(fun err -> match err with Deref_null _, _ -> true | _ -> false) deref_err_list @@ -437,10 +442,10 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo | Some x -> Some x | None -> - Some deref_err + Some deref_err ) -let post_process_sigma tenv (sigma: Sil.hpred list) loc : Sil.hpred list = +let post_process_sigma tenv (sigma : Sil.hpred list) loc : Sil.hpred list = let map_inst inst = Sil.inst_new_loc loc inst in let do_hpred (_, _, hpred) = Sil.hpred_instmap map_inst hpred in (* update the location of instrumentations *) @@ -475,7 +480,7 @@ let check_path_errors_in_post tenv caller_pname post post_path = x.f |-> se becomes x |-> \{ f: se \}. Also, update any Aresource attributes to refer to the caller *) let post_process_post tenv caller_pname callee_pname loc actual_pre - ((post: Prop.exposed Prop.t), post_path) = + ((post : Prop.exposed Prop.t), post_path) = let actual_pre_has_freed_attribute e = match Attribute.get_resource tenv actual_pre e with | Some (Apred (Aresource {ra_kind= Rrelease}, _)) -> @@ -531,14 +536,14 @@ let rec fsel_star_fld fsel1 fsel2 = fsel2 | fsel1, [] -> fsel1 - | (f1, se1) :: fsel1', (f2, se2) :: fsel2' -> + | (f1, se1) :: fsel1', (f2, se2) :: fsel2' -> ( match Typ.Fieldname.compare f1 f2 with | 0 -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2' | n when n < 0 -> (f1, se1) :: fsel_star_fld fsel1' fsel2 | _ -> - (f2, se2) :: fsel_star_fld fsel1 fsel2' + (f2, se2) :: fsel_star_fld fsel1 fsel2' ) and array_content_star se1 se2 = @@ -553,7 +558,7 @@ and esel_star_fld esel1 esel2 = List.map ~f:(fun (e, se) -> (e, sexp_set_inst Sil.Inone se)) esel2 | esel1, [] -> esel1 - | (e1, se1) :: esel1', (e2, se2) :: esel2' -> + | (e1, se1) :: esel1', (e2, se2) :: esel2' -> ( match Exp.compare e1 e2 with | 0 -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2' @@ -562,7 +567,7 @@ and esel_star_fld esel1 esel2 = | _ -> let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *) - (e2, se2') :: esel_star_fld esel1 esel2' + (e2, se2') :: esel_star_fld esel1 esel2' ) and sexp_star_fld se1 se2 : Sil.strexp = @@ -591,16 +596,16 @@ let texp_star tenv texp1 texp2 = true | _, [] -> false - | (f1, _, _) :: ftal1', (f2, _, _) :: ftal2' -> + | (f1, _, _) :: ftal1', (f2, _, _) :: ftal2' -> ( match Typ.Fieldname.compare f1 f2 with | n when n < 0 -> false | 0 -> ftal_sub ftal1' ftal2' | _ -> - ftal_sub ftal1 ftal2' + ftal_sub ftal1 ftal2' ) in - let typ_star (t1: Typ.t) (t2: Typ.t) = + let typ_star (t1 : Typ.t) (t2 : Typ.t) = match (t1.desc, t2.desc) with | Tstruct name1, Tstruct name2 when Typ.Name.is_same_type name1 name2 -> ( match (Tenv.lookup tenv name1, Tenv.lookup tenv name2) with @@ -618,7 +623,7 @@ let texp_star tenv texp1 texp2 = texp1 -let hpred_star_fld tenv (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred = +let hpred_star_fld tenv (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred = match (hpred1, hpred2) with | Sil.Hpointsto (e1, se1, t1), Sil.Hpointsto (_, se2, t2) -> (* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2; @@ -629,7 +634,7 @@ let hpred_star_fld tenv (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred = (** Implementation of [*] for the field-splitting model *) -let sigma_star_fld tenv (sigma1: Sil.hpred list) (sigma2: Sil.hpred list) : Sil.hpred list = +let sigma_star_fld tenv (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpred list = let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in let sigma2 = List.stable_sort ~compare:hpred_lhs_compare sigma2 in (* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *) @@ -639,14 +644,14 @@ let sigma_star_fld tenv (sigma1: Sil.hpred list) (sigma2: Sil.hpred list) : Sil. [] | sigma1, [] -> sigma1 - | hpred1 :: sigma1', hpred2 :: sigma2' -> + | hpred1 :: sigma1', hpred2 :: sigma2' -> ( match hpred_lhs_compare hpred1 hpred2 with | 0 -> hpred_star_fld tenv hpred1 hpred2 :: star sigma1' sigma2' | n when n < 0 -> hpred1 :: star sigma1' sg2 | _ -> - star sg1 sigma2' + star sg1 sigma2' ) in try star sigma1 sigma2 with exn when SymOp.exn_not_failure exn -> L.d_str "cannot star " ; @@ -661,7 +666,7 @@ let hpred_typing_lhs_compare hpred1 (e2, _) = match hpred1 with Sil.Hpointsto (e1, _, _) -> Exp.compare e1 e2 | _ -> -1 -let hpred_star_typing (hpred1: Sil.hpred) (_, te2) : Sil.hpred = +let hpred_star_typing (hpred1 : Sil.hpred) (_, te2) : Sil.hpred = match hpred1 with | Sil.Hpointsto (e1, se1, _) -> Sil.Hpointsto (e1, se1, te2) @@ -670,7 +675,7 @@ let hpred_star_typing (hpred1: Sil.hpred) (_, te2) : Sil.hpred = (** Implementation of [*] between predicates and typings *) -let sigma_star_typ (sigma1: Sil.hpred list) (typings2: (Exp.t * Exp.t) list) : Sil.hpred list = +let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Exp.t * Exp.t) list) : Sil.hpred list = let typing_lhs_compare (e1, _) (e2, _) = Exp.compare e1 e2 in let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in let typings2 = List.stable_sort ~compare:typing_lhs_compare typings2 in @@ -680,14 +685,14 @@ let sigma_star_typ (sigma1: Sil.hpred list) (typings2: (Exp.t * Exp.t) list) : S [] | sigma1, [] -> sigma1 - | hpred1 :: sigma1', typing2 :: typings2' -> + | hpred1 :: sigma1', typing2 :: typings2' -> ( match hpred_typing_lhs_compare hpred1 typing2 with | 0 -> hpred_star_typing hpred1 typing2 :: star sigma1' typings2' | n when n < 0 -> hpred1 :: star sigma1' typ2 | _ -> - star sg1 typings2' + star sg1 typings2' ) in try star sigma1 typings2 with exn when SymOp.exn_not_failure exn -> L.d_str "cannot star " ; @@ -701,7 +706,7 @@ let sigma_star_typ (sigma1: Sil.hpred list) (typings2: (Exp.t * Exp.t) list) : S (** [prop_footprint_add_pi_sigma_starfld_sigma prop pi sigma missing_fld] extends the footprint of [prop] with [pi,sigma] and extends the fields of |-> with [missing_fld] *) -let prop_footprint_add_pi_sigma_starfld_sigma tenv (prop: 'a Prop.t) pi_new sigma_new missing_fld +let prop_footprint_add_pi_sigma_starfld_sigma tenv (prop : 'a Prop.t) pi_new sigma_new missing_fld missing_typ : Prop.normal Prop.t option = let rec extend_sigma current_sigma new_sigma = match new_sigma with @@ -833,14 +838,14 @@ let prop_set_exn tenv pname prop se_exn = let include_subtrace callee_pname = match Summary.proc_resolve_attributes callee_pname with | Some attrs -> - not attrs.ProcAttributes.is_model + (not attrs.ProcAttributes.is_model) && SourceFile.is_under_project_root attrs.ProcAttributes.loc.Location.file | None -> false (** combine the spec's post with a splitting and actual precondition *) -let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path_pre split +let combine tenv ret_id (posts : ('a Prop.t * Paths.Path.t) list) actual_pre path_pre split caller_pdesc callee_pname loc = let caller_pname = Procdesc.get_proc_name caller_pdesc in let instantiated_post = @@ -928,7 +933,7 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path match Prop.prop_iter_create post_p2 with | None -> post_p2 - | Some iter -> + | Some iter -> ( let filter = function | Sil.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar -> Some () @@ -938,7 +943,7 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path match Prop.prop_iter_find iter filter with | None -> post_p2 - | Some iter' -> + | Some iter' -> ( match fst (Prop.prop_iter_current tenv iter') with | Sil.Hpointsto (_, Sil.Eexp (e', inst), _) when exp_is_exn e' -> (* resuls is an exception: set in caller *) @@ -951,7 +956,7 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path (* returning nothing or unexpected sexp, turning into nondet *) Prop.prop_iter_remove_curr_then_to_prop tenv iter' | _ -> - assert false + assert false ) ) in let post_p4 = if !Config.footprint then @@ -985,8 +990,10 @@ let mk_actual_precondition tenv prop actual_params formal_params = if apars <> [] then ( let str = "more actual pars than formal pars in fun call (" - ^ string_of_int (List.length actual_params) ^ " vs " - ^ string_of_int (List.length formal_params) ^ ")" + ^ string_of_int (List.length actual_params) + ^ " vs " + ^ string_of_int (List.length formal_params) + ^ ")" in L.d_warning str ; L.d_ln () ) ; [] @@ -996,7 +1003,8 @@ let mk_actual_precondition tenv prop actual_params formal_params = comb formal_params actual_params in let mk_instantiation (formal_var, (actual_e, actual_t)) = - Prop.mk_ptsto tenv (Exp.Lvar formal_var) (Sil.Eexp (actual_e, Sil.inst_actual_precondition)) + Prop.mk_ptsto tenv (Exp.Lvar formal_var) + (Sil.Eexp (actual_e, Sil.inst_actual_precondition)) (Exp.Sizeof {typ= actual_t; nbytes= None; dynamic_length= None; subtype= Subtype.exact}) in let instantiated_formals = List.map ~f:mk_instantiation formals_actuals in @@ -1013,20 +1021,20 @@ let mk_posts tenv prop callee_pname posts = let last_call_ret_non_null = List.exists ~f:(function - | Sil.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname -> - Prover.check_disequal tenv prop exp Exp.zero - | _ -> - false) + | Sil.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname -> + Prover.check_disequal tenv prop exp Exp.zero + | _ -> + false) (Attribute.get_all prop) in if last_call_ret_non_null then let returns_null prop = List.exists ~f:(function - | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar -> - Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero - | _ -> - false) + | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar -> + Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero + | _ -> + false) prop.Prop.sigma in List.filter ~f:(fun (prop, _) -> not (returns_null prop)) posts @@ -1088,7 +1096,7 @@ let missing_sigma_need_adding_to_tenv tenv hpreds = let missing_hpred_need_adding_to_tenv hpred = match hpred with | Sil.Hpointsto (_, Sil.Estruct (missing_fields, _), Exp.Sizeof {typ= {desc= Typ.Tstruct name}}) - -> ( + -> ( match Tenv.lookup tenv name with | Some struc -> List.exists ~f:(field_is_missing struc) missing_fields @@ -1100,14 +1108,15 @@ let missing_sigma_need_adding_to_tenv tenv hpreds = List.exists hpreds ~f:missing_hpred_need_adding_to_tenv -let add_missing_field_to_tenv ~missing_sigma exe_env caller_tenv callee_pname hpreds callee_summary = +let add_missing_field_to_tenv ~missing_sigma exe_env caller_tenv callee_pname hpreds callee_summary + = (* if hpreds are missing_sigma, we may not need to add the fields to the tenv, so we check that first *) let add_fields = if missing_sigma then missing_sigma_need_adding_to_tenv caller_tenv hpreds else true in let callee_attributes = Summary.get_attributes callee_summary in (* if the callee is a model, then we don't have a tenv for it *) - if not callee_attributes.ProcAttributes.is_model && add_fields then + if (not callee_attributes.ProcAttributes.is_model) && add_fields then let callee_tenv_opt = try Some (Exe_env.get_tenv exe_env callee_pname) with _ -> let source_file = callee_attributes.ProcAttributes.loc.Location.file in @@ -1133,8 +1142,8 @@ let add_missing_field_to_tenv ~missing_sigma exe_env caller_tenv callee_pname hp (** Perform symbolic execution for a single spec *) let exe_spec exe_env tenv ret_id (n, nspecs) caller_pdesc callee_pname loc prop path_pre - (spec: Prop.exposed BiabductionSummary.spec) actual_params formal_params callee_summary - : abduction_res = + (spec : Prop.exposed BiabductionSummary.spec) actual_params formal_params callee_summary : + abduction_res = let caller_pname = Procdesc.get_proc_name caller_pdesc in let posts = mk_posts tenv prop callee_pname spec.BiabductionSummary.posts in let actual_pre = mk_actual_precondition tenv prop actual_params formal_params in @@ -1165,7 +1174,7 @@ let exe_spec exe_env tenv ret_id (n, nspecs) caller_pdesc callee_pname loc prop , frame_fld , missing_fld , frame_typ - , missing_typ ) -> + , missing_typ ) -> ( (* check if a missing_fld hpred is from a dyn language (ObjC) *) let hpred_missing_objc_class = function | Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ}) -> @@ -1230,21 +1239,21 @@ let exe_spec exe_env tenv ret_id (n, nspecs) caller_pdesc callee_pname loc prop let rec join_paths = function | [] -> None - | (_, p) :: l -> - match join_paths l with None -> Some p | Some p' -> Some (Paths.Path.join p p') + | (_, p) :: l -> ( + match join_paths l with None -> Some p | Some p' -> Some (Paths.Path.join p p') ) in let pjoin = join_paths posts in (* join the paths from the posts *) Invalid_res (Dereference_error (deref_error, desc, pjoin)) | None -> let split = do_split () in - if not !Config.footprint && split.missing_sigma <> [] then ( + if (not !Config.footprint) && split.missing_sigma <> [] then ( L.d_strln "Implication error: missing_sigma not empty in re-execution" ; Invalid_res Missing_sigma_not_empty ) - else if not !Config.footprint && missing_fld_not_objc_class <> [] then ( + else if (not !Config.footprint) && missing_fld_not_objc_class <> [] then ( L.d_strln "Implication error: missing_fld not empty in re-execution" ; Invalid_res Missing_fld_not_empty ) - else report_valid_res split + else report_valid_res split ) let remove_constant_string_class tenv prop = @@ -1263,8 +1272,8 @@ let remove_constant_string_class tenv prop = (** existentially quantify the path identifier generated by the prover to keep track of expansions of lhs paths and remove pointsto's whose lhs is a constant string *) -let quantify_path_idents_remove_constant_strings tenv (prop: Prop.normal Prop.t) - : Prop.normal Prop.t = +let quantify_path_idents_remove_constant_strings tenv (prop : Prop.normal Prop.t) : + Prop.normal Prop.t = let ids_queue = Prop.free_vars prop |> Sequence.filter ~f:Ident.is_path |> Ident.hashqueue_of_sequence in @@ -1273,9 +1282,9 @@ let quantify_path_idents_remove_constant_strings tenv (prop: Prop.normal Prop.t) (** Strengthen the footprint by adding pure facts from the current part *) -let prop_pure_to_footprint tenv (p: 'a Prop.t) : Prop.normal Prop.t = +let prop_pure_to_footprint tenv (p : 'a Prop.t) : Prop.normal Prop.t = let is_footprint_atom_not_attribute a = - not (Attribute.is_pred a) && Sil.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint + (not (Attribute.is_pred a)) && Sil.atom_free_vars a |> Sequence.for_all ~f:Ident.is_footprint in let pure = Prop.get_pure p in let new_footprint_atoms = List.filter ~f:is_footprint_atom_not_attribute pure in @@ -1312,10 +1321,9 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re let res_with_path_idents = if !Config.footprint then if List.is_empty valid_res_cons_pre_missing then ( - match (* no valid results where actual pre and missing are consistent *) - deref_errors with - | error :: _ - -> ( + (* no valid results where actual pre and missing are consistent *) + match deref_errors with + | error :: _ -> ( (* dereference error detected *) let extend_path path_opt path_pos_opt = match path_opt with @@ -1369,12 +1377,12 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re else if List.exists ~f:(function - | Prover_checks (check :: _) -> - trace_call CR_not_met ; - let exn = get_check_exn tenv check callee_pname loc __POS__ in - raise exn - | _ -> - false) + | Prover_checks (check :: _) -> + trace_call CR_not_met ; + let exn = get_check_exn tenv check callee_pname loc __POS__ in + raise exn + | _ -> + false) invalid_res then call_desc (Some Localise.Pnm_bounds) else call_desc None @@ -1385,7 +1393,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re (* combine the valid results, and store diverging states *) let process_valid_res vr = let save_diverging_states () = - if not vr.incons_pre_missing && List.is_empty vr.vr_cons_res then + if (not vr.incons_pre_missing) && List.is_empty vr.vr_cons_res then (* no consistent results on one spec: divergence *) let incons_res = List.map diff --git a/infer/src/biabduction/Tabulation.mli b/infer/src/biabduction/Tabulation.mli index 15dd77ffb..7333af639 100644 --- a/infer/src/biabduction/Tabulation.mli +++ b/infer/src/biabduction/Tabulation.mli @@ -16,8 +16,13 @@ type call_result = | CR_skip (** the callee was skipped *) val log_call_trace : - caller_name:Typ.Procname.t -> callee_name:Typ.Procname.t -> ?callee_attributes:ProcAttributes.t - -> ?reason:string -> ?dynamic_dispatch:EventLogger.dynamic_dispatch -> Location.t -> call_result + caller_name:Typ.Procname.t + -> callee_name:Typ.Procname.t + -> ?callee_attributes:ProcAttributes.t + -> ?reason:string + -> ?dynamic_dispatch:EventLogger.dynamic_dispatch + -> Location.t + -> call_result -> unit (** Interprocedural footprint analysis *) @@ -47,9 +52,18 @@ val lookup_custom_errors : 'a Prop.t -> string option (** search in prop contains an error state *) val exe_function_call : - ?dynamic_dispatch:EventLogger.dynamic_dispatch -> Exe_env.t -> Summary.t -> Tenv.t -> Ident.t - -> Procdesc.t -> Typ.Procname.t -> Location.t -> (Exp.t * Typ.t) list -> Prop.normal Prop.t - -> Paths.Path.t -> (Prop.normal Prop.t * Paths.Path.t) list + ?dynamic_dispatch:EventLogger.dynamic_dispatch + -> Exe_env.t + -> Summary.t + -> Tenv.t + -> Ident.t + -> Procdesc.t + -> Typ.Procname.t + -> Location.t + -> (Exp.t * Typ.t) list + -> Prop.normal Prop.t + -> Paths.Path.t + -> (Prop.normal Prop.t * Paths.Path.t) list (** Execute the function call and return the list of results with return value *) val get_specs_from_payload : Summary.t -> Prop.normal BiabductionSummary.spec list diff --git a/infer/src/biabduction/Timeout.ml b/infer/src/biabduction/Timeout.ml index d7adff3d7..dfac20527 100644 --- a/infer/src/biabduction/Timeout.ml +++ b/infer/src/biabduction/Timeout.ml @@ -39,7 +39,7 @@ let set_alarm nsecs = (Unix.setitimer Unix.ITIMER_REAL { Unix.it_interval= 3.0 ; (* try again after 3 seconds if the signal is lost *) - Unix.it_value= nsecs }) + Unix.it_value= nsecs }) | Config.Win32 -> SymOp.set_wallclock_alarm nsecs diff --git a/infer/src/biabduction/interproc.ml b/infer/src/biabduction/interproc.ml index 16180c53a..c535a1848 100644 --- a/infer/src/biabduction/interproc.ml +++ b/infer/src/biabduction/interproc.ml @@ -97,9 +97,9 @@ module Worklist = struct ; visit_map= Procdesc.NodeMap.empty } - let is_empty (wl: t) : bool = NodeVisitSet.is_empty wl.todo_set + let is_empty (wl : t) : bool = NodeVisitSet.is_empty wl.todo_set - let add (wl: t) (node: Procdesc.Node.t) : unit = + let add (wl : t) (node : Procdesc.Node.t) : unit = let visits = (* recover visit count if it was visited before *) try Procdesc.NodeMap.find node wl.visit_map with Caml.Not_found -> 0 @@ -108,7 +108,7 @@ module Worklist = struct (** remove the minimum element from the worklist, and increase its number of visits *) - let remove (wl: t) : Procdesc.Node.t = + let remove (wl : t) : Procdesc.Node.t = try let min = NodeVisitSet.min_elt wl.todo_set in wl.todo_set <- NodeVisitSet.remove min wl.todo_set ; @@ -129,15 +129,15 @@ let path_set_create_worklist proc_cfg = Worklist.create () -let htable_retrieve (htable: (Procdesc.Node.id, Paths.PathSet.t) Hashtbl.t) (key: Procdesc.Node.id) - : Paths.PathSet.t = +let htable_retrieve (htable : (Procdesc.Node.id, Paths.PathSet.t) Hashtbl.t) + (key : Procdesc.Node.id) : Paths.PathSet.t = try Hashtbl.find htable key with Caml.Not_found -> Hashtbl.replace htable key Paths.PathSet.empty ; Paths.PathSet.empty (** Add [d] to the pathset todo at [node] returning true if changed *) -let path_set_put_todo (wl: Worklist.t) (node: Procdesc.Node.t) (d: Paths.PathSet.t) : bool = +let path_set_put_todo (wl : Worklist.t) (node : Procdesc.Node.t) (d : Paths.PathSet.t) : bool = let changed = if Paths.PathSet.is_empty d then false else @@ -153,7 +153,7 @@ let path_set_put_todo (wl: Worklist.t) (node: Procdesc.Node.t) (d: Paths.PathSet changed -let path_set_checkout_todo (wl: Worklist.t) (node: Procdesc.Node.t) : Paths.PathSet.t = +let path_set_checkout_todo (wl : Worklist.t) (node : Procdesc.Node.t) : Paths.PathSet.t = try let node_id = Procdesc.Node.get_id node in let todo = Hashtbl.find wl.Worklist.path_set_todo node_id in @@ -168,12 +168,12 @@ let path_set_checkout_todo (wl: Worklist.t) (node: Procdesc.Node.t) : Paths.Path (* =============== END of the edge_set object =============== *) -let collect_do_abstract_pre pname tenv (pset: Propset.t) : Propset.t = +let collect_do_abstract_pre pname tenv (pset : Propset.t) : Propset.t = if !Config.footprint then Config.run_in_re_execution_mode (Abs.lifted_abstract pname tenv) pset else Abs.lifted_abstract pname tenv pset -let collect_do_abstract_post pname tenv (pathset: Paths.PathSet.t) : Paths.PathSet.t = +let collect_do_abstract_post pname tenv (pathset : Paths.PathSet.t) : Paths.PathSet.t = let abs_option p = if Prover.check_inconsistency tenv p then None else Some (Abs.abstract pname tenv p) in @@ -184,7 +184,7 @@ let collect_do_abstract_post pname tenv (pathset: Paths.PathSet.t) : Paths.PathS let do_join_pre plist = Dom.proplist_collapse_pre plist -let do_join_post pname tenv (pset: Paths.PathSet.t) = +let do_join_post pname tenv (pset : Paths.PathSet.t) = if Config.spec_abs_level <= 0 then Dom.pathset_collapse tenv pset else Dom.pathset_collapse tenv (Dom.pathset_collapse_impl pname tenv pset) @@ -261,8 +261,8 @@ let collect_preconditions tenv summary : Prop.normal BiabductionSummary.Jprop.t (* =============== START of symbolic execution =============== *) (** propagate a set of results to the given node *) -let propagate (wl: Worklist.t) pname ~is_exception (pset: Paths.PathSet.t) - (curr_node: Procdesc.Node.t) = +let propagate (wl : Worklist.t) pname ~is_exception (pset : Paths.PathSet.t) + (curr_node : Procdesc.Node.t) = let edgeset_todo = (* prop must be a renamed prop by the invariant preserved by PropSet *) let f prop path edgeset_curr = @@ -278,8 +278,8 @@ let propagate (wl: Worklist.t) pname ~is_exception (pset: Paths.PathSet.t) (** propagate a set of results, including exceptions and divergence *) -let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Paths.PathSet.t) - curr_node (wl: Worklist.t) = +let propagate_nodes_divergence tenv (proc_cfg : ProcCfg.Exceptional.t) (pset : Paths.PathSet.t) + curr_node (wl : Worklist.t) = let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in let pset_exn, pset_ok = Paths.PathSet.partition (Tabulation.prop_is_exn pname) pset in if !Config.footprint && not (Paths.PathSet.is_empty (State.get_diverging_states_node ())) then ( @@ -310,7 +310,7 @@ let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Pat (* =============== START of forward_tabulate =============== *) (** Symbolic execution for a Join node *) -let do_symexec_join proc_cfg tenv wl curr_node (edgeset_todo: Paths.PathSet.t) = +let do_symexec_join proc_cfg tenv wl curr_node (edgeset_todo : Paths.PathSet.t) = let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in let curr_node_id = ProcCfg.Exceptional.Node.id curr_node in let new_dset = edgeset_todo in @@ -369,7 +369,8 @@ let instrs_get_normal_vars instrs = let do_instr res instr = Sil.instr_get_exps instr |> List.fold_left ~init:res ~f:(fun res e -> - Exp.free_vars e |> Sequence.filter ~f:Ident.is_normal + Exp.free_vars e + |> Sequence.filter ~f:Ident.is_normal |> Ident.hashqueue_of_sequence ~init:res ) in Instrs.fold ~init:(Ident.HashQueue.create ()) ~f:do_instr instrs |> Ident.HashQueue.keys @@ -377,7 +378,7 @@ let instrs_get_normal_vars instrs = (** Perform symbolic execution for a node starting from an initial prop *) let do_symbolic_execution exe_env summary proc_cfg handle_exn tenv - (node: ProcCfg.Exceptional.Node.t) (prop: Prop.normal Prop.t) (path: Paths.Path.t) = + (node : ProcCfg.Exceptional.Node.t) (prop : Prop.normal Prop.t) (path : Paths.Path.t) = State.mark_execution_start node ; let instrs = ProcCfg.Exceptional.instrs node in (* fresh normal vars must be fresh w.r.t. instructions *) @@ -423,11 +424,7 @@ let forward_tabulate summary exe_env tenv proc_cfg wl = let exe_iter f pathset = let ps_size = Paths.PathSet.size pathset in let cnt = ref 0 in - let exe prop path = - State.set_path path None ; - incr cnt ; - f prop path !cnt ps_size - in + let exe prop path = State.set_path path None ; incr cnt ; f prop path !cnt ps_size in Paths.PathSet.iter exe pathset in let print_node_preamble curr_node session pathset_todo = @@ -442,9 +439,11 @@ let forward_tabulate summary exe_env tenv proc_cfg wl = in L.d_strln ( "**** " ^ log_string pname ^ " " ^ "Node: " - ^ string_of_int (Procdesc.Node.get_id curr_node :> int) ^ ", " ^ "Procedure: " - ^ Typ.Procname.to_string pname ^ ", " ^ "Session: " ^ string_of_int session ^ ", " ^ "Todo: " - ^ string_of_int (Paths.PathSet.size pathset_todo) ^ " ****" ) ; + ^ string_of_int (Procdesc.Node.get_id curr_node :> int) + ^ ", " ^ "Procedure: " ^ Typ.Procname.to_string pname ^ ", " ^ "Session: " + ^ string_of_int session ^ ", " ^ "Todo: " + ^ string_of_int (Paths.PathSet.size pathset_todo) + ^ " ****" ) ; L.d_increase_indent 1 ; Propset.d Prop.prop_emp (Paths.PathSet.to_propset tenv pathset_todo) ; L.d_strln ".... Instructions: .... " ; @@ -452,7 +451,7 @@ let forward_tabulate summary exe_env tenv proc_cfg wl = L.d_ln () ; L.d_ln () in - let do_prop (curr_node: ProcCfg.Exceptional.Node.t) handle_exn prop path cnt num_paths = + let do_prop (curr_node : ProcCfg.Exceptional.Node.t) handle_exn prop path cnt num_paths = L.d_strln ("Processing prop " ^ string_of_int cnt ^ "/" ^ string_of_int num_paths) ; L.d_increase_indent 1 ; try @@ -465,7 +464,7 @@ let forward_tabulate summary exe_env tenv proc_cfg wl = L.d_ln () with exn -> IExn.reraise_if exn ~f:(fun () -> - not !Config.footprint || not (Exceptions.handle_exception exn) ) ; + (not !Config.footprint) || not (Exceptions.handle_exception exn) ) ; handle_exn exn ; L.d_decrease_indent 1 ; L.d_ln () @@ -622,7 +621,7 @@ let extract_specs tenv pdesc pathset : Prop.normal BiabductionSummary.spec list List.fold ~f:add ~init:Pmap.empty pre_post_visited_list in let specs = ref [] in - let add_spec pre ((posts: Paths.PathSet.t), visited) = + let add_spec pre ((posts : Paths.PathSet.t), visited) = let posts' = List.map ~f:(fun (p, path) -> (PropUtil.remove_seed_vars tenv p, path)) @@ -692,7 +691,7 @@ let create_seed_vars sigma = parameters. The footprint is initialized according to the execution mode. The prop is not necessarily emp, so it should be incorporated when the footprint is constructed. *) -let prop_init_formals_seed tenv new_formals (prop: 'a Prop.t) : Prop.exposed Prop.t = +let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Prop.t = let sigma_new_formals = let do_formal (pv, typ) = let texp = @@ -720,7 +719,7 @@ let prop_init_formals_seed tenv new_formals (prop: 'a Prop.t) : Prop.exposed Pro (** Construct an initial prop by extending [prop] with locals, and formals if [add_formals] is true as well as seed variables *) -let initial_prop tenv (curr_f: Procdesc.t) (prop: 'a Prop.t) add_formals : Prop.normal Prop.t = +let initial_prop tenv (curr_f : Procdesc.t) (prop : 'a Prop.t) add_formals : Prop.normal Prop.t = let construct_decl (x, typ) = (Pvar.mk x (Procdesc.get_proc_name curr_f), typ) in let new_formals = if add_formals then List.map ~f:construct_decl (Procdesc.get_formals curr_f) else [] @@ -753,8 +752,8 @@ let initial_prop_from_pre tenv curr_f pre = (** Re-execute one precondition and return some spec if there was no re-execution error. *) let execute_filter_prop summary exe_env tenv proc_cfg - (precondition: Prop.normal BiabductionSummary.Jprop.t) - : Prop.normal BiabductionSummary.spec option = + (precondition : Prop.normal BiabductionSummary.Jprop.t) : + Prop.normal BiabductionSummary.spec option = let init_node = ProcCfg.Exceptional.start_node proc_cfg in let wl = path_set_create_worklist proc_cfg in let pdesc = ProcCfg.Exceptional.proc_desc proc_cfg in @@ -826,12 +825,12 @@ type exe_phase = and [get_results ()] returns the results computed. This function is architected so that [get_results ()] can be called even after [go ()] was interrupted by and exception. *) -let perform_analysis_phase exe_env tenv (summary: Summary.t) (proc_cfg: ProcCfg.Exceptional.t) - : exe_phase = +let perform_analysis_phase exe_env tenv (summary : Summary.t) (proc_cfg : ProcCfg.Exceptional.t) : + exe_phase = let pname = Summary.get_proc_name summary in let start_node = ProcCfg.Exceptional.start_node proc_cfg in let compute_footprint () : exe_phase = - let go (wl: Worklist.t) () = + let go (wl : Worklist.t) () = let pdesc = ProcCfg.Exceptional.proc_desc proc_cfg in let init_prop = initial_prop_from_emp tenv pdesc in (* use existing pre's (in recursion some might exist) as starting points *) @@ -860,7 +859,7 @@ let perform_analysis_phase exe_env tenv (summary: Summary.t) (proc_cfg: ProcCfg. ignore (path_set_put_todo wl start_node init_edgeset) ; forward_tabulate summary exe_env tenv proc_cfg wl in - let get_results (wl: Worklist.t) () = + let get_results (wl : Worklist.t) () = State.process_execution_failures (Reporting.log_issue_deprecated Exceptions.Warning) pname ; let results = collect_analysis_result tenv wl proc_cfg in let specs = @@ -1054,8 +1053,8 @@ module SpecMap = Caml.Map.Make (struct end) (** Update the specs of the current proc after the execution of one phase *) -let update_specs tenv prev_summary phase (new_specs: BiabductionSummary.NormSpec.t list) - : BiabductionSummary.NormSpec.t list * bool = +let update_specs tenv prev_summary phase (new_specs : BiabductionSummary.NormSpec.t list) : + BiabductionSummary.NormSpec.t list * bool = let new_specs = BiabductionSummary.normalized_specs_to_specs new_specs in let old_specs = Tabulation.get_specs_from_payload prev_summary in let changed = ref false in @@ -1065,7 +1064,8 @@ let update_specs tenv prev_summary phase (new_specs: BiabductionSummary.NormSpec ~f:(fun map spec -> SpecMap.add spec.BiabductionSummary.pre ( Paths.PathSet.from_renamed_list spec.BiabductionSummary.posts - , spec.BiabductionSummary.visited ) map ) + , spec.BiabductionSummary.visited ) + map ) ~init:SpecMap.empty old_specs) in let re_exe_filter old_spec = @@ -1102,7 +1102,8 @@ let update_specs tenv prev_summary phase (new_specs: BiabductionSummary.NormSpec current_specs := SpecMap.add spec.BiabductionSummary.pre ( Paths.PathSet.from_renamed_list spec.BiabductionSummary.posts - , spec.BiabductionSummary.visited ) !current_specs + , spec.BiabductionSummary.visited ) + !current_specs in let res = ref [] in let convert pre (post_set, visited) = diff --git a/infer/src/bufferoverrun/absLoc.ml b/infer/src/bufferoverrun/absLoc.ml index 851810a1a..ff72ae746 100644 --- a/infer/src/bufferoverrun/absLoc.ml +++ b/infer/src/bufferoverrun/absLoc.ml @@ -32,7 +32,7 @@ module Loc = struct type t = Var of Var.t | Allocsite of Allocsite.t | Field of t * Typ.Fieldname.t [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let unknown = Allocsite Allocsite.unknown diff --git a/infer/src/bufferoverrun/arrayBlk.ml b/infer/src/bufferoverrun/arrayBlk.ml index cf3572e58..dfa72a912 100644 --- a/infer/src/bufferoverrun/arrayBlk.ml +++ b/infer/src/bufferoverrun/arrayBlk.ml @@ -46,7 +46,8 @@ module ArrInfo = struct fun ~lhs ~rhs -> if phys_equal lhs rhs then true else - Itv.le ~lhs:lhs.offset ~rhs:rhs.offset && Itv.le ~lhs:lhs.size ~rhs:rhs.size + Itv.le ~lhs:lhs.offset ~rhs:rhs.offset + && Itv.le ~lhs:lhs.size ~rhs:rhs.size && Itv.le ~lhs:lhs.stride ~rhs:rhs.stride diff --git a/infer/src/bufferoverrun/bounds.ml b/infer/src/bufferoverrun/bounds.ml index 9bf160ff2..e9db87f9e 100644 --- a/infer/src/bufferoverrun/bounds.ml +++ b/infer/src/bufferoverrun/bounds.ml @@ -51,9 +51,13 @@ module SymLinear = struct M.for_all2 ~f:le_one_pair x y - let make - : unsigned:bool -> Typ.Procname.t -> Symb.SymbolTable.t -> Symb.SymbolPath.t -> Counter.t - -> t * t = + let make : + unsigned:bool + -> Typ.Procname.t + -> Symb.SymbolTable.t + -> Symb.SymbolPath.t + -> Counter.t + -> t * t = fun ~unsigned pname symbol_table path new_sym_num -> let lb, ub = Symb.SymbolTable.lookup ~unsigned pname path symbol_table new_sym_num in (singleton_one lb, singleton_one ub) @@ -61,8 +65,8 @@ module SymLinear = struct let eq : t -> t -> bool = fun x y -> - let eq_pair _ (coeff1: NonZeroInt.t option) (coeff2: NonZeroInt.t option) = - [%compare.equal : int option] (coeff1 :> int option) (coeff2 :> int option) + let eq_pair _ (coeff1 : NonZeroInt.t option) (coeff2 : NonZeroInt.t option) = + [%compare.equal: int option] (coeff1 :> int option) (coeff2 :> int option) in M.for_all2 ~f:eq_pair x y @@ -192,7 +196,7 @@ module Bound = struct module Sign = struct type t = sign [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let neg = function Plus -> Minus | Minus -> Plus @@ -211,7 +215,7 @@ module Bound = struct module MinMax = struct type t = min_max [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let neg = function Min -> Max | Max -> Min @@ -230,7 +234,7 @@ module Bound = struct | PInf [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let pp : F.formatter -> t -> unit = fun fmt -> function @@ -294,12 +298,12 @@ module Bound = struct match m with | Min -> of_int (Sign.eval_int sign c d) - | Max -> + | Max -> ( match sign with | Plus -> Linear (c, SymLinear.singleton_one s) | Minus -> - Linear (c, SymLinear.singleton_minus_one s) + Linear (c, SymLinear.singleton_minus_one s) ) else MinMax (c, sign, m, d, s) @@ -455,9 +459,11 @@ module Bound = struct mk_MinMax (c2, Plus, Min, c1 - c2, SymLinear.get_one_symbol x2) | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> mk_MinMax (c1, Plus, Min, c2 - c1, SymLinear.get_one_symbol x1) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 + -> mk_MinMax (c2, Minus, Max, c2 - c1, SymLinear.get_mone_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 + -> mk_MinMax (c1, Minus, Max, c1 - c2, SymLinear.get_mone_symbol x1) | MinMax (c1, Plus, Min, d1, s), Linear (c2, se) | Linear (c2, se), MinMax (c1, Plus, Min, d1, s) @@ -512,9 +518,11 @@ module Bound = struct mk_MinMax (c2, Plus, Max, c1 - c2, SymLinear.get_one_symbol x2) | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> mk_MinMax (c1, Plus, Max, c2 - c1, SymLinear.get_one_symbol x1) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 + -> mk_MinMax (c2, Minus, Min, c2 - c1, SymLinear.get_mone_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 + -> mk_MinMax (c1, Minus, Min, c1 - c2, SymLinear.get_mone_symbol x1) | _, _ -> default @@ -622,14 +630,14 @@ module Bound = struct if NonZeroInt.is_positive n then PInf else MInf | Linear (c, x') -> Linear (c * (n :> int), SymLinear.mult_const n x') - | MinMax _ -> + | MinMax _ -> ( let int_bound = let bound_end' = if NonZeroInt.is_positive n then bound_end else Symb.BoundEnd.neg bound_end in int_of_minmax bound_end' x in - match int_bound with Some i -> of_int (i * (n :> int)) | None -> of_bound_end bound_end + match int_bound with Some i -> of_int (i * (n :> int)) | None -> of_bound_end bound_end ) let mult_const_l = mult_const Symb.BoundEnd.LowerBound @@ -701,8 +709,8 @@ module Bound = struct (** Substitutes ALL symbols in [x] with respect to [map]. Throws [Symbol_not_found] if a symbol in [x] can't be found in [map]. Under/over-Approximate as good as possible according to [subst_pos]. *) - let subst_exn - : subst_pos:Symb.BoundEnd.t -> t -> t bottom_lifted Symb.SymbolMap.t -> t bottom_lifted = + let subst_exn : + subst_pos:Symb.BoundEnd.t -> t -> t bottom_lifted Symb.SymbolMap.t -> t bottom_lifted = fun ~subst_pos x map -> let get_exn s = match Symb.SymbolMap.find s map with @@ -722,21 +730,22 @@ module Bound = struct | NonBottom x -> let x = mult_const subst_pos coeff x in if Symb.Symbol.is_unsigned s then NonBottom (ub ~default:x zero x) else NonBottom x - with Caml.Not_found -> + with Caml.Not_found -> ( (* For unsigned symbols, we can over/under-approximate with zero depending on [subst_pos] and the sign of the coefficient. *) match (Symb.Symbol.is_unsigned s, subst_pos, NonZeroInt.is_positive coeff) with | true, Symb.BoundEnd.LowerBound, true | true, Symb.BoundEnd.UpperBound, false -> NonBottom zero | _ -> - raise (Symbol_not_found s) + raise (Symbol_not_found s) ) in match x with | MInf | PInf -> NonBottom x | Linear (c, se) -> - SymLinear.fold se ~init:(NonBottom (of_int c)) ~f:(fun acc s coeff -> - lift2 (plus subst_pos) acc (get_mult_const s coeff) ) - | MinMax (c, sign, min_max, d, s) -> + SymLinear.fold se + ~init:(NonBottom (of_int c)) + ~f:(fun acc s coeff -> lift2 (plus subst_pos) acc (get_mult_const s coeff)) + | MinMax (c, sign, min_max, d, s) -> ( match get_exn s with | Bottom -> Bottom @@ -755,8 +764,7 @@ module Bound = struct PInf | sign, Min, PInf | sign, Max, MInf -> of_int (Sign.eval_int sign c d) - | _, _, Linear (c2, se) - -> ( + | _, _, Linear (c2, se) -> ( if SymLinear.is_zero se then of_int (Sign.eval_int sign c (MinMax.eval_int min_max d c2)) else if SymLinear.is_one_symbol se then @@ -775,7 +783,7 @@ module Bound = struct of_int i | None -> of_bound_end subst_pos ) - | _, _, MinMax (c2, sign2, min_max2, d2, s2) -> + | _, _, MinMax (c2, sign2, min_max2, d2, s2) -> ( match (min_max, sign2, min_max2) with | Min, Plus, Min | Max, Plus, Max -> let c' = Sign.eval_int sign c c2 in @@ -792,9 +800,9 @@ module Bound = struct of_int (Sign.eval_int sign c (MinMax.eval_int min_max d - (int_of_minmax bound_end x' |> Option.value ~default:d))) + (int_of_minmax bound_end x' |> Option.value ~default:d))) ) in - NonBottom res + NonBottom res ) let subst_lb_exn x map = subst_exn ~subst_pos:Symb.BoundEnd.LowerBound x map @@ -833,10 +841,10 @@ module NonNegativeBound = struct ValTop | Bound.MInf -> assert false - | b -> + | b -> ( match Bound.is_const b with | None -> Symbolic b | Some c -> - Constant (NonNegativeInt.of_int_exn c) + Constant (NonNegativeInt.of_int_exn c) ) end diff --git a/infer/src/bufferoverrun/bounds.mli b/infer/src/bufferoverrun/bounds.mli index 3c8261a96..efb918137 100644 --- a/infer/src/bufferoverrun/bounds.mli +++ b/infer/src/bufferoverrun/bounds.mli @@ -18,7 +18,11 @@ module SymLinear : sig type t = Ints.NonZeroInt.t M.t val make : - unsigned:bool -> Typ.Procname.t -> Symb.SymbolTable.t -> Symb.SymbolPath.t -> Counter.t + unsigned:bool + -> Typ.Procname.t + -> Symb.SymbolTable.t + -> Symb.SymbolPath.t + -> Counter.t -> t * t val eq : t -> t -> bool @@ -116,11 +120,13 @@ module Bound : sig val is_not_infty : t -> bool val subst_lb_exn : - t -> t AbstractDomain.Types.bottom_lifted Symb.SymbolMap.t + t + -> t AbstractDomain.Types.bottom_lifted Symb.SymbolMap.t -> t AbstractDomain.Types.bottom_lifted val subst_ub_exn : - t -> t AbstractDomain.Types.bottom_lifted Symb.SymbolMap.t + t + -> t AbstractDomain.Types.bottom_lifted Symb.SymbolMap.t -> t AbstractDomain.Types.bottom_lifted val simplify_bound_ends_from_paths : t -> t diff --git a/infer/src/bufferoverrun/bufferOverrunChecker.ml b/infer/src/bufferoverrun/bufferOverrunChecker.ml index 1cb43db38..9867601b1 100644 --- a/infer/src/bufferoverrun/bufferOverrunChecker.ml +++ b/infer/src/bufferoverrun/bufferOverrunChecker.ml @@ -23,9 +23,9 @@ module TraceSet = Trace.Set module Payload = SummaryPayload.Make (struct type t = Dom.Summary.t - let update_payloads astate (payloads: Payloads.t) = {payloads with buffer_overrun= Some astate} + let update_payloads astate (payloads : Payloads.t) = {payloads with buffer_overrun= Some astate} - let of_payloads (payloads: Payloads.t) = payloads.buffer_overrun + let of_payloads (payloads : Payloads.t) = payloads.buffer_overrun end) module TransferFunctions (CFG : ProcCfg.S) = struct @@ -52,7 +52,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let ret_var = Loc.of_var (Var.of_id id) in let add_ret_alias l = Dom.Mem.load_alias id l mem in let mem = Option.value_map ret_alias ~default:mem ~f:add_ret_alias in - Dom.Val.subst ret_val subst_map location |> Dom.Val.add_trace_elem (Trace.Return location) + Dom.Val.subst ret_val subst_map location + |> Dom.Val.add_trace_elem (Trace.Return location) |> Fn.flip (Dom.Mem.add_stack ret_var) mem |> copy_reachable_new_locs_from (Dom.Val.get_all_locs ret_val) @@ -68,8 +69,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match Tenv.lookup tenv typename with | Some str -> let formal_locs = - Dom.Mem.find (Loc.of_pvar (fst formal)) callee_exit_mem |> Dom.Val.get_array_blk - |> ArrayBlk.get_pow_loc + Dom.Mem.find (Loc.of_pvar (fst formal)) callee_exit_mem + |> Dom.Val.get_array_blk |> ArrayBlk.get_pow_loc in let instantiate_fld mem (fn, _, _) = let formal_fields = PowLoc.append_field formal_locs ~fn in @@ -83,8 +84,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct mem ) | _ -> let formal_locs = - Dom.Mem.find (Loc.of_pvar (fst formal)) callee_exit_mem |> Dom.Val.get_array_blk - |> ArrayBlk.get_pow_loc + Dom.Mem.find (Loc.of_pvar (fst formal)) callee_exit_mem + |> Dom.Val.get_array_blk |> ArrayBlk.get_pow_loc in let v = Dom.Mem.find_set formal_locs callee_exit_mem in let actual_locs = Dom.Val.get_all_locs actual in @@ -101,9 +102,16 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Dom.Mem.forget_locs (PowLoc.add ret_loc (PowLoc.singleton ret_var)) mem - let instantiate_mem - : Tenv.t -> Ident.t * Typ.t -> Procdesc.t -> Typ.Procname.t -> (Exp.t * Typ.t) list - -> Dom.Mem.astate -> Dom.Summary.t -> Location.t -> Dom.Mem.astate = + let instantiate_mem : + Tenv.t + -> Ident.t * Typ.t + -> Procdesc.t + -> Typ.Procname.t + -> (Exp.t * Typ.t) list + -> Dom.Mem.astate + -> Dom.Summary.t + -> Location.t + -> Dom.Mem.astate = fun tenv ret callee_pdesc callee_pname params caller_mem summary location -> let callee_symbol_table = Dom.Summary.get_symbol_table summary in let callee_exit_mem = Dom.Summary.get_output summary in @@ -130,7 +138,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct L.(debug BufferOverrun Verbose) "================================@\n@." - let exec_instr : Dom.Mem.astate -> extras ProcData.t -> CFG.Node.t -> Sil.instr -> Dom.Mem.astate = + let exec_instr : Dom.Mem.astate -> extras ProcData.t -> CFG.Node.t -> Sil.instr -> Dom.Mem.astate + = fun mem {pdesc; tenv; extras= symbol_table} node instr -> let output_mem = match instr with @@ -170,8 +179,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct mem | Prune (exp, _, _, _) -> Sem.Prune.prune exp mem - | Call (((id, _) as ret), Const (Cfun callee_pname), params, location, _) - -> ( + | Call (((id, _) as ret), Const (Cfun callee_pname), params, location, _) -> ( let mem = Dom.Mem.add_stack_loc (Loc.of_id id) mem in match Models.Call.dispatch tenv callee_pname params with | Some {Models.exec} -> @@ -180,7 +188,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Models.mk_model_env callee_pname node_hash location tenv symbol_table in exec model_env ~ret mem - | None -> + | None -> ( match Ondemand.analyze_proc_name ~caller_pdesc:pdesc callee_pname with | Some callee_summary -> ( match Payload.of_summary callee_summary with @@ -197,7 +205,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct L.(debug BufferOverrun Verbose) "/!\\ Unknown call to %a at %a@\n" Typ.Procname.pp callee_pname Location.pp location ; - Dom.Mem.add_unknown_from id ~callee_pname ~location mem ) + Dom.Mem.add_unknown_from id ~callee_pname ~location mem ) ) | Call ((id, _), fun_exp, _, location, _) -> let mem = Dom.Mem.add_stack_loc (Loc.of_id id) mem in let () = @@ -223,10 +231,19 @@ module Analyzer = AbstractInterpreter.Make (CFG) (TransferFunctions) type invariant_map = Analyzer.invariant_map module Init = struct - let declare_symbolic_val - : Typ.Procname.t -> Itv.SymbolTable.t -> Itv.SymbolPath.partial -> Tenv.t -> node_hash:int - -> Location.t -> Loc.t -> Typ.typ -> inst_num:int -> new_sym_num:Itv.Counter.t -> Dom.Mem.t - -> Dom.Mem.t = + let declare_symbolic_val : + Typ.Procname.t + -> Itv.SymbolTable.t + -> Itv.SymbolPath.partial + -> Tenv.t + -> node_hash:int + -> Location.t + -> Loc.t + -> Typ.typ + -> inst_num:int + -> new_sym_num:Itv.Counter.t + -> Dom.Mem.t + -> Dom.Mem.t = fun pname symbol_table path tenv ~node_hash location loc typ ~inst_num ~new_sym_num mem -> let max_depth = 2 in let new_alloc_num = Itv.Counter.make 1 in @@ -299,9 +316,16 @@ module Init = struct decl_sym_val pname path tenv ~node_hash location ~depth:0 ~may_last_field:true loc typ mem - let declare_symbolic_parameters - : Typ.Procname.t -> Tenv.t -> node_hash:int -> Location.t -> Itv.SymbolTable.t - -> inst_num:int -> (Pvar.t * Typ.t) list -> Dom.Mem.astate -> Dom.Mem.astate = + let declare_symbolic_parameters : + Typ.Procname.t + -> Tenv.t + -> node_hash:int + -> Location.t + -> Itv.SymbolTable.t + -> inst_num:int + -> (Pvar.t * Typ.t) list + -> Dom.Mem.astate + -> Dom.Mem.astate = fun pname tenv ~node_hash location symbol_table ~inst_num formals mem -> let new_sym_num = Itv.Counter.make 0 in let add_formal (mem, inst_num) (pvar, typ) = @@ -356,7 +380,7 @@ module Report = struct * of a procedure (no more significant instruction) * or of a block (goes directly to a node with multiple predecessors) *) - let rec is_end_of_block_or_procedure (cfg: CFG.t) node rem_instrs = + let rec is_end_of_block_or_procedure (cfg : CFG.t) node rem_instrs = Instrs.for_all rem_instrs ~f:Sil.instr_is_auxiliary && match IContainer.singleton_or_more node ~fold:(CFG.fold_succs cfg) with @@ -370,7 +394,7 @@ module Report = struct false end - let check_unreachable_code summary tenv (cfg: CFG.t) (node: CFG.Node.t) instr rem_instrs = + let check_unreachable_code summary tenv (cfg : CFG.t) (node : CFG.Node.t) instr rem_instrs = match instr with | Sil.Prune (_, _, _, (Ik_land_lor | Ik_bexp)) -> () @@ -394,9 +418,14 @@ module Report = struct Reporting.log_error summary ~loc:location exn - let check_binop_array_access - : is_plus:bool -> e1:Exp.t -> e2:Exp.t -> Location.t -> Dom.Mem.astate -> PO.ConditionSet.t - -> PO.ConditionSet.t = + let check_binop_array_access : + is_plus:bool + -> e1:Exp.t + -> e2:Exp.t + -> Location.t + -> Dom.Mem.astate + -> PO.ConditionSet.t + -> PO.ConditionSet.t = fun ~is_plus ~e1 ~e2 location mem cond_set -> let arr = Sem.eval e1 mem in let idx = Sem.eval e2 mem in @@ -405,9 +434,14 @@ module Report = struct BoUtils.Check.array_access ~arr ~idx ~idx_sym_exp ~relation ~is_plus location cond_set - let check_binop - : bop:Binop.t -> e1:Exp.t -> e2:Exp.t -> Location.t -> Dom.Mem.astate -> PO.ConditionSet.t - -> PO.ConditionSet.t = + let check_binop : + bop:Binop.t + -> e1:Exp.t + -> e2:Exp.t + -> Location.t + -> Dom.Mem.astate + -> PO.ConditionSet.t + -> PO.ConditionSet.t = fun ~bop ~e1 ~e2 location mem cond_set -> match bop with | Binop.PlusPI -> @@ -418,7 +452,8 @@ module Report = struct cond_set - let check_expr : Exp.t -> Location.t -> Dom.Mem.astate -> PO.ConditionSet.t -> PO.ConditionSet.t = + let check_expr : Exp.t -> Location.t -> Dom.Mem.astate -> PO.ConditionSet.t -> PO.ConditionSet.t + = fun exp location mem cond_set -> let rec check_sub_expr exp cond_set = match exp with @@ -448,9 +483,14 @@ module Report = struct cond_set - let instantiate_cond - : Tenv.t -> Procdesc.t -> (Exp.t * Typ.t) list -> Dom.Mem.astate -> Payload.t -> Location.t - -> PO.ConditionSet.t = + let instantiate_cond : + Tenv.t + -> Procdesc.t + -> (Exp.t * Typ.t) list + -> Dom.Mem.astate + -> Payload.t + -> Location.t + -> PO.ConditionSet.t = fun tenv callee_pdesc params caller_mem summary location -> let callee_symbol_table = Dom.Summary.get_symbol_table summary in let callee_exit_mem = Dom.Summary.get_output summary in @@ -463,9 +503,15 @@ module Report = struct PO.ConditionSet.subst callee_cond bound_subst_map rel_subst_map caller_rel pname location - let check_instr - : Procdesc.t -> Tenv.t -> Itv.SymbolTable.t -> CFG.Node.t -> Sil.instr -> Dom.Mem.astate - -> PO.ConditionSet.t -> PO.ConditionSet.t = + let check_instr : + Procdesc.t + -> Tenv.t + -> Itv.SymbolTable.t + -> CFG.Node.t + -> Sil.instr + -> Dom.Mem.astate + -> PO.ConditionSet.t + -> PO.ConditionSet.t = fun pdesc tenv symbol_table node instr mem cond_set -> match instr with | Sil.Load (_, exp, _, location) | Sil.Store (exp, _, _, location) -> @@ -476,7 +522,7 @@ module Report = struct let node_hash = CFG.Node.hash node in let pname = Procdesc.get_proc_name pdesc in check (Models.mk_model_env pname node_hash location tenv symbol_table) mem cond_set - | None -> + | None -> ( match Ondemand.analyze_proc_name ~caller_pdesc:pdesc callee_pname with | Some callee_summary -> ( match Payload.of_summary callee_summary with @@ -487,7 +533,7 @@ module Report = struct | None -> (* no inferbo payload *) cond_set ) | None -> - (* unknown call *) cond_set ) + (* unknown call *) cond_set ) ) | _ -> cond_set @@ -502,10 +548,17 @@ module Report = struct L.(debug BufferOverrun Verbose) "================================@\n@." - let check_instrs - : Summary.t -> Procdesc.t -> Tenv.t -> Itv.SymbolTable.t -> CFG.t -> CFG.Node.t - -> Instrs.not_reversed_t -> Dom.Mem.astate AbstractInterpreter.state -> PO.ConditionSet.t - -> PO.ConditionSet.t = + let check_instrs : + Summary.t + -> Procdesc.t + -> Tenv.t + -> Itv.SymbolTable.t + -> CFG.t + -> CFG.Node.t + -> Instrs.not_reversed_t + -> Dom.Mem.astate AbstractInterpreter.state + -> PO.ConditionSet.t + -> PO.ConditionSet.t = fun summary pdesc tenv symbol_table cfg node instrs state cond_set -> match state with | _ when Instrs.is_empty instrs -> @@ -528,9 +581,16 @@ module Report = struct cond_set - let check_node - : Summary.t -> Procdesc.t -> Tenv.t -> Itv.SymbolTable.t -> CFG.t -> Analyzer.invariant_map - -> PO.ConditionSet.t -> CFG.Node.t -> PO.ConditionSet.t = + let check_node : + Summary.t + -> Procdesc.t + -> Tenv.t + -> Itv.SymbolTable.t + -> CFG.t + -> Analyzer.invariant_map + -> PO.ConditionSet.t + -> CFG.Node.t + -> PO.ConditionSet.t = fun summary pdesc tenv symbol_table cfg inv_map cond_set node -> match Analyzer.extract_state (CFG.Node.id node) inv_map with | Some state -> @@ -540,9 +600,14 @@ module Report = struct cond_set - let check_proc - : Summary.t -> Procdesc.t -> Tenv.t -> Itv.SymbolTable.t -> CFG.t -> Analyzer.invariant_map - -> PO.ConditionSet.t = + let check_proc : + Summary.t + -> Procdesc.t + -> Tenv.t + -> Itv.SymbolTable.t + -> CFG.t + -> Analyzer.invariant_map + -> PO.ConditionSet.t = fun summary pdesc tenv symbol_table cfg inv_map -> CFG.fold_nodes cfg ~f:(check_node summary pdesc tenv symbol_table cfg inv_map) @@ -646,8 +711,8 @@ let compute_invariant_map_and_check : Callbacks.proc_callback_args -> invariant_ | Some exit_mem -> let post = (Itv.SymbolTable.summary_of symbol_table, exit_mem, cond_set) in ( if Config.bo_debug >= 1 then - let proc_name = Procdesc.get_proc_name proc_desc in - print_summary proc_name post ) ; + let proc_name = Procdesc.get_proc_name proc_desc in + print_summary proc_name post ) ; Payload.update_summary post summary | _ -> summary diff --git a/infer/src/bufferoverrun/bufferOverrunDomain.ml b/infer/src/bufferoverrun/bufferOverrunDomain.ml index 6b1af0175..e63424755 100644 --- a/infer/src/bufferoverrun/bufferOverrunDomain.ml +++ b/infer/src/bufferoverrun/bufferOverrunDomain.ml @@ -72,7 +72,8 @@ module Val = struct let ( <= ) ~lhs ~rhs = if phys_equal lhs rhs then true else - Itv.( <= ) ~lhs:lhs.itv ~rhs:rhs.itv && Relation.Sym.( <= ) ~lhs:lhs.sym ~rhs:rhs.sym + Itv.( <= ) ~lhs:lhs.itv ~rhs:rhs.itv + && Relation.Sym.( <= ) ~lhs:lhs.sym ~rhs:rhs.sym && PowLoc.( <= ) ~lhs:lhs.powloc ~rhs:rhs.powloc && ArrayBlk.( <= ) ~lhs:lhs.arrayblk ~rhs:rhs.arrayblk && Relation.Sym.( <= ) ~lhs:lhs.offset_sym ~rhs:rhs.offset_sym @@ -128,7 +129,7 @@ module Val = struct let set_traces : TraceSet.t -> t -> t = fun traces x -> {x with traces} - let of_itv ?(traces= TraceSet.empty) itv = {bot with itv; traces} + let of_itv ?(traces = TraceSet.empty) itv = {bot with itv; traces} let of_int n = of_itv (Itv.of_int n) @@ -147,10 +148,16 @@ module Val = struct let modify_itv : Itv.t -> t -> t = fun i x -> {x with itv= i} - let make_sym - : ?unsigned:bool -> Loc.t -> Typ.Procname.t -> Itv.SymbolTable.t -> Itv.SymbolPath.partial - -> Itv.Counter.t -> Location.t -> t = - fun ?(unsigned= false) loc pname symbol_table path new_sym_num location -> + let make_sym : + ?unsigned:bool + -> Loc.t + -> Typ.Procname.t + -> Itv.SymbolTable.t + -> Itv.SymbolPath.partial + -> Itv.Counter.t + -> Location.t + -> t = + fun ?(unsigned = false) loc pname symbol_table path new_sym_num location -> { bot with itv= Itv.make_sym ~unsigned pname symbol_table (Itv.SymbolPath.normal path) new_sym_num ; sym= Relation.Sym.of_loc loc @@ -210,9 +217,12 @@ module Val = struct let lift_prune1 : (Itv.t -> Itv.t) -> t -> t = fun f x -> {x with itv= f x.itv} - let lift_prune2 - : (Itv.t -> Itv.t -> Itv.t) -> (ArrayBlk.astate -> ArrayBlk.astate -> ArrayBlk.astate) -> t - -> t -> t = + let lift_prune2 : + (Itv.t -> Itv.t -> Itv.t) + -> (ArrayBlk.astate -> ArrayBlk.astate -> ArrayBlk.astate) + -> t + -> t + -> t = fun f g x y -> { x with itv= f x.itv y.itv @@ -232,7 +242,7 @@ module Val = struct let prune_ne : t -> t -> t = lift_prune2 Itv.prune_ne ArrayBlk.prune_ne - let is_pointer_to_non_array x = not (PowLoc.is_bot x.powloc) && ArrayBlk.is_bot x.arrayblk + let is_pointer_to_non_array x = (not (PowLoc.is_bot x.powloc)) && ArrayBlk.is_bot x.arrayblk (* In the pointer arithmetics, it returns top, if we cannot precisely follow the physical memory model, e.g., (&x + 1). *) @@ -264,9 +274,11 @@ module Val = struct fun x -> {x with itv= Itv.normalize x.itv; arrayblk= ArrayBlk.normalize x.arrayblk} - let subst - : t -> Itv.Bound.t bottom_lifted Itv.SymbolMap.t * TraceSet.t Itv.SymbolMap.t -> Location.t - -> t = + let subst : + t + -> Itv.Bound.t bottom_lifted Itv.SymbolMap.t * TraceSet.t Itv.SymbolMap.t + -> Location.t + -> t = fun x (bound_map, trace_map) location -> let symbols = get_symbols x in let traces_caller = @@ -331,7 +343,7 @@ end module AliasTarget = struct type t = Simple of Loc.t | Empty of Loc.t [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let pp fmt = function Simple l -> Loc.pp fmt l | Empty l -> F.fprintf fmt "empty(%a)" Loc.pp l @@ -709,8 +721,8 @@ module MemReach = struct {m with mem_pure= MemPure.add x v m.mem_pure} - let add_unknown_from - : Ident.t -> callee_pname:Typ.Procname.t option -> location:Location.t -> t -> t = + let add_unknown_from : + Ident.t -> callee_pname:Typ.Procname.t option -> location:Location.t -> t -> t = fun id ~callee_pname ~location m -> let val_unknown = Val.unknown_from ~callee_pname ~location in add_stack (Loc.of_id id) val_unknown m |> add_heap Loc.unknown val_unknown @@ -819,9 +831,11 @@ module MemReach = struct fun constrs -> lift_relation (Relation.meet_constraints constrs) - let store_relation - : PowLoc.t -> Relation.SymExp.t option * Relation.SymExp.t option * Relation.SymExp.t option - -> t -> t = + let store_relation : + PowLoc.t + -> Relation.SymExp.t option * Relation.SymExp.t option * Relation.SymExp.t option + -> t + -> t = fun locs symexp_opts -> lift_relation (Relation.store_relation locs symexp_opts) @@ -829,9 +843,9 @@ module MemReach = struct let init_param_relation : Loc.t -> t -> t = fun loc -> lift_relation (Relation.init_param loc) - let init_array_relation - : Allocsite.t -> offset:Itv.t -> size:Itv.t -> size_exp_opt:Relation.SymExp.t option -> t - -> t = + let init_array_relation : + Allocsite.t -> offset:Itv.t -> size:Itv.t -> size_exp_opt:Relation.SymExp.t option -> t -> t + = fun allocsite ~offset ~size ~size_exp_opt -> lift_relation (Relation.init_array allocsite ~offset ~size ~size_exp_opt) @@ -956,9 +970,11 @@ module Mem = struct let is_relation_unsat m = f_lift_default ~default:true MemReach.is_relation_unsat m - let store_relation - : PowLoc.t -> Relation.SymExp.t option * Relation.SymExp.t option * Relation.SymExp.t option - -> t -> t = + let store_relation : + PowLoc.t + -> Relation.SymExp.t option * Relation.SymExp.t option * Relation.SymExp.t option + -> t + -> t = fun locs symexp_opts -> f_lift (MemReach.store_relation locs symexp_opts) @@ -966,9 +982,9 @@ module Mem = struct let init_param_relation : Loc.t -> t -> t = fun loc -> f_lift (MemReach.init_param_relation loc) - let init_array_relation - : Allocsite.t -> offset:Itv.t -> size:Itv.t -> size_exp_opt:Relation.SymExp.t option -> t - -> t = + let init_array_relation : + Allocsite.t -> offset:Itv.t -> size:Itv.t -> size_exp_opt:Relation.SymExp.t option -> t -> t + = fun allocsite ~offset ~size ~size_exp_opt -> f_lift (MemReach.init_array_relation allocsite ~offset ~size ~size_exp_opt) diff --git a/infer/src/bufferoverrun/bufferOverrunDomainRelation.ml b/infer/src/bufferoverrun/bufferOverrunDomainRelation.ml index cf6097359..dbe4b5031 100644 --- a/infer/src/bufferoverrun/bufferOverrunDomainRelation.ml +++ b/infer/src/bufferoverrun/bufferOverrunDomainRelation.ml @@ -49,8 +49,11 @@ module type S = sig val of_exp : get_sym_f:(Exp.t -> Sym.astate) -> Exp.t -> t option val of_exps : - get_int_sym_f:(Exp.t -> Sym.astate) -> get_offset_sym_f:(Exp.t -> Sym.astate) - -> get_size_sym_f:(Exp.t -> Sym.astate) -> Exp.t -> t option * t option * t option + get_int_sym_f:(Exp.t -> Sym.astate) + -> get_offset_sym_f:(Exp.t -> Sym.astate) + -> get_size_sym_f:(Exp.t -> Sym.astate) + -> Exp.t + -> t option * t option * t option val of_exp_opt : get_sym_f:(Exp.t -> Sym.astate) -> Exp.t option -> t option @@ -746,7 +749,8 @@ module Make (Manager : Manager_S) = struct Option.map (raw_size_of_exp ~get_size_sym_f e) ~f:of_raw - let of_exps ~get_int_sym_f ~get_offset_sym_f ~get_size_sym_f e : t option * t option * t option = + let of_exps ~get_int_sym_f ~get_offset_sym_f ~get_size_sym_f e : t option * t option * t option + = let int_sym = of_exp ~get_sym_f:get_int_sym_f e in let offset_sym = offset_of_exp ~get_int_sym_f ~get_offset_sym_f e in let size_sym = size_of_exp ~get_size_sym_f e in @@ -831,8 +835,8 @@ module Make (Manager : Manager_S) = struct Option.map (symexp_raw_subst subst_map re) ~f:(fun re' -> Texpr1.Unop (uop, re', typ, round) ) | Texpr1.Binop (bop, re1, re2, typ, round) -> - Option.map2 (symexp_raw_subst subst_map re1) (symexp_raw_subst subst_map re2) ~f: - (fun re1' re2' -> Texpr1.Binop (bop, re1', re2', typ, round) ) + Option.map2 (symexp_raw_subst subst_map re1) (symexp_raw_subst subst_map re2) + ~f:(fun re1' re2' -> Texpr1.Binop (bop, re1', re2', typ, round) ) let symexp_subst subst_map x = @@ -865,8 +869,12 @@ module Make (Manager : Manager_S) = struct let x, y = (Tcons1.array_extend_environment x env, Tcons1.array_extend_environment y env) in let len1, len2 = (Tcons1.array_length x, Tcons1.array_length y) in let tcons_array = Tcons1.array_make env (len1 + len2) in - for i = 0 to len1 - 1 do Tcons1.array_set tcons_array i (Tcons1.array_get x i) done ; - for i = 0 to len2 - 1 do Tcons1.array_set tcons_array (len1 + i) (Tcons1.array_get y i) done ; + for i = 0 to len1 - 1 do + Tcons1.array_set tcons_array i (Tcons1.array_get x i) + done ; + for i = 0 to len2 - 1 do + Tcons1.array_set tcons_array (len1 + i) (Tcons1.array_get y i) + done ; tcons_array @@ -1021,8 +1029,7 @@ module Make (Manager : Manager_S) = struct Some (Tcons1.make symexp Tcons1.DISEQ) | Tcons1.DISEQ -> Some (Tcons1.make symexp Tcons1.EQ) - | Tcons1.SUPEQ | Tcons1.SUP - -> ( + | Tcons1.SUPEQ | Tcons1.SUP -> ( let env = Tcons1.get_env constr in let neg_symexp = Texpr1.of_expr env (SymExp.raw_uop_make Texpr1.Neg (Texpr1.to_expr symexp)) @@ -1119,7 +1126,8 @@ module Make (Manager : Manager_S) = struct fun ~forget_free subst_map x -> let vars_in_subst_map = SubstMap.fold subst_map ~init:VarSet.empty ~f:(fun var sym_exp_opt acc -> - acc |> VarSet.add var |> VarSet.add (Var.param_of var) + acc |> VarSet.add var + |> VarSet.add (Var.param_of var) |> VarSet.union (SymExp.vars_set_of_opt sym_exp_opt) ) in let new_env = Env.of_vars_set vars_in_subst_map in @@ -1468,12 +1476,12 @@ module Make (Manager : Manager_S) = struct match size_exp_opt with | None -> Constraints.itv_of size_sym size - | Some size_exp -> + | Some size_exp -> ( match Constraints.eq_of_sym size_sym size_exp with | None -> Constraints.itv_of size_sym size | Some constr -> - constr + constr ) in meet_constraints (Constraints.and_ offset_constrs size_constrs) x @@ -1517,16 +1525,16 @@ module Make (Manager : Manager_S) = struct match subst_param_caller subst_map caller with | Bottom -> Bottom - | NonBottom caller -> + | NonBottom caller -> ( match subst_callee subst_map callee with | Bottom -> Bottom - | NonBottom callee -> + | NonBottom callee -> ( match meet caller callee with | Bottom -> Bottom | NonBottom relation -> - NonBottom (forget_temp_param subst_map relation) + NonBottom (forget_temp_param subst_map relation) ) ) end include AbstractDomain.BottomLifted (PackedVal) @@ -1574,8 +1582,8 @@ module Make (Manager : Manager_S) = struct fun constrs -> lift_default ~default:Bottom (PackedVal.meet_constraints constrs) - let store_relation - : PowLoc.t -> SymExp.t option * SymExp.t option * SymExp.t option -> astate -> astate = + let store_relation : + PowLoc.t -> SymExp.t option * SymExp.t option * SymExp.t option -> astate -> astate = fun locs texpr_opts -> lift_default ~default:Bottom (PackedVal.store_relation locs texpr_opts) @@ -1583,9 +1591,9 @@ module Make (Manager : Manager_S) = struct fun loc -> lift_default ~default:Bottom (PackedVal.init_param loc) - let init_array - : Allocsite.t -> offset:Itv.t -> size:Itv.t -> size_exp_opt:SymExp.t option -> astate - -> astate = + let init_array : + Allocsite.t -> offset:Itv.t -> size:Itv.t -> size_exp_opt:SymExp.t option -> astate -> astate + = fun allocsite ~offset ~size ~size_exp_opt -> lift_default ~default:Bottom (PackedVal.init_array allocsite ~offset ~size ~size_exp_opt) @@ -1615,8 +1623,7 @@ include ( val match Config.bo_relational_domain with | Some `Bo_relational_domain_oct -> (module Make (ApronOctagonManager) : S) | Some `Bo_relational_domain_poly -> - (module Make (ElinaPolyManager) : S) -) + (module Make (ElinaPolyManager) : S) ) (* NOTE: Globally only one manager (of a relational domain depends on Apron) can set deserialization functions. *) diff --git a/infer/src/bufferoverrun/bufferOverrunModels.ml b/infer/src/bufferoverrun/bufferOverrunModels.ml index eaba97227..cedefbe30 100644 --- a/infer/src/bufferoverrun/bufferOverrunModels.ml +++ b/infer/src/bufferoverrun/bufferOverrunModels.ml @@ -35,13 +35,25 @@ type check_fun = model_env -> Dom.Mem.astate -> PO.ConditionSet.t -> PO.Conditio type model = {exec: exec_fun; check: check_fun} type declare_local_fun = - decl_local:BoUtils.Exec.decl_local -> model_env -> Loc.t -> inst_num:int -> dimension:int - -> Dom.Mem.astate -> Dom.Mem.astate * int + decl_local:BoUtils.Exec.decl_local + -> model_env + -> Loc.t + -> inst_num:int + -> dimension:int + -> Dom.Mem.astate + -> Dom.Mem.astate * int type declare_symbolic_fun = - decl_sym_val:BoUtils.Exec.decl_sym_val -> Itv.SymbolPath.partial -> model_env -> depth:int - -> Loc.t -> inst_num:int -> new_sym_num:Itv.Counter.t -> new_alloc_num:Itv.Counter.t - -> Dom.Mem.astate -> Dom.Mem.astate + decl_sym_val:BoUtils.Exec.decl_sym_val + -> Itv.SymbolPath.partial + -> model_env + -> depth:int + -> Loc.t + -> inst_num:int + -> new_sym_num:Itv.Counter.t + -> new_alloc_num:Itv.Counter.t + -> Dom.Mem.astate + -> Dom.Mem.astate type typ_model = {declare_local: declare_local_fun; declare_symbolic: declare_symbolic_fun} @@ -57,8 +69,8 @@ let get_malloc_info : Exp.t -> Typ.t * Int.t option * Exp.t * Exp.t option = fun | Exp.BinOp (Binop.Mult, length, Exp.Sizeof {typ; nbytes}) -> (typ, nbytes, length, None) (* In Java all arrays are dynamically allocated *) - | Exp.Sizeof {typ; nbytes; dynamic_length= Some arr_length} - when Language.curr_language_is Java -> + | Exp.Sizeof {typ; nbytes; dynamic_length= Some arr_length} when Language.curr_language_is Java + -> (typ, nbytes, arr_length, Some arr_length) | Exp.Sizeof {typ; nbytes; dynamic_length} -> (typ, nbytes, Exp.one, dynamic_length) @@ -80,7 +92,7 @@ let check_alloc_size size_exp {location} mem cond_set = PO.ConditionSet.add_alloc_size location ~length traces cond_set -let set_uninitialized location (typ: Typ.t) ploc mem = +let set_uninitialized location (typ : Typ.t) ploc mem = match typ.desc with | Tint _ | Tfloat _ -> Dom.Mem.weak_update ploc Dom.Val.Itv.top mem @@ -104,7 +116,8 @@ let malloc size_exp = Relation.SymExp.of_exp ~get_sym_f:(Sem.get_sym_f mem) size_exp in let v = Dom.Val.of_array_alloc allocsite ~stride ~offset ~size |> Dom.Val.set_traces traces in - mem |> Dom.Mem.add_stack (Loc.of_id id) v + mem + |> Dom.Mem.add_stack (Loc.of_id id) v |> Dom.Mem.init_array_relation allocsite ~offset ~size ~size_exp_opt |> set_uninitialized location typ (Dom.Val.get_array_locs v) |> BoUtils.Exec.init_array_fields tenv pname ~node_hash typ (Dom.Val.get_array_locs v) @@ -120,7 +133,8 @@ let realloc src_exp size_exp = let length = Sem.eval length0 mem in let traces = TraceSet.add_elem (Trace.ArrDecl location) (Dom.Val.get_traces length) in let v = - Sem.eval src_exp mem |> Dom.Val.set_array_size (Dom.Val.get_itv length) + Sem.eval src_exp mem + |> Dom.Val.set_array_size (Dom.Val.get_itv length) |> Dom.Val.set_traces traces in let mem = Dom.Mem.add_stack (Loc.of_id id) v mem in @@ -198,7 +212,8 @@ let set_array_length array length_exp = let stride = Option.map ~f:IntLit.to_int_exn stride in let allocsite = Allocsite.make pname ~node_hash ~inst_num:0 ~dimension:1 in let v = Dom.Val.of_array_alloc allocsite ~stride ~offset:Itv.zero ~size:length in - mem |> Dom.Mem.add_stack (Loc.of_pvar array_pvar) v + mem + |> Dom.Mem.add_stack (Loc.of_pvar array_pvar) v |> set_uninitialized location elt (Dom.Val.get_array_locs v) | _ -> L.(die InternalError) "Unexpected type of first argument for __set_array_length() " @@ -383,7 +398,7 @@ module Collection = struct {exec; check= no_check} - let add_at_index (alist_id: Ident.t) index_exp = + let add_at_index (alist_id : Ident.t) index_exp = let check {location} mem cond_set = let array_exp = Exp.Var alist_id in BoUtils.Check.collection_access ~array_exp ~index_exp ~is_collection_add:true mem location @@ -436,7 +451,8 @@ module Call = struct ; -"fgetc" <>--> by_value Dom.Val.Itv.m1_255 ; -"infer_print" <>$ capt_exp $!--> infer_print ; -"malloc" <>$ capt_exp $+...$--> malloc - ; -"__new" <>$ capt_exp_of_typ (+PatternMatch.implements_collection) + ; -"__new" + <>$ capt_exp_of_typ (+PatternMatch.implements_collection) $+...$--> Collection.new_list ; -"__new" <>$ capt_exp $+...$--> malloc ; -"__new_array" <>$ capt_exp $+...$--> malloc @@ -445,30 +461,32 @@ module Call = struct ; -"__get_array_length" <>$ capt_exp $!--> get_array_length ; -"__set_array_length" <>$ capt_arg $+ capt_exp $!--> set_array_length ; -"strlen" <>--> by_value Dom.Val.Itv.nat - ; -"boost" &:: "split" $ capt_arg_of_typ (-"std" &:: "vector") $+ any_arg $+ any_arg - $+? any_arg $--> Boost.Split.std_vector - ; -"folly" &:: "split" $ any_arg $+ any_arg $+ capt_arg_of_typ (-"std" &:: "vector") + ; -"boost" &:: "split" + $ capt_arg_of_typ (-"std" &:: "vector") + $+ any_arg $+ any_arg $+? any_arg $--> Boost.Split.std_vector + ; -"folly" &:: "split" $ any_arg $+ any_arg + $+ capt_arg_of_typ (-"std" &:: "vector") $+? capt_exp $--> Folly.Split.std_vector ; std_array0 >:: "array" &--> StdArray.constructor ; std_array2 >:: "at" $ capt_arg $+ capt_arg $!--> StdArray.at ; std_array2 >:: "operator[]" $ capt_arg $+ capt_arg $!--> StdArray.at ; -"std" &:: "array" &::.*--> StdArray.no_model - ; +PatternMatch.implements_collection &:: "get" <>$ capt_var_exn $+ capt_exp - $--> Collection.get_or_set_at_index - ; +PatternMatch.implements_collection &:: "set" <>$ capt_var_exn $+ capt_exp $+ any_arg - $--> Collection.get_or_set_at_index - ; +PatternMatch.implements_collection &:: "remove" <>$ capt_var_exn $+ capt_exp - $--> Collection.remove_at_index - ; +PatternMatch.implements_collection &:: "add" <>$ capt_var_exn $+ any_arg - $--> Collection.add - ; +PatternMatch.implements_collection &:: "add" <>$ capt_var_exn $+ capt_exp $+ any_arg - $!--> Collection.add_at_index + ; +PatternMatch.implements_collection + &:: "get" <>$ capt_var_exn $+ capt_exp $--> Collection.get_or_set_at_index + ; +PatternMatch.implements_collection + &:: "set" <>$ capt_var_exn $+ capt_exp $+ any_arg $--> Collection.get_or_set_at_index + ; +PatternMatch.implements_collection + &:: "remove" <>$ capt_var_exn $+ capt_exp $--> Collection.remove_at_index + ; +PatternMatch.implements_collection + &:: "add" <>$ capt_var_exn $+ any_arg $--> Collection.add + ; +PatternMatch.implements_collection + &:: "add" <>$ capt_var_exn $+ capt_exp $+ any_arg $!--> Collection.add_at_index ; +PatternMatch.implements_collection &:: "iterator" <>$ capt_exp $!--> Collection.iterator ; +PatternMatch.implements_iterator &:: "hasNext" <>$ capt_exp $!--> Collection.hasNext - ; +PatternMatch.implements_collection &:: "addAll" <>$ capt_var_exn $+ capt_exp - $--> Collection.addAll - ; +PatternMatch.implements_collection &:: "addAll" <>$ capt_var_exn $+ capt_exp $+ capt_exp - $!--> Collection.addAll_at_index + ; +PatternMatch.implements_collection + &:: "addAll" <>$ capt_var_exn $+ capt_exp $--> Collection.addAll + ; +PatternMatch.implements_collection + &:: "addAll" <>$ capt_var_exn $+ capt_exp $+ capt_exp $!--> Collection.addAll_at_index ; +PatternMatch.implements_collection &:: "size" <>$ capt_exp $!--> Collection.size ] end diff --git a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml index c83e9bfc3..62ed2614c 100644 --- a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml +++ b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml @@ -67,7 +67,7 @@ module AllocSizeCondition = struct {report_issue_type= Some IssueType.inferbo_alloc_is_zero; propagate= false} | `LeftSmallerThanRight -> {report_issue_type= Some IssueType.inferbo_alloc_is_negative; propagate= false} - | _ -> + | _ -> ( let is_symbolic = ItvPure.is_symbolic length in match ItvPure.xcompare ~lhs:length ~rhs:ItvPure.mone with | `Equal | `LeftSmallerThanRight | `RightSubsumesLeft -> @@ -75,7 +75,7 @@ module AllocSizeCondition = struct | `LeftSubsumesRight when Bound.is_not_infty (ItvPure.lb length) -> { report_issue_type= Some IssueType.inferbo_alloc_may_be_negative ; propagate= is_symbolic } - | cmp_mone -> + | cmp_mone -> ( match ItvPure.xcompare ~lhs:length ~rhs:itv_big with | `Equal | `RightSmallerThanLeft | `RightSubsumesLeft -> {report_issue_type= Some IssueType.inferbo_alloc_is_big; propagate= false} @@ -90,7 +90,7 @@ module AllocSizeCondition = struct | _ -> false in - {report_issue_type= None; propagate} + {report_issue_type= None; propagate} ) ) let subst bound_map length = @@ -129,9 +129,13 @@ module ArrayAccessCondition = struct F.fprintf fmt "Offset: %a Size: %a" ItvPure.pp c.idx ItvPure.pp c.size - let make - : idx:ItvPure.t -> size:ItvPure.t -> idx_sym_exp:Relation.SymExp.t option - -> size_sym_exp:Relation.SymExp.t option -> relation:Relation.astate -> t option = + let make : + idx:ItvPure.t + -> size:ItvPure.t + -> idx_sym_exp:Relation.SymExp.t option + -> size_sym_exp:Relation.SymExp.t option + -> relation:Relation.astate + -> t option = fun ~idx ~size ~idx_sym_exp ~size_sym_exp ~relation -> if ItvPure.is_invalid idx || ItvPure.is_invalid size then None else Some {idx; size; idx_sym_exp; size_sym_exp; relation} @@ -191,13 +195,14 @@ module ArrayAccessCondition = struct let filter1 : t -> bool = fun c -> ItvPure.is_top c.idx || ItvPure.is_top c.size || ItvPure.is_lb_infty c.idx - || ItvPure.is_lb_infty c.size || (ItvPure.is_nat c.idx && ItvPure.is_nat c.size) + || ItvPure.is_lb_infty c.size + || (ItvPure.is_nat c.idx && ItvPure.is_nat c.size) let filter2 : t -> bool = fun c -> (* basically, alarms involving infinity are filtered *) - (not (ItvPure.is_finite c.idx) || not (ItvPure.is_finite c.size)) + ((not (ItvPure.is_finite c.idx)) || not (ItvPure.is_finite c.size)) && (* except the following cases *) not ( Bound.is_not_infty (ItvPure.lb c.idx) @@ -260,9 +265,12 @@ module ArrayAccessCondition = struct {report_issue_type; propagate= is_symbolic} - let subst - : Itv.Bound.t bottom_lifted Itv.SymbolMap.t -> Relation.SubstMap.t -> Relation.astate -> t - -> t option = + let subst : + Itv.Bound.t bottom_lifted Itv.SymbolMap.t + -> Relation.SubstMap.t + -> Relation.astate + -> t + -> t option = fun bound_map rel_map caller_relation c -> match (ItvPure.subst c.idx bound_map, ItvPure.subst c.size bound_map) with | NonBottom idx, NonBottom size -> @@ -426,7 +434,7 @@ module Reported = struct let make issue_type = issue_type - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] end module ConditionWithTrace = struct @@ -488,7 +496,7 @@ module ConditionWithTrace = struct let check_aux cwt = - let {report_issue_type; propagate} as checked = Condition.check cwt.cond in + let ({report_issue_type; propagate} as checked) = Condition.check cwt.cond in match report_issue_type with | None -> checked @@ -555,7 +563,7 @@ module ConditionSet = struct L.(debug BufferOverrun Verbose) "[InferboPO] Adding new condition %a@." ConditionWithTrace.pp new_ ; if same then new_ :: condset else new_ :: acc - | existing :: rest as existings -> + | existing :: rest as existings -> ( match try_merge ~existing ~new_ with | `DoNotAddAndStop -> if Config.bo_debug >= 3 then @@ -570,7 +578,7 @@ module ConditionSet = struct existing ConditionWithTrace.pp new_ ; aux ~new_ acc ~same:false rest | `KeepExistingAndContinue -> - aux ~new_ (existing :: acc) ~same rest + aux ~new_ (existing :: acc) ~same rest ) in aux ~new_ [] ~same:true condset @@ -589,7 +597,8 @@ module ConditionSet = struct let add_array_access location ~idx ~size ~is_collection_add ~idx_sym_exp ~size_sym_exp ~relation val_traces condset = ArrayAccessCondition.make ~idx ~size ~idx_sym_exp ~size_sym_exp ~relation - |> Condition.make_array_access ~is_collection_add |> add_opt location val_traces condset + |> Condition.make_array_access ~is_collection_add + |> add_opt location val_traces condset let add_alloc_size location ~length val_traces condset = diff --git a/infer/src/bufferoverrun/bufferOverrunProofObligations.mli b/infer/src/bufferoverrun/bufferOverrunProofObligations.mli index 79a042916..56f8fcbcd 100644 --- a/infer/src/bufferoverrun/bufferOverrunProofObligations.mli +++ b/infer/src/bufferoverrun/bufferOverrunProofObligations.mli @@ -35,17 +35,29 @@ module ConditionSet : sig val pp_summary : Format.formatter -> summary_t -> unit val add_array_access : - Location.t -> idx:ItvPure.astate -> size:ItvPure.astate -> is_collection_add:bool - -> idx_sym_exp:Relation.SymExp.t option -> size_sym_exp:Relation.SymExp.t option - -> relation:Relation.astate -> ValTraceSet.t -> t -> t + Location.t + -> idx:ItvPure.astate + -> size:ItvPure.astate + -> is_collection_add:bool + -> idx_sym_exp:Relation.SymExp.t option + -> size_sym_exp:Relation.SymExp.t option + -> relation:Relation.astate + -> ValTraceSet.t + -> t + -> t val add_alloc_size : Location.t -> length:ItvPure.astate -> ValTraceSet.t -> t -> t val join : t -> t -> t val subst : - summary_t -> Bounds.Bound.t bottom_lifted Symb.SymbolMap.t * ValTraceSet.t Symb.SymbolMap.t - -> Relation.SubstMap.t -> Relation.astate -> Typ.Procname.t -> Location.t -> t + summary_t + -> Bounds.Bound.t bottom_lifted Symb.SymbolMap.t * ValTraceSet.t Symb.SymbolMap.t + -> Relation.SubstMap.t + -> Relation.astate + -> Typ.Procname.t + -> Location.t + -> t val check_all : report:(Condition.t -> ConditionTrace.t -> IssueType.t -> unit) -> t -> t (** Check the conditions, call [report] on those that trigger an issue, returns those that needs to be propagated to callers. *) diff --git a/infer/src/bufferoverrun/bufferOverrunSemantics.ml b/infer/src/bufferoverrun/bufferOverrunSemantics.ml index 0cd61a0b1..98813f2f5 100644 --- a/infer/src/bufferoverrun/bufferOverrunSemantics.ml +++ b/infer/src/bufferoverrun/bufferOverrunSemantics.ml @@ -366,7 +366,8 @@ module Prune = struct let is_unreachable_constant : Exp.t -> Mem.astate -> bool = fun e m -> let v = eval e m in - Itv.( <= ) ~lhs:(Val.get_itv v) ~rhs:(Itv.of_int 0) && PowLoc.is_bot (Val.get_pow_loc v) + Itv.( <= ) ~lhs:(Val.get_itv v) ~rhs:(Itv.of_int 0) + && PowLoc.is_bot (Val.get_pow_loc v) && ArrayBlk.is_bot (Val.get_array_blk v) @@ -390,7 +391,8 @@ module Prune = struct | Exp.BinOp (Binop.LAnd, e1, e2) -> astate |> prune_helper e1 |> prune_helper e2 | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) -> - astate |> prune_helper (Exp.UnOp (Unop.LNot, e1, t)) + astate + |> prune_helper (Exp.UnOp (Unop.LNot, e1, t)) |> prune_helper (Exp.UnOp (Unop.LNot, e2, t)) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Lt as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Gt as c), e1, e2), _) @@ -420,12 +422,19 @@ let get_formals : Procdesc.t -> (Pvar.t * Typ.t) list = Procdesc.get_formals pdesc |> List.map ~f:(fun (name, typ) -> (Pvar.mk name proc_name, typ)) -let get_matching_pairs - : Tenv.t -> Itv.SymbolPath.partial -> Val.t -> Val.t -> Exp.t option -> Typ.t -> Mem.astate - -> Itv.SymbolTable.summary_t -> Mem.astate - -> (Itv.Symbol.t * Itv.Bound.t bottom_lifted * TraceSet.t) list - * AliasTarget.t option - * (Relation.Var.t * Relation.SymExp.t option) list = +let get_matching_pairs : + Tenv.t + -> Itv.SymbolPath.partial + -> Val.t + -> Val.t + -> Exp.t option + -> Typ.t + -> Mem.astate + -> Itv.SymbolTable.summary_t + -> Mem.astate + -> (Itv.Symbol.t * Itv.Bound.t bottom_lifted * TraceSet.t) list + * AliasTarget.t option + * (Relation.Var.t * Relation.SymExp.t option) list = fun tenv formal callee_v actual actual_exp_opt typ caller_mem callee_symbol_table callee_exit_mem -> let open Itv in let callee_ret_alias = Mem.find_ret_alias callee_exit_mem in @@ -477,12 +486,14 @@ let get_matching_pairs let add_pair_val path1 v1 v2 ~e2_opt (bound_pairs, rel_pairs) = add_ret_alias (Val.get_all_locs v1) (Val.get_all_locs v2) ; let bound_pairs = - bound_pairs |> add_pair_itv (SymbolPath.normal path1) (get_itv v2) (Val.get_traces v2) + bound_pairs + |> add_pair_itv (SymbolPath.normal path1) (get_itv v2) (Val.get_traces v2) |> add_pair_itv (SymbolPath.offset path1) (get_offset v2) (Val.get_traces v2) |> add_pair_itv (SymbolPath.length path1) (get_size v2) (Val.get_traces v2) in let rel_pairs = - rel_pairs |> add_pair_sym_main_value v1 v2 ~e2_opt + rel_pairs + |> add_pair_sym_main_value v1 v2 ~e2_opt |> add_pair_sym (get_offset_sym v1) (get_offset_sym v2) |> add_pair_sym (get_size_sym v1) (get_size_sym v2) in @@ -514,15 +525,16 @@ let get_matching_pairs pairs in let bound_pairs, rel_pairs = - ([], []) |> add_pair_val formal callee_v actual ~e2_opt:actual_exp_opt + ([], []) + |> add_pair_val formal callee_v actual ~e2_opt:actual_exp_opt |> add_pair_ptr typ formal callee_v actual in (bound_pairs, !ret_alias, rel_pairs) -let subst_map_of_bound_pairs - : (Itv.Symbol.t * Itv.Bound.t bottom_lifted * TraceSet.t) list - -> Itv.Bound.t bottom_lifted Itv.SymbolMap.t * TraceSet.t Itv.SymbolMap.t = +let subst_map_of_bound_pairs : + (Itv.Symbol.t * Itv.Bound.t bottom_lifted * TraceSet.t) list + -> Itv.Bound.t bottom_lifted Itv.SymbolMap.t * TraceSet.t Itv.SymbolMap.t = fun pairs -> let add_pair (bound_map, trace_map) (formal, actual, traces) = (Itv.SymbolMap.add formal actual bound_map, Itv.SymbolMap.add formal traces trace_map) @@ -530,16 +542,20 @@ let subst_map_of_bound_pairs List.fold ~f:add_pair ~init:(Itv.SymbolMap.empty, Itv.SymbolMap.empty) pairs -let subst_map_of_rel_pairs - : (Relation.Var.t * Relation.SymExp.t option) list -> Relation.SubstMap.t = +let subst_map_of_rel_pairs : + (Relation.Var.t * Relation.SymExp.t option) list -> Relation.SubstMap.t = fun pairs -> let add_pair rel_map (x, e) = Relation.SubstMap.add x e rel_map in List.fold pairs ~init:Relation.SubstMap.empty ~f:add_pair -let rec list_fold2_def - : default:Val.t * Exp.t option -> f:('a -> Val.t * Exp.t option -> 'b -> 'b) -> 'a list - -> (Val.t * Exp.t option) list -> init:'b -> 'b = +let rec list_fold2_def : + default:Val.t * Exp.t option + -> f:('a -> Val.t * Exp.t option -> 'b -> 'b) + -> 'a list + -> (Val.t * Exp.t option) list + -> init:'b + -> 'b = fun ~default ~f xs ys ~init:acc -> match (xs, ys) with | [], _ -> @@ -554,12 +570,16 @@ let rec list_fold2_def list_fold2_def ~default ~f xs' ys' ~init:(f x y acc) -let get_subst_map - : Tenv.t -> Procdesc.t -> (Exp.t * 'a) list -> Mem.astate -> Itv.SymbolTable.summary_t - -> Mem.astate - -> (Itv.Bound.t bottom_lifted Itv.SymbolMap.t * TraceSet.t Itv.SymbolMap.t) - * AliasTarget.t option - * Relation.SubstMap.t = +let get_subst_map : + Tenv.t + -> Procdesc.t + -> (Exp.t * 'a) list + -> Mem.astate + -> Itv.SymbolTable.summary_t + -> Mem.astate + -> (Itv.Bound.t bottom_lifted Itv.SymbolMap.t * TraceSet.t Itv.SymbolMap.t) + * AliasTarget.t option + * Relation.SubstMap.t = fun tenv callee_pdesc params caller_mem callee_symbol_table callee_exit_mem -> let add_pair (formal, typ) (actual, actual_exp) (bound_l, ret_alias, rel_l) = let callee_v = Mem.find (Loc.of_pvar formal) callee_exit_mem in diff --git a/infer/src/bufferoverrun/bufferOverrunUtils.ml b/infer/src/bufferoverrun/bufferOverrunUtils.ml index 664ea93dd..5807a70fa 100644 --- a/infer/src/bufferoverrun/bufferOverrunUtils.ml +++ b/infer/src/bufferoverrun/bufferOverrunUtils.ml @@ -31,13 +31,29 @@ module Exec = struct type decl_local = - Typ.Procname.t -> node_hash:int -> Location.t -> Loc.t -> Typ.t -> inst_num:int - -> dimension:int -> Dom.Mem.astate -> Dom.Mem.astate * int + Typ.Procname.t + -> node_hash:int + -> Location.t + -> Loc.t + -> Typ.t + -> inst_num:int + -> dimension:int + -> Dom.Mem.astate + -> Dom.Mem.astate * int - let decl_local_array - : decl_local:decl_local -> Typ.Procname.t -> node_hash:int -> Location.t -> Loc.t -> Typ.t - -> length:IntLit.t option -> ?stride:int -> inst_num:int -> dimension:int -> Dom.Mem.astate - -> Dom.Mem.astate * int = + let decl_local_array : + decl_local:decl_local + -> Typ.Procname.t + -> node_hash:int + -> Location.t + -> Loc.t + -> Typ.t + -> length:IntLit.t option + -> ?stride:int + -> inst_num:int + -> dimension:int + -> Dom.Mem.astate + -> Dom.Mem.astate * int = fun ~decl_local pname ~node_hash location loc typ ~length ?stride ~inst_num ~dimension mem -> let offset = Itv.zero in let size = Option.value_map ~default:Itv.top ~f:Itv.of_int_lit length in @@ -57,9 +73,15 @@ module Exec = struct (mem, inst_num + 1) - let decl_local_collection - : Typ.Procname.t -> node_hash:int -> Location.t -> Loc.t -> inst_num:int -> dimension:int - -> Dom.Mem.astate -> Dom.Mem.astate * int = + let decl_local_collection : + Typ.Procname.t + -> node_hash:int + -> Location.t + -> Loc.t + -> inst_num:int + -> dimension:int + -> Dom.Mem.astate + -> Dom.Mem.astate * int = fun pname ~node_hash location loc ~inst_num ~dimension mem -> let allocsite = Allocsite.make pname ~node_hash ~inst_num ~dimension in let alloc_loc = Loc.of_allocsite allocsite in @@ -76,14 +98,35 @@ module Exec = struct type decl_sym_val = - Typ.Procname.t -> Itv.SymbolPath.partial -> Tenv.t -> node_hash:int -> Location.t -> depth:int - -> Loc.t -> Typ.t -> Dom.Mem.astate -> Dom.Mem.astate - - let decl_sym_arr - : decl_sym_val:decl_sym_val -> Typ.Procname.t -> Itv.SymbolTable.t -> Itv.SymbolPath.partial - -> Tenv.t -> node_hash:int -> Location.t -> depth:int -> Loc.t -> Typ.t -> ?offset:Itv.t - -> ?size:Itv.t -> inst_num:int -> new_sym_num:Itv.Counter.t -> new_alloc_num:Itv.Counter.t - -> Dom.Mem.astate -> Dom.Mem.astate = + Typ.Procname.t + -> Itv.SymbolPath.partial + -> Tenv.t + -> node_hash:int + -> Location.t + -> depth:int + -> Loc.t + -> Typ.t + -> Dom.Mem.astate + -> Dom.Mem.astate + + let decl_sym_arr : + decl_sym_val:decl_sym_val + -> Typ.Procname.t + -> Itv.SymbolTable.t + -> Itv.SymbolPath.partial + -> Tenv.t + -> node_hash:int + -> Location.t + -> depth:int + -> Loc.t + -> Typ.t + -> ?offset:Itv.t + -> ?size:Itv.t + -> inst_num:int + -> new_sym_num:Itv.Counter.t + -> new_alloc_num:Itv.Counter.t + -> Dom.Mem.astate + -> Dom.Mem.astate = fun ~decl_sym_val pname symbol_table path tenv ~node_hash location ~depth loc typ ?offset ?size ~inst_num ~new_sym_num ~new_alloc_num mem -> let option_value opt_x default_f = match opt_x with Some x -> x | None -> default_f () in @@ -113,10 +156,20 @@ module Exec = struct decl_sym_val pname path tenv ~node_hash location ~depth deref_loc typ mem - let decl_sym_java_ptr - : decl_sym_val:decl_sym_val -> Typ.Procname.t -> Itv.SymbolPath.partial -> Tenv.t - -> node_hash:int -> Location.t -> depth:int -> Loc.t -> Typ.t -> inst_num:int - -> new_alloc_num:Itv.Counter.t -> Dom.Mem.astate -> Dom.Mem.astate = + let decl_sym_java_ptr : + decl_sym_val:decl_sym_val + -> Typ.Procname.t + -> Itv.SymbolPath.partial + -> Tenv.t + -> node_hash:int + -> Location.t + -> depth:int + -> Loc.t + -> Typ.t + -> inst_num:int + -> new_alloc_num:Itv.Counter.t + -> Dom.Mem.astate + -> Dom.Mem.astate = fun ~decl_sym_val pname path tenv ~node_hash location ~depth loc typ ~inst_num ~new_alloc_num mem -> let alloc_num = Itv.Counter.next new_alloc_num in @@ -128,13 +181,20 @@ module Exec = struct decl_sym_val pname path tenv ~node_hash location ~depth alloc_loc typ mem - let decl_sym_collection - : Typ.Procname.t -> Itv.SymbolTable.t -> Itv.SymbolPath.partial -> Location.t -> Loc.t - -> new_sym_num:Itv.Counter.t -> Dom.Mem.astate -> Dom.Mem.astate = + let decl_sym_collection : + Typ.Procname.t + -> Itv.SymbolTable.t + -> Itv.SymbolPath.partial + -> Location.t + -> Loc.t + -> new_sym_num:Itv.Counter.t + -> Dom.Mem.astate + -> Dom.Mem.astate = fun pname symbol_table path location loc ~new_sym_num mem -> let size = Itv.make_sym ~unsigned:true pname symbol_table (Itv.SymbolPath.length path) new_sym_num - |> Dom.Val.of_itv |> Dom.Val.add_trace_elem (Trace.SymAssign (loc, location)) + |> Dom.Val.of_itv + |> Dom.Val.add_trace_elem (Trace.SymAssign (loc, location)) in Dom.Mem.add_heap loc size mem @@ -180,8 +240,7 @@ module Exec = struct match typ.Typ.desc with | Tstruct typename -> ( match Tenv.lookup tenv typename with - | Some {fields} when not (List.is_empty fields) - -> ( + | Some {fields} when not (List.is_empty fields) -> ( let field_name, field_typ, _ = List.last_exn fields in let field_loc = PowLoc.append_field locs ~fn:field_name in match field_typ.Typ.desc with @@ -199,7 +258,7 @@ end module Check = struct let check_access ~size ~idx ~size_sym_exp ~idx_sym_exp ~relation ~arr ~idx_traces - ?(is_collection_add= false) location cond_set = + ?(is_collection_add = false) location cond_set = let arr_traces = Dom.Val.get_traces arr in match (size, idx) with | NonBottom length, NonBottom idx -> @@ -230,7 +289,7 @@ module Check = struct location cond_set - let collection_access ~array_exp ~index_exp ?(is_collection_add= false) mem location cond_set = + let collection_access ~array_exp ~index_exp ?(is_collection_add = false) mem location cond_set = let idx = Sem.eval index_exp mem in let arr = Sem.eval array_exp mem in let idx_traces = Dom.Val.get_traces idx in diff --git a/infer/src/bufferoverrun/bufferOverrunUtils.mli b/infer/src/bufferoverrun/bufferOverrunUtils.mli index 09c31cada..51c978054 100644 --- a/infer/src/bufferoverrun/bufferOverrunUtils.mli +++ b/infer/src/bufferoverrun/bufferOverrunUtils.mli @@ -17,55 +17,134 @@ module Exec : sig val load_val : Ident.t -> Dom.Val.astate -> Dom.Mem.astate -> Dom.Mem.astate type decl_local = - Typ.Procname.t -> node_hash:int -> Location.t -> Loc.t -> Typ.t -> inst_num:int - -> dimension:int -> Dom.Mem.astate -> Dom.Mem.astate * int + Typ.Procname.t + -> node_hash:int + -> Location.t + -> Loc.t + -> Typ.t + -> inst_num:int + -> dimension:int + -> Dom.Mem.astate + -> Dom.Mem.astate * int val decl_local_array : - decl_local:decl_local -> Typ.Procname.t -> node_hash:int -> Location.t -> Loc.t -> Typ.t - -> length:IntLit.t option -> ?stride:int -> inst_num:int -> dimension:int -> Dom.Mem.astate + decl_local:decl_local + -> Typ.Procname.t + -> node_hash:int + -> Location.t + -> Loc.t + -> Typ.t + -> length:IntLit.t option + -> ?stride:int + -> inst_num:int + -> dimension:int + -> Dom.Mem.astate -> Dom.Mem.astate * int val decl_local_collection : - Typ.Procname.t -> node_hash:int -> Location.t -> Loc.t -> inst_num:int -> dimension:int - -> Dom.Mem.astate -> Dom.Mem.astate * int + Typ.Procname.t + -> node_hash:int + -> Location.t + -> Loc.t + -> inst_num:int + -> dimension:int + -> Dom.Mem.astate + -> Dom.Mem.astate * int type decl_sym_val = - Typ.Procname.t -> Itv.SymbolPath.partial -> Tenv.t -> node_hash:int -> Location.t -> depth:int - -> Loc.t -> Typ.t -> Dom.Mem.astate -> Dom.Mem.astate + Typ.Procname.t + -> Itv.SymbolPath.partial + -> Tenv.t + -> node_hash:int + -> Location.t + -> depth:int + -> Loc.t + -> Typ.t + -> Dom.Mem.astate + -> Dom.Mem.astate val decl_sym_arr : - decl_sym_val:decl_sym_val -> Typ.Procname.t -> Itv.SymbolTable.t -> Itv.SymbolPath.partial - -> Tenv.t -> node_hash:int -> Location.t -> depth:int -> Loc.t -> Typ.t -> ?offset:Itv.t - -> ?size:Itv.t -> inst_num:int -> new_sym_num:Itv.Counter.t -> new_alloc_num:Itv.Counter.t - -> Dom.Mem.astate -> Dom.Mem.astate + decl_sym_val:decl_sym_val + -> Typ.Procname.t + -> Itv.SymbolTable.t + -> Itv.SymbolPath.partial + -> Tenv.t + -> node_hash:int + -> Location.t + -> depth:int + -> Loc.t + -> Typ.t + -> ?offset:Itv.t + -> ?size:Itv.t + -> inst_num:int + -> new_sym_num:Itv.Counter.t + -> new_alloc_num:Itv.Counter.t + -> Dom.Mem.astate + -> Dom.Mem.astate val decl_sym_java_ptr : - decl_sym_val:decl_sym_val -> Typ.Procname.t -> Itv.SymbolPath.partial -> Tenv.t - -> node_hash:int -> Location.t -> depth:int -> Loc.t -> Typ.t -> inst_num:int - -> new_alloc_num:Itv.Counter.t -> Dom.Mem.astate -> Dom.Mem.astate + decl_sym_val:decl_sym_val + -> Typ.Procname.t + -> Itv.SymbolPath.partial + -> Tenv.t + -> node_hash:int + -> Location.t + -> depth:int + -> Loc.t + -> Typ.t + -> inst_num:int + -> new_alloc_num:Itv.Counter.t + -> Dom.Mem.astate + -> Dom.Mem.astate val decl_sym_collection : - Typ.Procname.t -> Itv.SymbolTable.t -> Itv.SymbolPath.partial -> Location.t -> Loc.t - -> new_sym_num:Itv.Counter.t -> Dom.Mem.astate -> Dom.Mem.astate + Typ.Procname.t + -> Itv.SymbolTable.t + -> Itv.SymbolPath.partial + -> Location.t + -> Loc.t + -> new_sym_num:Itv.Counter.t + -> Dom.Mem.astate + -> Dom.Mem.astate val init_array_fields : - Tenv.t -> Typ.Procname.t -> node_hash:int -> Typ.t -> PowLoc.t -> ?dyn_length:Exp.t - -> Dom.Mem.astate -> Dom.Mem.astate + Tenv.t + -> Typ.Procname.t + -> node_hash:int + -> Typ.t + -> PowLoc.t + -> ?dyn_length:Exp.t + -> Dom.Mem.astate + -> Dom.Mem.astate val set_dyn_length : Tenv.t -> Typ.t -> PowLoc.t -> Itv.t -> Dom.Mem.astate -> Dom.Mem.astate end module Check : sig val array_access : - arr:Dom.Val.t -> idx:Dom.Val.t -> idx_sym_exp:Relation.SymExp.t option - -> relation:Relation.astate -> is_plus:bool -> Location.t -> PO.ConditionSet.t + arr:Dom.Val.t + -> idx:Dom.Val.t + -> idx_sym_exp:Relation.SymExp.t option + -> relation:Relation.astate + -> is_plus:bool + -> Location.t + -> PO.ConditionSet.t -> PO.ConditionSet.t val lindex : - array_exp:Exp.t -> index_exp:Exp.t -> Dom.Mem.astate -> Location.t -> PO.ConditionSet.t + array_exp:Exp.t + -> index_exp:Exp.t + -> Dom.Mem.astate + -> Location.t + -> PO.ConditionSet.t -> PO.ConditionSet.t val collection_access : - array_exp:Exp.t -> index_exp:Exp.t -> ?is_collection_add:bool -> Dom.Mem.astate -> Location.t - -> PO.ConditionSet.t -> PO.ConditionSet.t + array_exp:Exp.t + -> index_exp:Exp.t + -> ?is_collection_add:bool + -> Dom.Mem.astate + -> Location.t + -> PO.ConditionSet.t + -> PO.ConditionSet.t end diff --git a/infer/src/bufferoverrun/ints.mli b/infer/src/bufferoverrun/ints.mli index 24c183ba2..b1ed92d85 100644 --- a/infer/src/bufferoverrun/ints.mli +++ b/infer/src/bufferoverrun/ints.mli @@ -6,7 +6,6 @@ *) open! IStd - module F = Format module NonZeroInt : sig diff --git a/infer/src/bufferoverrun/itv.ml b/infer/src/bufferoverrun/itv.ml index c1ce0eda7..84ad591c9 100644 --- a/infer/src/bufferoverrun/itv.ml +++ b/infer/src/bufferoverrun/itv.ml @@ -22,7 +22,7 @@ module Boolean = struct let true_ = True - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let is_false = function False -> true | _ -> false @@ -46,7 +46,8 @@ module NonNegativeBound = struct let of_bound b = if Bound.le b zero then zero else b let int_lb b = - Bound.int_lb b |> Option.bind ~f:NonNegativeInt.of_int + Bound.int_lb b + |> Option.bind ~f:NonNegativeInt.of_int |> Option.value ~default:NonNegativeInt.zero @@ -57,12 +58,12 @@ module NonNegativeBound = struct Bounds.ValTop | Bound.MInf -> assert false - | b -> + | b -> ( match Bound.is_const b with | None -> Bounds.Symbolic b | Some c -> - Bounds.Constant (NonNegativeInt.of_int_exn c) + Bounds.Constant (NonNegativeInt.of_int_exn c) ) let subst_exn b map = @@ -325,10 +326,10 @@ module MakePolynomial (S : NonNegativeSymbol) = struct if Int.equal 0 (S.compare s last_s) then ((last_s, PositiveInt.succ last_occ), others) else ((s, PositiveInt.one), last :: others) in - let pp_coeff fmt (c: NonNegativeInt.t) = + let pp_coeff fmt (c : NonNegativeInt.t) = if (c :> int) > 1 then F.fprintf fmt "%a * " NonNegativeInt.pp c in - let pp_exp fmt (e: PositiveInt.t) = + let pp_exp fmt (e : PositiveInt.t) = if (e :> int) > 1 then F.fprintf fmt "^%a" PositiveInt.pp e in let pp_magic_parentheses pp fmt x = @@ -404,7 +405,8 @@ module ItvRange = struct let of_bounds : lb:Bound.t -> ub:Bound.t -> t = fun ~lb ~ub -> - Bound.plus_u ub Bound.one |> Bound.plus_u (Bound.neg lb) + Bound.plus_u ub Bound.one + |> Bound.plus_u (Bound.neg lb) |> Bound.simplify_bound_ends_from_paths |> Bounds.NonNegativeBound.of_bound @@ -459,7 +461,7 @@ module ItvPure = struct match Bound.xcompare ~lhs:u1 ~rhs:l2 with | `LeftSmallerThanRight -> `LeftSmallerThanRight - | u1l2 -> + | u1l2 -> ( match (Bound.xcompare ~lhs:u2 ~rhs:l1, u1l2) with | `LeftSmallerThanRight, _ -> `RightSmallerThanLeft @@ -468,7 +470,7 @@ module ItvPure = struct | _, `Equal -> `LeftSmallerThanRight | _ -> - `NotComparable ) + `NotComparable ) ) | (`LeftSmallerThanRight | `Equal), (`LeftSmallerThanRight | `Equal) -> `LeftSmallerThanRight | (`RightSmallerThanLeft | `Equal), (`RightSmallerThanLeft | `Equal) -> @@ -500,7 +502,8 @@ module ItvPure = struct let of_int n = of_bound (Bound.of_int n) - let make_sym : unsigned:bool -> Typ.Procname.t -> SymbolTable.t -> SymbolPath.t -> Counter.t -> t = + let make_sym : unsigned:bool -> Typ.Procname.t -> SymbolTable.t -> SymbolPath.t -> Counter.t -> t + = fun ~unsigned pname symbol_table path new_sym_num -> let lb, ub = Bounds.SymLinear.make ~unsigned pname symbol_table path new_sym_num in (Bound.of_sym lb, Bound.of_sym ub) @@ -622,7 +625,7 @@ module ItvPure = struct top | Some 0 -> x (* x % [0,0] does nothing. *) - | Some m -> + | Some m -> ( match is_const x with | Some n -> of_int (n mod m) @@ -630,7 +633,7 @@ module ItvPure = struct let abs_m = abs m in if is_ge_zero x then (Bound.zero, Bound.of_int (abs_m - 1)) else if is_le_zero x then (Bound.of_int (-abs_m + 1), Bound.zero) - else (Bound.of_int (-abs_m + 1), Bound.of_int (abs_m - 1)) + else (Bound.of_int (-abs_m + 1), Bound.of_int (abs_m - 1)) ) (* x << [-1,-1] does nothing. *) @@ -712,13 +715,17 @@ module ItvPure = struct (l1, u2) | (l1, Bound.Linear (c1, s1)), (_, Bound.Linear (c2, s2)) when Bounds.SymLinear.eq s1 s2 -> (l1, Bound.Linear (min c1 c2, s1)) - | (l1, Bound.Linear (c, se)), (_, u) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol u -> + | (l1, Bound.Linear (c, se)), (_, u) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol u + -> (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) - | (l1, u), (_, Bound.Linear (c, se)) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol u -> + | (l1, u), (_, Bound.Linear (c, se)) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol u + -> (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) - | (l1, Bound.Linear (c, se)), (_, u) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol u -> + | (l1, Bound.Linear (c, se)), (_, u) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol u + -> (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) - | (l1, u), (_, Bound.Linear (c, se)) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol u -> + | (l1, u), (_, Bound.Linear (c, se)) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol u + -> (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) | (l1, Bound.Linear (c1, se)), (_, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')) | (l1, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')), (_, Bound.Linear (c1, se)) @@ -739,13 +746,17 @@ module ItvPure = struct (l2, u1) | (Bound.Linear (c1, s1), u1), (Bound.Linear (c2, s2), _) when Bounds.SymLinear.eq s1 s2 -> (Bound.Linear (max c1 c2, s1), u1) - | (Bound.Linear (c, se), u1), (l, _) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol l -> + | (Bound.Linear (c, se), u1), (l, _) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol l + -> (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) - | (l, u1), (Bound.Linear (c, se), _) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol l -> + | (l, u1), (Bound.Linear (c, se), _) when Bounds.SymLinear.is_zero se && Bound.is_one_symbol l + -> (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) - | (Bound.Linear (c, se), u1), (l, _) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol l -> + | (Bound.Linear (c, se), u1), (l, _) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol l + -> (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) - | (l, u1), (Bound.Linear (c, se), _) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol l -> + | (l, u1), (Bound.Linear (c, se), _) when Bounds.SymLinear.is_zero se && Bound.is_mone_symbol l + -> (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) | (Bound.Linear (c1, se), u1), (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), _) | (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), u1), (Bound.Linear (c1, se), _) @@ -941,8 +952,9 @@ let minus : t -> t -> t = lift2 ItvPure.minus let get_iterator_itv : t -> t = lift1 ItvPure.get_iterator_itv -let make_sym : ?unsigned:bool -> Typ.Procname.t -> SymbolTable.t -> SymbolPath.t -> Counter.t -> t = - fun ?(unsigned= false) pname symbol_table path new_sym_num -> +let make_sym : ?unsigned:bool -> Typ.Procname.t -> SymbolTable.t -> SymbolPath.t -> Counter.t -> t + = + fun ?(unsigned = false) pname symbol_table path new_sym_num -> NonBottom (ItvPure.make_sym ~unsigned pname symbol_table path new_sym_num) diff --git a/infer/src/bufferoverrun/itv.mli b/infer/src/bufferoverrun/itv.mli index 88c19048d..9b6a42cce 100644 --- a/infer/src/bufferoverrun/itv.mli +++ b/infer/src/bufferoverrun/itv.mli @@ -110,7 +110,8 @@ module ItvPure : sig val widen : prev:t -> next:t -> num_iters:int -> t val xcompare : - lhs:t -> rhs:t + lhs:t + -> rhs:t -> [ `Equal | `LeftSmallerThanRight | `RightSmallerThanLeft diff --git a/infer/src/bufferoverrun/symb.ml b/infer/src/bufferoverrun/symb.ml index 5a7080606..bfeccdb87 100644 --- a/infer/src/bufferoverrun/symb.ml +++ b/infer/src/bufferoverrun/symb.ml @@ -22,7 +22,7 @@ module SymbolPath = struct type t = Normal of partial | Offset of partial | Length of partial [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let of_pvar pvar = Pvar pvar @@ -64,7 +64,7 @@ module Symbol = struct Int.compare s1.id s2.id - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let paths_equal s1 s2 = SymbolPath.equal s1.path s2.path @@ -130,7 +130,7 @@ module SymbolMap = struct fun m -> if is_empty m then None else - let (kmin, _) as binding = min_binding m in + let ((kmin, _) as binding) = min_binding m in let kmax, _ = max_binding m in if Symbol.equal kmin kmax then Some binding else None end diff --git a/infer/src/checkers/BoundedCallTree.ml b/infer/src/checkers/BoundedCallTree.ml index add59e5c4..9830b39bd 100644 --- a/infer/src/checkers/BoundedCallTree.ml +++ b/infer/src/checkers/BoundedCallTree.ml @@ -20,9 +20,9 @@ module Domain = AbstractDomain.FiniteSet (Typ.Procname) module SpecPayload = SummaryPayload.Make (struct type t = Stacktree_j.stacktree - let update_payloads frame (payloads: Payloads.t) = {payloads with crashcontext_frame= Some frame} + let update_payloads frame (payloads : Payloads.t) = {payloads with crashcontext_frame= Some frame} - let of_payloads (payloads: Payloads.t) = payloads.crashcontext_frame + let of_payloads (payloads : Payloads.t) = payloads.crashcontext_frame end) type extras_t = {stacktraces: Stacktrace.t list} @@ -38,7 +38,7 @@ let line_range_of_pdesc pdesc = {Stacktree_j.start_line; end_line} -let stacktree_of_pdesc pdesc ?(loc= Procdesc.get_loc pdesc) ?(callees= []) location_type = +let stacktree_of_pdesc pdesc ?(loc = Procdesc.get_loc pdesc) ?(callees = []) location_type = let procname = Procdesc.get_proc_name pdesc in let frame_loc = Some @@ -95,8 +95,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let exec_instr astate proc_data _ = function - | Sil.Call (_, Const (Const.Cfun pn), _, loc, _) - -> ( + | Sil.Call (_, Const (Const.Cfun pn), _, loc, _) -> ( let traces = proc_data.ProcData.extras.stacktraces in let caller = Procdesc.get_proc_name proc_data.ProcData.pdesc in let matches_proc frame = @@ -123,8 +122,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Some frame -> let new_astate = Domain.add pn astate in ( if Stacktrace.frame_matches_location frame loc then - let pdesc = proc_data.ProcData.pdesc in - output_json_summary pdesc new_astate loc "call_site" ) ; + let pdesc = proc_data.ProcData.pdesc in + output_json_summary pdesc new_astate loc "call_site" ) ; new_astate | None -> astate ) diff --git a/infer/src/checkers/Litho.ml b/infer/src/checkers/Litho.ml index 79764b5aa..60df8179e 100644 --- a/infer/src/checkers/Litho.ml +++ b/infer/src/checkers/Litho.ml @@ -12,9 +12,9 @@ module Domain = LithoDomain module Payload = SummaryPayload.Make (struct type t = Domain.astate - let update_payloads astate (payloads: Payloads.t) = {payloads with litho= Some astate} + let update_payloads astate (payloads : Payloads.t) = {payloads with litho= Some astate} - let of_payloads (payloads: Payloads.t) = payloads.litho + let of_payloads (payloads : Payloads.t) = payloads.litho end) module LithoFramework = struct @@ -62,8 +62,7 @@ module GraphQLGetters = struct (* we skip analysis of all GraphQL procs *) && match procname with - | Typ.Procname.Java java_procname - -> ( + | Typ.Procname.Java java_procname -> ( PatternMatch.is_getter java_procname && match Typ.Procname.Java.get_package java_procname with @@ -144,8 +143,8 @@ module RequiredProps = struct let should_report proc_desc tenv = let pname = Procdesc.get_proc_name proc_desc in - not (LithoFramework.is_function pname) - && not (LithoFramework.is_component_build_method pname tenv) + (not (LithoFramework.is_function pname)) + && (not (LithoFramework.is_component_build_method pname tenv)) && Procdesc.get_access proc_desc <> PredSymb.Private @@ -154,7 +153,8 @@ module RequiredProps = struct (* @Prop(resType = ...) myProp can also be set via myProp(), myPropAttr(), or myPropRes(). Our annotation parameter parsing is too primitive to identify resType, so just assume that all @Prop's can be set any of these 3 ways. *) - || String.Set.mem prop_set (prop ^ "Attr") || String.Set.mem prop_set (prop ^ "Res") + || String.Set.mem prop_set (prop ^ "Attr") + || String.Set.mem prop_set (prop ^ "Res") let report astate tenv summary = @@ -162,12 +162,10 @@ module RequiredProps = struct let rev_chain = List.rev call_chain in match rev_chain with | pname :: _ when LithoFramework.is_component_build_method pname tenv -> ( - match - (* Here, we'll have a type name like MyComponent$Builder in hand. Truncate the $Builder + (* Here, we'll have a type name like MyComponent$Builder in hand. Truncate the $Builder part from the typename, then look at the fields of MyComponent to figure out which ones are annotated with @Prop *) - find_client_component_type call_chain - with + match find_client_component_type call_chain with | Some parent_typename -> let required_props = get_required_props parent_typename tenv in let prop_set = List.map ~f:Typ.Procname.get_method call_chain |> String.Set.of_list in @@ -216,7 +214,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct astate - let exec_instr astate (proc_data: extras ProcData.t) _ (instr: HilInstr.t) : Domain.astate = + let exec_instr astate (proc_data : extras ProcData.t) _ (instr : HilInstr.t) : Domain.astate = let caller_pname = Procdesc.get_proc_name proc_data.pdesc in match instr with | Call @@ -236,7 +234,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct || (* track GraphQL getters in order to report graphql field accesses *) Domain.mem receiver astate (* track anything called on a receiver we're already tracking *) ) - && not (Typ.Procname.Java.is_static java_callee_procname) + && (not (Typ.Procname.Java.is_static java_callee_procname)) && not ( LithoFramework.is_function callee_procname && not (LithoFramework.is_function caller_pname) ) @@ -255,8 +253,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Call (ret_id_typ, Direct callee_procname, actuals, _, _) -> let summary = Payload.read proc_data.pdesc callee_procname in apply_callee_summary summary caller_pname ret_id_typ actuals astate - | Assign (lhs_ae, HilExp.AccessExpression rhs_ae, _) - -> ( + | Assign (lhs_ae, HilExp.AccessExpression rhs_ae, _) -> ( (* creating an alias for the rhs binding; assume all reads will now occur through the alias. this helps us keep track of chains in cases like tmp = getFoo(); x = tmp; tmp.getBar() *) diff --git a/infer/src/checkers/LithoDomain.ml b/infer/src/checkers/LithoDomain.ml index 78277bf70..5343c7040 100644 --- a/infer/src/checkers/LithoDomain.ml +++ b/infer/src/checkers/LithoDomain.ml @@ -11,7 +11,7 @@ module F = Format module LocalAccessPath = struct type t = {access_path: AccessPath.t; parent: Typ.Procname.t} [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let make access_path parent = {access_path; parent} @@ -38,7 +38,7 @@ end module CallSet = AbstractDomain.FiniteSet (MethodCall) include AbstractDomain.Map (LocalAccessPath) (CallSet) -let substitute ~(f_sub: LocalAccessPath.t -> LocalAccessPath.t option) astate = +let substitute ~(f_sub : LocalAccessPath.t -> LocalAccessPath.t option) astate = fold (fun original_access_path call_set acc -> let access_path' = @@ -65,8 +65,8 @@ let substitute ~(f_sub: LocalAccessPath.t -> LocalAccessPath.t option) astate = maximal chain. For example, if the domain encodes the chains foo().bar().goo() and foo().baz(), [f] will be called once on foo().bar().goo() and once on foo().baz() *) let iter_call_chains_with_suffix ~f call_suffix astate = - let rec unroll_call_ ({receiver; procname}: MethodCall.t) (acc, visited) = - let is_cycle (call: MethodCall.t) = + let rec unroll_call_ ({receiver; procname} : MethodCall.t) (acc, visited) = + let is_cycle (call : MethodCall.t) = (* detect direct cycles and cycles due to mutual recursion *) LocalAccessPath.equal call.receiver receiver || Typ.Procname.Set.mem call.procname visited in diff --git a/infer/src/checkers/NullabilityCheck.ml b/infer/src/checkers/NullabilityCheck.ml index 246274d45..956fb2b26 100644 --- a/infer/src/checkers/NullabilityCheck.ml +++ b/infer/src/checkers/NullabilityCheck.ml @@ -76,7 +76,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Errlog.fold (fun {Errlog.err_name; err_desc; in_footprint} {Errlog.loc} found_confict -> found_confict - || in_footprint && IssueType.equal err_name IssueType.null_dereference + || in_footprint + && IssueType.equal err_name IssueType.null_dereference && Location.equal loc report_location && Localise.error_desc_is_reportable_bucket err_desc ) (Summary.get_err_log summary) false @@ -182,7 +183,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let assume_pnames_notnull ap (aps, checked_pnames) : Domain.astate = let remove_call_sites ap aps = - let add_diff (to_remove: CallSites.t) ap call_sites map = + let add_diff (to_remove : CallSites.t) ap call_sites map = let remaining_call_sites = CallSites.diff call_sites to_remove in if CallSites.is_empty remaining_call_sites then map else NullableAP.add ap remaining_call_sites map @@ -206,12 +207,12 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let rec longest_nullable_prefix ap ((nullable_aps, _) as astate) = - try Some (ap, NullableAP.find ap nullable_aps) with Caml.Not_found -> + try Some (ap, NullableAP.find ap nullable_aps) with Caml.Not_found -> ( match ap with | _, [] -> None | p -> - longest_nullable_prefix (fst (AccessPath.truncate p)) astate + longest_nullable_prefix (fst (AccessPath.truncate p)) astate ) let check_ap proc_data loc ap astate = @@ -236,7 +237,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct check_nil_in_objc_container proc_data loc other_args astate - let exec_instr ((_, checked_pnames) as astate) proc_data _ (instr: HilInstr.t) : Domain.astate = + let exec_instr ((_, checked_pnames) as astate) proc_data _ (instr : HilInstr.t) : Domain.astate = let is_pointer_assignment tenv lhs rhs = (* the rhs has type int when assigning the lhs to null *) if HilExp.is_null_literal rhs then true @@ -286,8 +287,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct add_nullable_ap (ret_var, []) call_sites astate ) | Call (ret_var, _, _, _, _) -> remove_nullable_ap (ret_var, []) astate - | Assign (lhs_access_expr, rhs, loc) - -> ( + | Assign (lhs_access_expr, rhs, loc) -> ( let lhs = AccessExpression.to_access_path lhs_access_expr in Option.iter ~f:(fun (nullable_ap, call_sites) -> diff --git a/infer/src/checkers/NullabilityPreanalysis.ml b/infer/src/checkers/NullabilityPreanalysis.ml index 81c819d05..63b32d087 100644 --- a/infer/src/checkers/NullabilityPreanalysis.ml +++ b/infer/src/checkers/NullabilityPreanalysis.ml @@ -38,7 +38,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct with Caml.Not_found -> false - let exec_instr astate (proc_data: Exp.t Ident.Hash.t ProcData.t) _ instr = + let exec_instr astate (proc_data : Exp.t Ident.Hash.t ProcData.t) _ instr = match instr with | Sil.Load (id, exp, _, _) -> Ident.Hash.add proc_data.extras id exp ; diff --git a/infer/src/checkers/NullabilitySuggest.ml b/infer/src/checkers/NullabilitySuggest.ml index e9d5e420e..5cbdc9807 100644 --- a/infer/src/checkers/NullabilitySuggest.ml +++ b/infer/src/checkers/NullabilitySuggest.ml @@ -86,7 +86,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct None - let exec_instr (astate: Domain.astate) proc_data _ (instr: HilInstr.t) = + let exec_instr (astate : Domain.astate) proc_data _ (instr : HilInstr.t) = match instr with | Assume (expr, _, _, loc) -> ( match extract_null_compare_expr expr with @@ -134,7 +134,7 @@ let make_error_trace astate ap ud = let msg = F.sprintf "%s is compared to null here" (name_of src) in let ltr = [Errlog.make_trace_element depth loc msg []] in Some (loc, ltr) - | DependsOn (loc, dep) -> + | DependsOn (loc, dep) -> ( match Domain.find dep astate with | exception Caml.Not_found -> None @@ -146,7 +146,7 @@ let make_error_trace astate ap ud = let seen' = Set.add ud' seen in Option.map (error_trace_impl seen' (depth + 1) dep ud') - ~f:(fun (_, trace) -> (loc, trace_elem :: trace)) + ~f:(fun (_, trace) -> (loc, trace_elem :: trace)) ) in error_trace_impl Set.empty 0 ap ud @@ -175,7 +175,7 @@ let is_outside_codebase proc_name field_name = let checker {Callbacks.summary; proc_desc; tenv} = let proc_name = Procdesc.get_proc_name proc_desc in let annotation = Localise.nullable_annotation_name proc_name in - let report astate (proc_data: extras ProcData.t) = + let report astate (proc_data : extras ProcData.t) = let report_access_path ap udchain = match AccessPath.get_field_and_annotation ap proc_data.tenv with | Some (field_name, _) when is_outside_codebase proc_name field_name -> @@ -184,8 +184,7 @@ let checker {Callbacks.summary; proc_desc; tenv} = | Some (field_name, _) when Typ.Fieldname.Java.is_captured_parameter field_name -> (* Skip reporting when field comes from generated code *) () - | Some (field_name, _) - -> ( + | Some (field_name, _) -> ( let message = F.asprintf "Field %a should be annotated with %a" MF.pp_monospaced (pretty_field_name proc_data field_name) diff --git a/infer/src/checkers/Ownership.ml b/infer/src/checkers/Ownership.ml index 7239da34d..5c81b23de 100644 --- a/infer/src/checkers/Ownership.ml +++ b/infer/src/checkers/Ownership.ml @@ -190,7 +190,7 @@ module Domain = struct (* handle assigning directly to a base var *) - let handle_var_assign ?(is_operator_equal= false) lhs_base rhs_exp loc summary astate = + let handle_var_assign ?(is_operator_equal = false) lhs_base rhs_exp loc summary astate = match rhs_exp with | HilExp.Constant _ when not (Var.is_cpp_temporary (fst lhs_base)) -> add lhs_base CapabilityDomain.Owned astate @@ -207,7 +207,7 @@ module Domain = struct in borrow_vars lhs_base vars_captured_by_ref astate | HilExp.AccessExpression (Base rhs_base) - when not is_operator_equal && Typ.is_reference (snd rhs_base) -> + when (not is_operator_equal) && Typ.is_reference (snd rhs_base) -> copy_or_borrow_var lhs_base rhs_base astate | HilExp.AccessExpression (AddressOf (Base rhs_base)) when not is_operator_equal -> borrow_vars lhs_base (VarSet.singleton rhs_base) astate @@ -236,7 +236,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct false - let get_assigned_base (access_expression: AccessExpression.t) = + let get_assigned_base (access_expression : AccessExpression.t) = match access_expression with | Base base -> Some base @@ -279,10 +279,12 @@ module TransferFunctions (CFG : ProcCfg.S) = struct FN_placement_new_aliasing2_bad test) *) Domain.actuals_add_reads other_actuals loc summary astate |> Domain.add placement_base CapabilityDomain.Owned - |> Domain.add return_base CapabilityDomain.Owned |> Option.some + |> Domain.add return_base CapabilityDomain.Owned + |> Option.some | _ :: other_actuals -> Domain.actuals_add_reads other_actuals loc summary astate - |> Domain.add return_base CapabilityDomain.Owned |> Option.some + |> Domain.add return_base CapabilityDomain.Owned + |> Option.some | _ -> L.die InternalError "Placement new without placement in %a %a" Typ.Procname.pp pname Location.pp loc @@ -314,7 +316,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct false - let exec_instr (astate: Domain.astate) (proc_data: extras ProcData.t) _ (instr: HilInstr.t) = + let exec_instr (astate : Domain.astate) (proc_data : extras ProcData.t) _ (instr : HilInstr.t) = let summary = proc_data.extras in match instr with | Assign (lhs_access_exp, rhs_exp, loc) -> ( @@ -376,14 +378,14 @@ module Analyzer = LowerHil.MakeAbstractInterpreter (ProcCfg.Exceptional) (Transf let report_invalid_return post end_loc formal_map summary = (* look for return values that are borrowed from (now-invalid) local variables *) - let report_invalid_return base (capability: CapabilityDomain.astate) = + let report_invalid_return base (capability : CapabilityDomain.astate) = if Var.is_return (fst base) then match capability with | BorrowedFrom vars -> VarSet.iter (fun borrowed_base -> if - not (FormalMap.is_formal borrowed_base formal_map) + (not (FormalMap.is_formal borrowed_base formal_map)) && not (Var.is_global (fst borrowed_base)) then Domain.report_return_stack_var borrowed_base end_loc summary ) vars diff --git a/infer/src/checkers/Sink.ml b/infer/src/checkers/Sink.ml index e60e4034b..cd09f8fdb 100644 --- a/infer/src/checkers/Sink.ml +++ b/infer/src/checkers/Sink.ml @@ -35,7 +35,7 @@ module Make (Kind : Kind) = struct let indexes t = t.indexes - let make ?(indexes= IntSet.empty) kind site = {kind; site; indexes} + let make ?(indexes = IntSet.empty) kind site = {kind; site; indexes} let get site actuals call_flags tenv = match Kind.get (CallSite.pname site) actuals call_flags tenv with diff --git a/infer/src/checkers/SinkTrace.ml b/infer/src/checkers/SinkTrace.ml index 3215dbacc..8cc4e1dfd 100644 --- a/infer/src/checkers/SinkTrace.ml +++ b/infer/src/checkers/SinkTrace.ml @@ -23,7 +23,9 @@ module type S = sig val of_sink : Sink.t -> t val to_sink_loc_trace : - ?desc_of_sink:(Sink.t -> string) -> ?sink_should_nest:(Sink.t -> bool) -> sink_path + ?desc_of_sink:(Sink.t -> string) + -> ?sink_should_nest:(Sink.t -> bool) + -> sink_path -> Errlog.loc_trace_elem list end diff --git a/infer/src/checkers/SinkTrace.mli b/infer/src/checkers/SinkTrace.mli index f2996200f..a4525572e 100644 --- a/infer/src/checkers/SinkTrace.mli +++ b/infer/src/checkers/SinkTrace.mli @@ -27,7 +27,9 @@ module type S = sig val of_sink : Sink.t -> t val to_sink_loc_trace : - ?desc_of_sink:(Sink.t -> string) -> ?sink_should_nest:(Sink.t -> bool) -> sink_path + ?desc_of_sink:(Sink.t -> string) + -> ?sink_should_nest:(Sink.t -> bool) + -> sink_path -> Errlog.loc_trace_elem list end diff --git a/infer/src/checkers/Siof.ml b/infer/src/checkers/Siof.ml index 4926dc7af..007f5d12b 100644 --- a/infer/src/checkers/Siof.ml +++ b/infer/src/checkers/Siof.ml @@ -13,7 +13,7 @@ module GlobalVarSet = SiofTrace.GlobalVarSet let methods_whitelist = QualifiedCppName.Match.of_fuzzy_qual_names Config.siof_safe_methods -let is_whitelisted (pname: Typ.Procname.t) = +let is_whitelisted (pname : Typ.Procname.t) = Typ.Procname.get_qualifiers pname |> QualifiedCppName.Match.match_qualifiers methods_whitelist @@ -60,9 +60,9 @@ let is_modelled = module Payload = SummaryPayload.Make (struct type t = SiofDomain.Summary.astate - let update_payloads astate (payloads: Payloads.t) = {payloads with siof= Some astate} + let update_payloads astate (payloads : Payloads.t) = {payloads with siof= Some astate} - let of_payloads (payloads: Payloads.t) = payloads.siof + let of_payloads (payloads : Payloads.t) = payloads.siof end) module TransferFunctions (CFG : ProcCfg.S) = struct @@ -87,7 +87,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Domain.VarNames.elements initialized |> QualifiedCppName.Match.of_fuzzy_qual_names in Staged.stage (fun (* gvar \notin initialized, up to some fuzzing *) - gvar -> + gvar -> QualifiedCppName.of_qual_string (Pvar.to_string gvar) |> Fn.non (QualifiedCppName.Match.match_qualifiers initialized_matcher) ) @@ -98,8 +98,11 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let get_globals pdesc e = let is_dangerous_global pv = - Pvar.is_global pv && not (Pvar.is_static_local pv) && not (Pvar.is_pod pv) - && not (Pvar.is_compile_constant pv) && not (is_compile_time_constructed pdesc pv) + Pvar.is_global pv + && (not (Pvar.is_static_local pv)) + && (not (Pvar.is_pod pv)) + && (not (Pvar.is_compile_constant pv)) + && (not (is_compile_time_constructed pdesc pv)) && is_not_always_initialized pv in Exp.program_vars e @@ -133,7 +136,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let at_least_nonbottom = Domain.join (NonBottom SiofTrace.empty, Domain.VarNames.empty) - let exec_instr astate {ProcData.pdesc} _ (instr: Sil.instr) = + let exec_instr astate {ProcData.pdesc} _ (instr : Sil.instr) = match instr with | Store (Lvar global, Typ.({desc= Tptr _}), Lvar _, loc) when (Option.equal Typ.Procname.equal) @@ -165,7 +168,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in Domain.join astate (NonBottom SiofTrace.empty, Domain.VarNames.of_list init) | Call (_, Const (Cfun (ObjC_Cpp cpp_pname as callee_pname)), _ :: actuals_without_self, loc, _) - when Typ.Procname.is_constructor callee_pname && Typ.Procname.ObjC_Cpp.is_constexpr cpp_pname -> + when Typ.Procname.is_constructor callee_pname && Typ.Procname.ObjC_Cpp.is_constexpr cpp_pname + -> add_actuals_globals astate pdesc loc actuals_without_self | Call (_, Const (Cfun callee_pname), actuals, loc, _) -> let callee_astate = @@ -190,7 +194,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | None -> (Bottom, Domain.VarNames.empty) in - add_actuals_globals astate pdesc loc actuals |> Domain.join callee_astate + add_actuals_globals astate pdesc loc actuals + |> Domain.join callee_astate |> (* make sure it's not Bottom: we made a function call so this needs initialization *) at_least_nonbottom | Call (_, _, actuals, loc, _) -> @@ -244,7 +249,7 @@ let report_siof summary trace pdesc gname loc = else List.iter ~f:report_one_path reportable_paths -let siof_check pdesc gname (summary: Summary.t) = +let siof_check pdesc gname (summary : Summary.t) = match summary.payloads.siof with | Some (NonBottom post, _) -> let attrs = Procdesc.get_attributes pdesc in diff --git a/infer/src/checkers/Stacktrace.ml b/infer/src/checkers/Stacktrace.ml index 32764edd6..dd243a857 100644 --- a/infer/src/checkers/Stacktrace.ml +++ b/infer/src/checkers/Stacktrace.ml @@ -103,8 +103,10 @@ let of_json filename json = let exception_name = Yojson.Basic.Util.to_string (extract_json_member exception_name_key) in let frames = Yojson.Basic.Util.to_list (extract_json_member frames_key) - |> List.map ~f:Yojson.Basic.Util.to_string |> List.map ~f:String.strip - |> List.filter ~f:(fun s -> s <> "") |> List.map ~f:parse_stack_frame + |> List.map ~f:Yojson.Basic.Util.to_string + |> List.map ~f:String.strip + |> List.filter ~f:(fun s -> s <> "") + |> List.map ~f:parse_stack_frame in make exception_name frames diff --git a/infer/src/checkers/Trace.ml b/infer/src/checkers/Trace.ml index 7acf14e41..d981aa159 100644 --- a/infer/src/checkers/Trace.ml +++ b/infer/src/checkers/Trace.ml @@ -85,8 +85,11 @@ module type S = sig [cur_site] restricts the reported paths to ones introduced by the call at [cur_site] *) val to_loc_trace : - ?desc_of_source:(Source.t -> string) -> ?source_should_nest:(Source.t -> bool) - -> ?desc_of_sink:(Sink.t -> string) -> ?sink_should_nest:(Sink.t -> bool) -> path + ?desc_of_source:(Source.t -> string) + -> ?source_should_nest:(Source.t -> bool) + -> ?desc_of_sink:(Sink.t -> string) + -> ?sink_should_nest:(Sink.t -> bool) + -> path -> Errlog.loc_trace (** create a loc_trace from a path; [source_should_nest s] should be true when we are going one deeper into a call-chain, ie when lt_level should be bumper in the next loc_trace_elem, and @@ -400,14 +403,16 @@ module Make (Spec : Spec) = struct let to_loc_trace - ?(desc_of_source= fun source -> - let callsite = Source.call_site source in - Format.asprintf "return from %a" Typ.Procname.pp - (CallSite.pname callsite)) ?(source_should_nest= fun _ -> true) - ?(desc_of_sink= fun sink -> - let callsite = Sink.call_site sink in - Format.asprintf "call to %a" Typ.Procname.pp (CallSite.pname callsite)) - ?(sink_should_nest= fun _ -> true) (passthroughs, sources, sinks) = + ?(desc_of_source = + fun source -> + let callsite = Source.call_site source in + Format.asprintf "return from %a" Typ.Procname.pp (CallSite.pname callsite)) + ?(source_should_nest = fun _ -> true) + ?(desc_of_sink = + fun sink -> + let callsite = Sink.call_site sink in + Format.asprintf "call to %a" Typ.Procname.pp (CallSite.pname callsite)) + ?(sink_should_nest = fun _ -> true) (passthroughs, sources, sinks) = let trace_elems_of_passthroughs lt_level passthroughs acc0 = let trace_elem_of_passthrough passthrough acc = let passthrough_site = Passthrough.site passthrough in @@ -517,7 +522,8 @@ module Make (Spec : Spec) = struct List.map ~f:(fun source -> Source.with_callsite source callee_site) (Sources.Known.elements non_footprint_callee_sources) - |> Sources.Known.of_list |> Sources.Known.union caller_trace.sources.known + |> Sources.Known.of_list + |> Sources.Known.union caller_trace.sources.known in {caller_trace.sources with Sources.known; sanitizers} in @@ -557,7 +563,8 @@ module Make (Spec : Spec) = struct let ( <= ) ~lhs ~rhs = phys_equal lhs rhs - || Sources.( <= ) ~lhs:lhs.sources ~rhs:rhs.sources && Sinks.subset lhs.sinks rhs.sinks + || Sources.( <= ) ~lhs:lhs.sources ~rhs:rhs.sources + && Sinks.subset lhs.sinks rhs.sinks && Passthroughs.subset lhs.passthroughs rhs.passthroughs diff --git a/infer/src/checkers/Trace.mli b/infer/src/checkers/Trace.mli index a4b1cc180..6289e7222 100644 --- a/infer/src/checkers/Trace.mli +++ b/infer/src/checkers/Trace.mli @@ -94,8 +94,11 @@ module type S = sig [cur_site] restricts the reported paths to ones introduced by the call at [cur_site] *) val to_loc_trace : - ?desc_of_source:(Source.t -> string) -> ?source_should_nest:(Source.t -> bool) - -> ?desc_of_sink:(Sink.t -> string) -> ?sink_should_nest:(Sink.t -> bool) -> path + ?desc_of_source:(Source.t -> string) + -> ?source_should_nest:(Source.t -> bool) + -> ?desc_of_sink:(Sink.t -> string) + -> ?sink_should_nest:(Sink.t -> bool) + -> path -> Errlog.loc_trace (** create a loc_trace from a path; [source_should_nest s] should be true when we are going one deeper into a call-chain, ie when lt_level should be bumper in the next loc_trace_elem, and diff --git a/infer/src/checkers/accessPathDomains.ml b/infer/src/checkers/accessPathDomains.ml index 8688fa86a..d03b204ca 100644 --- a/infer/src/checkers/accessPathDomains.ml +++ b/infer/src/checkers/accessPathDomains.ml @@ -25,7 +25,7 @@ module Set = struct (fun lhs -> not (APSet.exists - (fun rhs -> not (phys_equal lhs rhs) && AccessPath.Abs.( <= ) ~lhs ~rhs) + (fun rhs -> (not (phys_equal lhs rhs)) && AccessPath.Abs.( <= ) ~lhs ~rhs) aps) ) aps diff --git a/infer/src/checkers/accessTree.ml b/infer/src/checkers/accessTree.ml index 4081acdb6..87f2481b3 100644 --- a/infer/src/checkers/accessTree.ml +++ b/infer/src/checkers/accessTree.ml @@ -90,7 +90,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct module BaseMap = AccessPath.BaseMap - type node = (TraceDomain.astate * tree) + type node = TraceDomain.astate * tree and tree = Subtree of node AccessMap.t | Star @@ -135,7 +135,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct (** find all of the traces in the subtree and join them with [orig_trace] *) - let rec join_all_traces ?(join_traces= TraceDomain.join) orig_trace = function + let rec join_all_traces ?(join_traces = TraceDomain.join) orig_trace = function | Subtree subtree -> let join_all_traces_ orig_trace tree = let node_join_traces _ (trace, node) trace_acc = @@ -356,28 +356,28 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct f acc (AccessPath.Abs.Abstracted cur_ap_raw) node - let node_fold (f: 'a -> AccessPath.Abs.t -> node -> 'a) base node acc = + let node_fold (f : 'a -> AccessPath.Abs.t -> node -> 'a) base node acc = node_fold_ f base [] node acc - let fold (f: 'a -> AccessPath.Abs.t -> node -> 'a) tree acc_ = + let fold (f : 'a -> AccessPath.Abs.t -> node -> 'a) tree acc_ = BaseMap.fold (fun base node acc -> node_fold f base node acc) tree acc_ - let trace_fold (f: 'a -> AccessPath.Abs.t -> TraceDomain.astate -> 'a) = + let trace_fold (f : 'a -> AccessPath.Abs.t -> TraceDomain.astate -> 'a) = let f_ acc ap (trace, _) = f acc ap trace in fold f_ exception Found - let exists (f: AccessPath.Abs.t -> node -> bool) tree = + let exists (f : AccessPath.Abs.t -> node -> bool) tree = try fold (fun _ access_path node -> if f access_path node then raise Found else false) tree false with Found -> true - let iter (f: AccessPath.Abs.t -> node -> unit) tree = + let iter (f : AccessPath.Abs.t -> node -> unit) tree = fold (fun () access_path node -> f access_path node) tree () diff --git a/infer/src/checkers/annotationReachability.ml b/infer/src/checkers/annotationReachability.ml index 3e5b2a830..bad55f8db 100644 --- a/infer/src/checkers/annotationReachability.ml +++ b/infer/src/checkers/annotationReachability.ml @@ -36,7 +36,7 @@ module Domain = struct else (AnnotReachabilityDomain.add annot sink_map' annot_map, previous_vstate) - let stop_tracking ((annot_map, _): astate) = (annot_map, Bottom) + let stop_tracking ((annot_map, _) : astate) = (annot_map, Bottom) let add_tracking_var var ((annot_map, previous_vstate) as astate) = match previous_vstate with @@ -61,14 +61,14 @@ end module Payload = SummaryPayload.Make (struct type t = AnnotReachabilityDomain.astate - let update_payloads annot_map (payloads: Payloads.t) = {payloads with annot_map= Some annot_map} + let update_payloads annot_map (payloads : Payloads.t) = {payloads with annot_map= Some annot_map} - let of_payloads (payloads: Payloads.t) = payloads.annot_map + let of_payloads (payloads : Payloads.t) = payloads.annot_map end) let is_modeled_expensive tenv = function | Typ.Procname.Java proc_name_java as proc_name -> - not (BuiltinDecl.is_declared proc_name) + (not (BuiltinDecl.is_declared proc_name)) && let is_subclass = let classname = @@ -88,7 +88,8 @@ let is_allocator tenv pname = let class_name = Typ.Name.Java.from_string (Typ.Procname.Java.get_class_name pname_java) in PatternMatch.is_throwable tenv class_name in - Typ.Procname.is_constructor pname && not (BuiltinDecl.is_declared pname) + Typ.Procname.is_constructor pname + && (not (BuiltinDecl.is_declared pname)) && not (is_throwable ()) | _ -> false @@ -146,7 +147,8 @@ let report_allocation_stack src_annot summary fst_call_loc trace stack_str const Reporting.log_error summary ~loc:fst_call_loc ~ltr:final_trace exn -let report_annotation_stack src_annot snk_annot src_summary loc trace stack_str snk_pname call_loc = +let report_annotation_stack src_annot snk_annot src_summary loc trace stack_str snk_pname call_loc + = let src_pname = Summary.get_proc_name src_summary in if String.equal snk_annot dummy_constructor_annot then report_allocation_stack src_annot src_summary loc trace stack_str snk_pname call_loc @@ -343,8 +345,7 @@ let annot_specs = (List.map ~f:annotation_of_str src_annots) (annotation_of_str snk_annot) ) in - ExpensiveAnnotationSpec.spec - :: NoAllocationAnnotationSpec.spec + ExpensiveAnnotationSpec.spec :: NoAllocationAnnotationSpec.spec :: StandardAnnotationSpec.from_annotations [annotation_of_str Annotations.any_thread; annotation_of_str Annotations.for_non_ui_thread] (annotation_of_str Annotations.ui_thread) @@ -391,7 +392,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let check_call tenv callee_pname caller_pname call_site astate = List.fold ~init:astate - ~f:(fun astate (spec: AnnotationSpec.t) -> + ~f:(fun astate (spec : AnnotationSpec.t) -> if spec.sink_predicate tenv callee_pname && not (spec.sanitizer_predicate tenv caller_pname) then Domain.add_call_site spec.sink_annotation callee_pname call_site astate @@ -444,7 +445,7 @@ let checker ({Callbacks.proc_desc; tenv; summary} as callback) : Summary.t = let proc_data = ProcData.make_default proc_desc tenv in match Analyzer.compute_post proc_data ~initial with | Some (annot_map, _) -> - List.iter annot_specs ~f:(fun (spec: AnnotationSpec.t) -> spec.report callback annot_map) ; + List.iter annot_specs ~f:(fun (spec : AnnotationSpec.t) -> spec.report callback annot_map) ; Payload.update_summary annot_map summary | None -> summary diff --git a/infer/src/checkers/annotations.ml b/infer/src/checkers/annotations.ml index 35d485d7f..da9ab1078 100644 --- a/infer/src/checkers/annotations.ml +++ b/infer/src/checkers/annotations.ml @@ -109,11 +109,11 @@ let volatile = "volatile" let worker_thread = "WorkerThread" -let ia_has_annotation_with (ia: Annot.Item.t) (predicate: Annot.t -> bool) : bool = +let ia_has_annotation_with (ia : Annot.Item.t) (predicate : Annot.t -> bool) : bool = List.exists ~f:(fun (a, _) -> predicate a) ia -let ma_has_annotation_with ((ia, ial): Annot.Method.t) (predicate: Annot.t -> bool) : bool = +let ma_has_annotation_with ((ia, ial) : Annot.Method.t) (predicate : Annot.t -> bool) : bool = let has_annot a = ia_has_annotation_with a predicate in has_annot ia || List.exists ~f:has_annot ial @@ -128,7 +128,7 @@ let annot_ends_with annot ann_name = String.equal annot_class_name ann_name -let class_name_matches s ((annot: Annot.t), _) = String.equal s annot.class_name +let class_name_matches s ((annot : Annot.t), _) = String.equal s annot.class_name let ia_ends_with ia ann_name = List.exists ~f:(fun (a, _) -> annot_ends_with a ann_name) ia @@ -154,7 +154,7 @@ let pname_has_return_annot pname ~attrs_of_pname predicate = false -let field_has_annot fieldname (struct_typ: Typ.Struct.t) predicate = +let field_has_annot fieldname (struct_typ : Typ.Struct.t) predicate = let fld_has_taint_annot (fname, _, annot) = Typ.Fieldname.equal fieldname fname && predicate annot in @@ -162,7 +162,7 @@ let field_has_annot fieldname (struct_typ: Typ.Struct.t) predicate = || List.exists ~f:fld_has_taint_annot struct_typ.statics -let struct_typ_has_annot (struct_typ: Typ.Struct.t) predicate = predicate struct_typ.annots +let struct_typ_has_annot (struct_typ : Typ.Struct.t) predicate = predicate struct_typ.annots let ia_is_not_thread_safe ia = ia_ends_with ia not_thread_safe diff --git a/infer/src/checkers/annotations.mli b/infer/src/checkers/annotations.mli index 779e528c4..b244b8ed2 100644 --- a/infer/src/checkers/annotations.mli +++ b/infer/src/checkers/annotations.mli @@ -130,8 +130,10 @@ val pdesc_has_return_annot : Procdesc.t -> (Annot.Item.t -> bool) -> bool value *) val pname_has_return_annot : - Typ.Procname.t -> attrs_of_pname:(Typ.Procname.t -> ProcAttributes.t option) - -> (Annot.Item.t -> bool) -> bool + Typ.Procname.t + -> attrs_of_pname:(Typ.Procname.t -> ProcAttributes.t option) + -> (Annot.Item.t -> bool) + -> bool (** return true if the given predicate evaluates to true on the annotation of [pname]'s return value. the function [attrs_of_pname] should resolve the proc attributes of [pname]. Specs.proc_resolve_attributes is a good choice for this resolution function. *) diff --git a/infer/src/checkers/control.ml b/infer/src/checkers/control.ml index 2728e27ed..a84f209ad 100644 --- a/infer/src/checkers/control.ml +++ b/infer/src/checkers/control.ml @@ -41,8 +41,7 @@ module LoopHeads = Procdesc.NodeSet module ExitNodeToLoopHeads = Procdesc.NodeMap (** Map loop head -> prune nodes in the loop guard *) -module LoopHeadToGuardNodes = -Procdesc.NodeMap +module LoopHeadToGuardNodes = Procdesc.NodeMap type loop_control_maps = { exit_map: LoopHeads.t ExitNodeToLoopHeads.t @@ -110,7 +109,7 @@ module TransferFunctionsControlDeps (CFG : ProcCfg.S) = struct along with the loop header that CV is originating from - a loop exit node, remove control variables of its guard nodes This is correct because the CVs are only going to be temporaries. *) - let exec_instr astate {ProcData.extras= {exit_map; loop_head_to_guard_nodes}} (node: CFG.Node.t) + let exec_instr astate {ProcData.extras= {exit_map; loop_head_to_guard_nodes}} (node : CFG.Node.t) _ = let node = CFG.Node.underlying_node node in let astate' = diff --git a/infer/src/checkers/cost.ml b/infer/src/checkers/cost.ml index e4a5aa3da..c70bbbc67 100644 --- a/infer/src/checkers/cost.ml +++ b/infer/src/checkers/cost.ml @@ -14,9 +14,9 @@ module NodesBasicCostDomain = CostDomain.NodeInstructionToCostMap module Payload = SummaryPayload.Make (struct type t = CostDomain.summary - let update_payloads sum (payloads: Payloads.t) = {payloads with cost= Some sum} + let update_payloads sum (payloads : Payloads.t) = {payloads with cost= Some sum} - let of_payloads (payloads: Payloads.t) = payloads.cost + let of_payloads (payloads : Payloads.t) = payloads.cost end) (* We use this treshold to give error if the cost is above it. @@ -48,7 +48,7 @@ module TransferFunctionsNodesBasicCost = struct L.(die InternalError) "Can't instantiate symbolic cost %a from call to %a (can't get procdesc)" BasicCost.pp callee_cost Typ.Procname.pp callee_pname - | Some callee_pdesc -> + | Some callee_pdesc -> ( match BufferOverrunChecker.Payload.read caller_pdesc callee_pname with | None -> L.(die InternalError) @@ -62,11 +62,12 @@ module TransferFunctionsNodesBasicCost = struct BufferOverrunSemantics.get_subst_map tenv callee_pdesc params inferbo_caller_mem callee_symbol_table callee_exit_mem in - BasicCost.subst callee_cost subst_map + BasicCost.subst callee_cost subst_map ) - let exec_instr_cost inferbo_mem (astate: CostDomain.NodeInstructionToCostMap.astate) - {ProcData.pdesc; tenv} (node: CFG.Node.t) instr : CostDomain.NodeInstructionToCostMap.astate = + let exec_instr_cost inferbo_mem (astate : CostDomain.NodeInstructionToCostMap.astate) + {ProcData.pdesc; tenv} (node : CFG.Node.t) instr : CostDomain.NodeInstructionToCostMap.astate + = let key = CFG.Node.id node in let astate' = match instr with @@ -141,7 +142,7 @@ module BoundMap = struct match Procdesc.Node.get_kind node with | Procdesc.Node.Exit_node _ -> Node.IdMap.add node_id BasicCost.one bound_map - | _ -> + | _ -> ( let exit_state_opt = let instr_node_id = InstrCFG.last_of_underlying_node node |> InstrCFG.Node.id in BufferOverrunChecker.extract_post instr_node_id inferbo_invariant_map @@ -172,7 +173,7 @@ module BoundMap = struct bound ; Node.IdMap.add node_id bound bound_map | _ -> - Node.IdMap.add node_id BasicCost.zero bound_map + Node.IdMap.add node_id BasicCost.zero bound_map ) in let bound_map = NodeCFG.fold_nodes node_cfg ~f:compute_node_upper_bound ~init:Node.IdMap.empty @@ -207,10 +208,10 @@ module ControlFlowCost = struct | `Edge _, `Node _ -> 1 | `Edge (f1, t1), `Edge (f2, t2) -> - [%compare : Node.id * Node.id] (f1, t1) (f2, t2) + [%compare: Node.id * Node.id] (f1, t1) (f2, t2) - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let pp : F.formatter -> t -> unit = fun fmt -> function @@ -220,7 +221,7 @@ module ControlFlowCost = struct F.fprintf fmt "Edge(%a -> %a)" Node.pp_id f Node.pp_id t - let normalize ~(normalizer: t -> [> t]) (x: t) : t = + let normalize ~(normalizer : t -> [> t]) (x : t) : t = match normalizer x with #t as x -> x | _ -> assert false end @@ -236,7 +237,7 @@ module ControlFlowCost = struct let compare : t -> t -> int = - fun (`Sum (l1, s1)) (`Sum (l2, s2)) -> [%compare : int * Item.t list] (l1, s1) (l2, s2) + fun (`Sum (l1, s1)) (`Sum (l2, s2)) -> [%compare: int * Item.t list] (l1, s1) (l2, s2) let pp : F.formatter -> t -> unit = @@ -339,8 +340,8 @@ module ControlFlowCost = struct let pp_equalities fmt t = ARList.append (t.items :> elt ARList.t) (t.sums :> elt ARList.t) - |> IContainer.to_rev_list ~fold:ARList.fold_unordered |> List.sort ~compare - |> Pp.seq ~sep:" = " pp fmt + |> IContainer.to_rev_list ~fold:ARList.fold_unordered + |> List.sort ~compare |> Pp.seq ~sep:" = " pp fmt let normalize_sums : normalizer:(elt -> elt) -> t -> unit = @@ -348,7 +349,8 @@ module ControlFlowCost = struct t.sums <- t.sums |> IContainer.rev_map_to_list ~fold:ARList.fold_unordered ~f:(Sum.normalize ~normalizer) - |> List.dedup_and_sort ~compare:Sum.compare |> ARList.of_list + |> List.dedup_and_sort ~compare:Sum.compare + |> ARList.of_list let infer_equalities_by_removing_item ~on_infer t item = @@ -366,8 +368,8 @@ module ControlFlowCost = struct |> List.dedup_and_sort ~compare:Item.compare - let infer_equalities_from_sums - : on_infer:(elt -> elt -> unit) -> normalizer:(elt -> elt) -> t -> unit = + let infer_equalities_from_sums : + on_infer:(elt -> elt -> unit) -> normalizer:(elt -> elt) -> t -> unit = fun ~on_infer ~normalizer t -> normalize_sums ~normalizer t ; (* Keep in mind that [on_infer] can modify [t]. @@ -385,9 +387,11 @@ module ControlFlowCost = struct t.cost <- ARList.fold_unordered t.items ~init:t.cost ~f:min_if_node - let improve_cost_from_sums - : on_improve:(Sum.t -> BasicCost.astate -> BasicCost.astate -> unit) - -> of_item:(Item.t -> BasicCost.astate) -> t -> unit = + let improve_cost_from_sums : + on_improve:(Sum.t -> BasicCost.astate -> BasicCost.astate -> unit) + -> of_item:(Item.t -> BasicCost.astate) + -> t + -> unit = fun ~on_improve ~of_item t -> let f sum = let cost_of_sum = Sum.cost ~of_item sum in @@ -415,7 +419,7 @@ module ConstraintSolver = struct let normalizer equalities e = (find equalities e :> ControlFlowCost.t) - let pp_repr fmt (repr: Repr.t) = ControlFlowCost.pp fmt (repr :> ControlFlowCost.t) + let pp_repr fmt (repr : Repr.t) = ControlFlowCost.pp fmt (repr :> ControlFlowCost.t) let pp_equalities fmt equalities = let pp_item fmt (repr, set) = @@ -509,8 +513,9 @@ module ConstraintSolver = struct From inequalities: if A = B + C, then B <= A, do cost(B) = min(cost(B), cost(A)) *) let improve_costs equalities ~max = - let of_item (item: ControlFlowCost.Item.t) = - (item :> ControlFlowCost.t) |> find equalities |> find_set equalities + let of_item (item : ControlFlowCost.Item.t) = + (item :> ControlFlowCost.t) + |> find equalities |> find_set equalities |> Option.value_map ~f:ControlFlowCost.Set.cost ~default:BasicCost.top in let f ~did_improve (repr, set) = @@ -522,7 +527,7 @@ module ConstraintSolver = struct did_improve () in ControlFlowCost.Set.improve_cost_from_sums ~on_improve ~of_item set ; - let try_from_inequality (sum_item: ControlFlowCost.Item.t) = + let try_from_inequality (sum_item : ControlFlowCost.Item.t) = let sum_item_set = (sum_item :> ControlFlowCost.t) |> find equalities |> find_create_set equalities in @@ -628,7 +633,7 @@ module TransferFunctionsWCET = struct (* We don't report when the cost is Top as it corresponds to subsequent 'don't know's. Instead, we report Top cost only at the top level per function when `report_infinity` is set to true *) let should_report_cost cost = - not (BasicCost.is_top cost) && not (BasicCost.( <= ) ~lhs:cost ~rhs:expensive_threshold) + (not (BasicCost.is_top cost)) && not (BasicCost.( <= ) ~lhs:cost ~rhs:expensive_threshold) let do_report summary loc cost = @@ -681,7 +686,7 @@ module TransferFunctionsWCET = struct m BasicCost.zero - let exec_instr ((_, reported_so_far): Domain.astate) {ProcData.extras} (node: CFG.Node.t) instr + let exec_instr ((_, reported_so_far) : Domain.astate) {ProcData.extras} (node : CFG.Node.t) instr : Domain.astate = let {basic_cost_map= invariant_map_cost; get_node_nb_exec; summary} = extras in let cost_node = @@ -702,7 +707,8 @@ module TransferFunctionsWCET = struct let preds = Procdesc.Node.get_preds und_node in let reported_so_far = if - should_report_on_instr instr && should_report_on_node (und_node :: preds) reported_so_far + should_report_on_instr instr + && should_report_on_node (und_node :: preds) reported_so_far && should_report_cost cost_node then ( do_report summary (Sil.instr_get_loc instr) cost_node ; diff --git a/infer/src/checkers/dataflow.ml b/infer/src/checkers/dataflow.ml index 6c2418880..3afb49320 100644 --- a/infer/src/checkers/dataflow.ml +++ b/infer/src/checkers/dataflow.ml @@ -45,7 +45,7 @@ module type DF = sig end (** Determine if the node can throw an exception. *) -let node_throws pdesc node (proc_throws: Typ.Procname.t -> throws) : throws = +let node_throws pdesc node (proc_throws : Typ.Procname.t -> throws) : throws = let instr_throws instr = let is_return pvar = let ret_pvar = Procdesc.get_ret_var pdesc in @@ -103,7 +103,7 @@ module MakeDF (St : DFStateType) : DF with type state = St.t = struct let join states initial_state = List.fold ~f:St.join ~init:initial_state states (** Propagate [new_state] to all the nodes immediately reachable. *) - let propagate t node states_succ states_exn (throws: throws) = + let propagate t node states_succ states_exn (throws : throws) = let propagate_to_dest new_state dest_node = let push_state s = H.replace t.pre_states dest_node s ; diff --git a/infer/src/checkers/hoisting.ml b/infer/src/checkers/hoisting.ml index 80fbd7428..5c6a074dd 100644 --- a/infer/src/checkers/hoisting.ml +++ b/infer/src/checkers/hoisting.ml @@ -19,8 +19,7 @@ module LoopNodes = AbstractDomain.FiniteSet (Procdesc.Node) module HoistCalls = AbstractDomain.FiniteSet (Call) (** Map loop_header -> instrs that can be hoisted out of the loop *) -module LoopHeadToHoistInstrs = -Procdesc.NodeMap +module LoopHeadToHoistInstrs = Procdesc.NodeMap (* A loop-invariant function call C(args) at node N can be hoisted out of the loop if * diff --git a/infer/src/checkers/liveness.ml b/infer/src/checkers/liveness.ml index dffb08876..721f45bd5 100644 --- a/infer/src/checkers/liveness.ml +++ b/infer/src/checkers/liveness.ml @@ -38,10 +38,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in match call_exp with | Exp.Const (Cfun (Typ.Procname.ObjC_Cpp _ as pname)) when Typ.Procname.is_constructor pname -> ( - match - (* first actual passed to a C++ constructor is actually written, not read *) - actuals - with + (* first actual passed to a C++ constructor is actually written, not read *) + match actuals with | (Exp.Lvar pvar, _) :: exps -> Domain.remove (Var.of_pvar pvar) live_acc |> add_live_actuals_ exps | exps -> @@ -87,8 +85,9 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Sil.Prune (exp, _, _, _) -> exp_add_live exp astate | Sil.Call ((ret_id, _), call_exp, actuals, _, _) -> - Domain.remove (Var.of_id ret_id) astate |> exp_add_live call_exp - |> add_live_actuals actuals call_exp |> add_local_consts_for_lambdas pdesc call_exp + Domain.remove (Var.of_id ret_id) astate + |> exp_add_live call_exp |> add_live_actuals actuals call_exp + |> add_local_consts_for_lambdas pdesc call_exp | Sil.Remove_temps _ | Abstract _ | Nullify _ -> astate @@ -175,8 +174,10 @@ let checker {Callbacks.tenv; summary; proc_desc} : Summary.t = not ( Pvar.is_frontend_tmp pvar || Pvar.is_return pvar || Pvar.is_global pvar || VarSet.mem (Var.of_pvar pvar) captured_by_ref_vars - || Domain.mem (Var.of_pvar pvar) live_vars || Procdesc.is_captured_var proc_desc pvar - || is_scope_guard typ || Procdesc.has_modify_in_block_attr proc_desc pvar ) + || Domain.mem (Var.of_pvar pvar) live_vars + || Procdesc.is_captured_var proc_desc pvar + || is_scope_guard typ + || Procdesc.has_modify_in_block_attr proc_desc pvar ) in let log_report pvar typ loc = let message = @@ -189,7 +190,8 @@ let checker {Callbacks.tenv; summary; proc_desc} : Summary.t = in let report_dead_store live_vars captured_by_ref_vars = function | Sil.Store (Lvar pvar, typ, rhs_exp, loc) - when should_report pvar typ live_vars captured_by_ref_vars && not (is_sentinel_exp rhs_exp) -> + when should_report pvar typ live_vars captured_by_ref_vars && not (is_sentinel_exp rhs_exp) + -> log_report pvar typ loc | Sil.Call (_, Exp.Const (Cfun (Typ.Procname.ObjC_Cpp _ as pname)), (Exp.Lvar pvar, typ) :: _, loc, _) diff --git a/infer/src/checkers/loopInvariant.ml b/infer/src/checkers/loopInvariant.ml index 73c190f39..1c37ac292 100644 --- a/infer/src/checkers/loopInvariant.ml +++ b/infer/src/checkers/loopInvariant.ml @@ -22,10 +22,8 @@ let is_defined_outside loop_nodes reaching_defs var = let is_fun_call_invariant tenv ~is_exp_invariant ~is_inv_by_default callee_pname params = List.for_all ~f:(fun (exp, _) -> is_exp_invariant exp) params && - match - (* Take into account invariance behavior of modeled functions *) - Models.Call.dispatch tenv callee_pname params - with + (* Take into account invariance behavior of modeled functions *) + match Models.Call.dispatch tenv callee_pname params with | Some inv -> InvariantModels.is_invariant inv | None -> @@ -33,7 +31,7 @@ let is_fun_call_invariant tenv ~is_exp_invariant ~is_inv_by_default callee_pname (* check if the def of var is unique and invariant *) -let is_def_unique_and_satisfy tenv var (loop_nodes: LoopNodes.t) ~is_inv_by_default +let is_def_unique_and_satisfy tenv var (loop_nodes : LoopNodes.t) ~is_inv_by_default is_exp_invariant = let equals_var id = Var.equal var (Var.of_id id) in (* Use O(1) is_singleton check *) diff --git a/infer/src/checkers/loop_control.ml b/infer/src/checkers/loop_control.ml index 323cb5295..69b7c16fa 100644 --- a/infer/src/checkers/loop_control.ml +++ b/infer/src/checkers/loop_control.ml @@ -137,36 +137,37 @@ let get_control_maps cfg = L.(debug Analysis Medium) "Exit nodes: [%a]\n" (Pp.comma_seq Procdesc.Node.pp) exit_nodes ; (* find all the prune nodes in the loop guard *) let guard_prune_nodes = - get_all_nodes_upwards_until loop_head exit_nodes |> remove_prune_node_pairs exit_nodes + get_all_nodes_upwards_until loop_head exit_nodes + |> remove_prune_node_pairs exit_nodes |> Control.GuardNodes.filter is_prune in let exit_map' = (List.fold_left ~init:exit_map ~f:(fun exit_map_acc exit_node -> Control.ExitNodeToLoopHeads.update exit_node (function - | Some existing_loop_heads -> - Some (Control.LoopHeads.add loop_head existing_loop_heads) - | None -> - Some (Control.LoopHeads.singleton loop_head)) + | Some existing_loop_heads -> + Some (Control.LoopHeads.add loop_head existing_loop_heads) + | None -> + Some (Control.LoopHeads.singleton loop_head)) exit_map_acc )) exit_nodes in let loop_head_to_guard_nodes' = Control.LoopHeadToGuardNodes.update loop_head (function - | Some existing_guard_nodes -> - Some (Control.GuardNodes.union existing_guard_nodes guard_prune_nodes) - | None -> - Some guard_prune_nodes) + | Some existing_guard_nodes -> + Some (Control.GuardNodes.union existing_guard_nodes guard_prune_nodes) + | None -> + Some guard_prune_nodes) loop_head_to_guard_nodes in let loop_head_to_loop_nodes' = LoopInvariant.LoopHeadToLoopNodes.update loop_head (function - | Some existing_loop_nodes -> - Some (LoopInvariant.LoopNodes.union existing_loop_nodes loop_nodes) - | None -> - Some loop_nodes) + | Some existing_loop_nodes -> + Some (LoopInvariant.LoopNodes.union existing_loop_nodes loop_nodes) + | None -> + Some loop_nodes) loop_head_to_loop_nodes in let open Control in diff --git a/infer/src/checkers/printfArgs.ml b/infer/src/checkers/printfArgs.ml index 5d891cd21..7d6854282 100644 --- a/infer/src/checkers/printfArgs.ml +++ b/infer/src/checkers/printfArgs.ml @@ -34,13 +34,13 @@ let printf_like_functions = ; vararg_pos= Some 3 } ] -let printf_like_function (proc_name: Typ.Procname.t) : printf_signature option = +let printf_like_function (proc_name : Typ.Procname.t) : printf_signature option = List.find ~f:(fun printf -> String.equal printf.unique_id (Typ.Procname.to_unique_id proc_name)) !printf_like_functions -let default_format_type_name (format_type: string) : string = +let default_format_type_name (format_type : string) : string = match format_type with | "d" | "i" | "u" | "x" | "X" | "o" -> "java.lang.Integer" @@ -58,11 +58,12 @@ let default_format_type_name (format_type: string) : string = "unknown" -let format_type_matches_given_type (format_type: string) (given_type: string) : bool = +let format_type_matches_given_type (format_type : string) (given_type : string) : bool = match format_type with | "d" | "i" | "u" | "x" | "X" | "o" -> List.mem ~equal:String.equal - ["java.lang.Integer"; "java.lang.Long"; "java.lang.Short"; "java.lang.Byte"] given_type + ["java.lang.Integer"; "java.lang.Long"; "java.lang.Short"; "java.lang.Byte"] + given_type | "a" | "A" | "f" | "F" | "g" | "G" | "e" | "E" -> List.mem ~equal:String.equal ["java.lang.Double"; "java.lang.Float"] given_type | "c" -> @@ -74,8 +75,8 @@ let format_type_matches_given_type (format_type: string) (given_type: string) : (* The format string and the nvar for the fixed arguments and the nvar of the varargs array *) -let format_arguments (printf: printf_signature) (args: (Exp.t * Typ.t) list) - : string option * Exp.t list * Exp.t option = +let format_arguments (printf : printf_signature) (args : (Exp.t * Typ.t) list) : + string option * Exp.t list * Exp.t option = let format_string = match List.nth_exn args printf.format_pos with | Exp.Const (Const.Cstr fmt), _ -> @@ -91,7 +92,7 @@ let format_arguments (printf: printf_signature) (args: (Exp.t * Typ.t) list) (* Extract type names from format string *) -let rec format_string_type_names (fmt_string: string) (start: int) : string list = +let rec format_string_type_names (fmt_string : string) (start : int) : string list = try let fmt_re = Str.regexp "%[0-9]*\\.?[0-9]*[A-mo-z]" in (* matches '%2.1d' etc. *) @@ -102,8 +103,8 @@ let rec format_string_type_names (fmt_string: string) (start: int) : string list with Caml.Not_found -> [] -let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) - (proc_name: Typ.Procname.t) (proc_desc: Procdesc.t) summary : unit = +let check_printf_args_ok tenv (node : Procdesc.Node.t) (instr : Sil.instr) + (proc_name : Typ.Procname.t) (proc_desc : Procdesc.t) summary : unit = (* Check if format string lines up with arguments *) let rec check_type_names instr_loc n_arg instr_proc_name fmt_type_names arg_type_names = let instr_name = Typ.Procname.to_simplified_string instr_proc_name in diff --git a/infer/src/checkers/reachingDefs.ml b/infer/src/checkers/reachingDefs.ml index b3e58c9aa..e6f54638a 100644 --- a/infer/src/checkers/reachingDefs.ml +++ b/infer/src/checkers/reachingDefs.ml @@ -27,7 +27,7 @@ module TransferFunctionsReachingDefs (CFG : ProcCfg.S) = struct type extras = ProcData.no_extras (* for each x := e at node n, remove x's definitions and introduce x -> n *) - let exec_instr astate _ (node: CFG.Node.t) instr = + let exec_instr astate _ (node : CFG.Node.t) instr = let node = CFG.Node.underlying_node node in let strong_update_def astate var = Domain.add var (Defs.singleton node) astate in let weak_update_def astate var = diff --git a/infer/src/checkers/registerCheckers.ml b/infer/src/checkers/registerCheckers.ml index f51797a43..573e4f21e 100644 --- a/infer/src/checkers/registerCheckers.ml +++ b/infer/src/checkers/registerCheckers.ml @@ -12,7 +12,11 @@ open! IStd module F = Format (* make sure SimpleChecker.ml is not dead code *) -let () = if false then let module SC = SimpleChecker.Make in () +let () = + if false then + let module SC = SimpleChecker.Make in + () + type callback_fun = | Procedure of Callbacks.proc_callback_t diff --git a/infer/src/checkers/uninit.ml b/infer/src/checkers/uninit.ml index 351938826..3a45367f7 100644 --- a/infer/src/checkers/uninit.ml +++ b/infer/src/checkers/uninit.ml @@ -10,8 +10,8 @@ module F = Format module L = Logging (** Forward analysis to compute uninitialized variables at each program point *) -module D = -UninitDomain.Domain +module D = UninitDomain.Domain + module UninitVars = AbstractDomain.FiniteSet (AccessExpression) module AliasedVars = AbstractDomain.FiniteSet (UninitDomain.VarPair) module RecordDomain = UninitDomain.Record (UninitVars) (AliasedVars) (D) @@ -19,9 +19,9 @@ module RecordDomain = UninitDomain.Record (UninitVars) (AliasedVars) (D) module Payload = SummaryPayload.Make (struct type t = UninitDomain.summary - let update_payloads sum (payloads: Payloads.t) = {payloads with uninit= Some sum} + let update_payloads sum (payloads : Payloads.t) = {payloads with uninit= Some sum} - let of_payloads (payloads: Payloads.t) = payloads.uninit + let of_payloads (payloads : Payloads.t) = payloads.uninit end) let blacklisted_functions = [BuiltinDecl.__set_array_length] @@ -73,7 +73,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let base = AccessExpression.get_base access_expr in match (AccessExpression.get_typ access_expr tenv, base) with | Some typ, (Var.ProgramVar pv, _) -> - not (Pvar.is_frontend_tmp pv) && not (Procdesc.is_captured_var pdesc pv) + (not (Pvar.is_frontend_tmp pv)) + && (not (Procdesc.is_captured_var pdesc pv)) && D.mem access_expr uninit_vars && should_report_on_type typ | _, _ -> false @@ -89,12 +90,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let is_struct_field_passed_by_ref call t access_expr idx = - is_struct t && not (AccessExpression.is_base access_expr) + is_struct t + && (not (AccessExpression.is_base access_expr)) && function_expects_a_pointer_as_nth_param call idx let is_array_element_passed_by_ref call t access_expr idx = - is_array t && not (AccessExpression.is_base access_expr) + is_array t + && (not (AccessExpression.is_base access_expr)) && function_expects_a_pointer_as_nth_param call idx @@ -110,7 +113,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | HilExp.AccessExpression access_expr -> let _, t = AccessExpression.get_base access_expr in if - should_report_var pdesc tenv uninit_vars access_expr && not (Typ.is_pointer t) + should_report_var pdesc tenv uninit_vars access_expr + && (not (Typ.is_pointer t)) && not (is_struct_field_passed_by_ref call t access_expr idx) then report_intra access_expr loc (snd extras) else () @@ -122,7 +126,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let remove_all_fields tenv base uninit_vars = match base with | _, {Typ.desc= Tptr ({Typ.desc= Tstruct name_struct}, _)} | _, {Typ.desc= Tstruct name_struct} - -> ( + -> ( match Tenv.lookup tenv name_struct with | Some {fields} -> List.fold @@ -238,13 +242,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct false - let exec_instr (astate: Domain.astate) {ProcData.pdesc; ProcData.extras; ProcData.tenv} _ - (instr: HilInstr.t) = + let exec_instr (astate : Domain.astate) {ProcData.pdesc; ProcData.extras; ProcData.tenv} _ + (instr : HilInstr.t) = let update_prepost access_expr rhs = let lhs_base = AccessExpression.get_base access_expr in if - FormalMap.is_formal lhs_base (fst extras) && Typ.is_pointer (snd lhs_base) - && ( not (is_pointer_assignment tenv access_expr rhs) + FormalMap.is_formal lhs_base (fst extras) + && Typ.is_pointer (snd lhs_base) + && ( (not (is_pointer_assignment tenv access_expr rhs)) || not (AccessExpression.is_base access_expr) ) then let pre' = D.add access_expr (fst astate.prepost) in @@ -300,8 +305,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let uninit_vars = List.foldi ~init:astate.uninit_vars actuals ~f:(fun idx acc actual_exp -> match actual_exp with - | HilExp.AccessExpression access_expr - -> ( + | HilExp.AccessExpression access_expr -> ( let access_expr_to_remove = match access_expr with AddressOf ae -> ae | _ -> access_expr in @@ -320,15 +324,17 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | _ -> D.remove access_expr_to_remove acc ) | base - when Option.value_map ~default:false ~f:Typ.Procname.is_constructor pname_opt -> + when Option.value_map ~default:false ~f:Typ.Procname.is_constructor pname_opt + -> remove_all_fields tenv base (D.remove access_expr_to_remove acc) | (_, {Typ.desc= Tptr _}) as base -> ( match pname_opt with | Some pname when Config.uninit_interproc -> remove_initialized_params pdesc pname acc idx access_expr_to_remove true | _ -> - D.remove access_expr_to_remove acc |> remove_all_fields tenv base - |> remove_all_array_elements base |> remove_dereference_access base ) + D.remove access_expr_to_remove acc + |> remove_all_fields tenv base |> remove_all_array_elements base + |> remove_dereference_access base ) | _ -> acc ) | HilExp.Closure (_, apl) -> @@ -362,7 +368,7 @@ module Analyzer = let get_locals cfg tenv pdesc = List.fold - ~f:(fun acc (var_data: ProcAttributes.var_data) -> + ~f:(fun acc (var_data : ProcAttributes.var_data) -> let pvar = Pvar.mk var_data.name (Procdesc.get_proc_name pdesc) in let base_access_expr = AccessExpression.Base (Var.of_pvar pvar, var_data.typ) in match var_data.typ.Typ.desc with diff --git a/infer/src/checkers/uninitDomain.ml b/infer/src/checkers/uninitDomain.ml index 27e0a4b18..6c3900a04 100644 --- a/infer/src/checkers/uninitDomain.ml +++ b/infer/src/checkers/uninitDomain.ml @@ -39,7 +39,8 @@ struct ~rhs:({uninit_vars= rhs_uv; aliased_vars= rhs_av; prepost= rhs_pp} as rhs) = if phys_equal lhs rhs then true else - Domain1.( <= ) ~lhs:lhs_uv ~rhs:rhs_uv && Domain2.( <= ) ~lhs:lhs_av ~rhs:rhs_av + Domain1.( <= ) ~lhs:lhs_uv ~rhs:rhs_uv + && Domain2.( <= ) ~lhs:lhs_av ~rhs:rhs_av && Domain3.( <= ) ~lhs:(fst lhs_pp) ~rhs:(fst rhs_pp) && Domain3.( <= ) ~lhs:(snd lhs_pp) ~rhs:(snd rhs_pp) diff --git a/infer/src/clang/ALVar.ml b/infer/src/clang/ALVar.ml index 4e309b796..e734f2ddb 100644 --- a/infer/src/clang/ALVar.ml +++ b/infer/src/clang/ALVar.ml @@ -21,7 +21,7 @@ type alexp = Const of string | Regexp of cached_regexp | Var of string | FId of type t = alexp [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let formula_id_to_string fid = match fid with Formula_id s -> s diff --git a/infer/src/clang/CType.ml b/infer/src/clang/CType.ml index 04dc56579..904563af3 100644 --- a/infer/src/clang/CType.ml +++ b/infer/src/clang/CType.ml @@ -33,7 +33,7 @@ let is_class typ = false -let rec return_type_of_function_qual_type (qual_type: Clang_ast_t.qual_type) = +let rec return_type_of_function_qual_type (qual_type : Clang_ast_t.qual_type) = let open Clang_ast_t in match CAst_utils.get_type qual_type.qt_type_ptr with | Some (FunctionProtoType (_, function_type_info, _)) diff --git a/infer/src/clang/CType_decl.ml b/infer/src/clang/CType_decl.ml index 36e3ce65d..af5d4714d 100644 --- a/infer/src/clang/CType_decl.ml +++ b/infer/src/clang/CType_decl.ml @@ -37,8 +37,7 @@ module BuildMethodSignature = struct | CXXConstructorDecl (decl_info, _, _, _, _) | CXXConversionDecl (decl_info, _, _, _, _) | CXXDestructorDecl (decl_info, _, _, _, _) - | ObjCMethodDecl (decl_info, _, _) - -> ( + | ObjCMethodDecl (decl_info, _, _) -> ( let method_kind = CMethodProperties.get_method_kind method_decl in match method_kind with | ClangMethodKind.CPP_INSTANCE | ClangMethodKind.OBJC_INSTANCE -> ( @@ -286,7 +285,7 @@ let add_predefined_objc_types tenv = let add_predefined_types tenv = add_predefined_objc_types tenv -let create_c_record_typename (tag_kind: Clang_ast_t.tag_kind) = +let create_c_record_typename (tag_kind : Clang_ast_t.tag_kind) = match tag_kind with | `TTK_Struct | `TTK_Interface | `TTK_Enum -> Typ.Name.C.from_qual_name @@ -331,7 +330,7 @@ let get_translate_as_friend_decl decl_list = let qual_name = CAst_utils.get_qualified_name name_info in QualifiedCppName.Match.match_qualifiers translate_as_type_ptr_matcher qual_name in - let get_friend_decl_opt (decl: Clang_ast_t.decl) = + let get_friend_decl_opt (decl : Clang_ast_t.decl) = match decl with | FriendDecl (_, `Type type_ptr) -> CAst_utils.get_decl_from_typ_ptr type_ptr @@ -364,7 +363,7 @@ let get_record_definition decl = (_, _, _, _, _, _, {rdi_is_complete_definition; rdi_definition_ptr}, _, _, _) | CXXRecordDecl (_, _, _, _, _, _, {rdi_is_complete_definition; rdi_definition_ptr}, _) | RecordDecl (_, _, _, _, _, _, {rdi_is_complete_definition; rdi_definition_ptr}) - when not rdi_is_complete_definition && rdi_definition_ptr <> 0 -> + when (not rdi_is_complete_definition) && rdi_definition_ptr <> 0 -> CAst_utils.get_decl rdi_definition_ptr |> Option.value ~default:decl | _ -> decl @@ -384,7 +383,7 @@ let rec get_mangled_method_name function_decl_info method_decl_info = match method_decl_info.xmdi_overriden_methods with | [] -> function_decl_info.fdi_mangled_name - | base1_dr :: _ -> + | base1_dr :: _ -> ( let base1 = match CAst_utils.get_decl base1_dr.dr_decl_pointer with Some b -> b | _ -> assert false in @@ -395,7 +394,7 @@ let rec get_mangled_method_name function_decl_info method_decl_info = | CXXDestructorDecl (_, _, _, fdi, mdi) -> get_mangled_method_name fdi mdi | _ -> - assert false + assert false ) let rec get_struct_fields tenv decl = @@ -510,7 +509,7 @@ and add_types_from_decl_to_tenv tenv decl = assert false -and get_template_args tenv (tsi: Clang_ast_t.template_specialization_info) = +and get_template_args tenv (tsi : Clang_ast_t.template_specialization_info) = let rec aux = function | `Type qual_type -> [Typ.TType (qual_type_to_sil_type tenv qual_type)] @@ -532,7 +531,7 @@ and qual_type_to_sil_type tenv qual_type = CType_to_sil_type.qual_type_to_sil_type add_types_from_decl_to_tenv tenv qual_type -and get_template_info tenv (fdi: Clang_ast_t.function_decl_info) = +and get_template_info tenv (fdi : Clang_ast_t.function_decl_info) = match fdi.fdi_template_specialization with | Some spec_info -> Typ.Template {mangled= fdi.fdi_mangled_name; args= get_template_args tenv spec_info} @@ -549,7 +548,8 @@ and mk_c_function ?tenv name function_decl_info_opt parameters = (* when we model static functions, we cannot take the file into account to create a mangled name because the file of the model is different to the real file, thus the model won't work *) - when not (CTrans_models.is_modelled_static_function (QualifiedCppName.to_qual_string name)) -> + when not (CTrans_models.is_modelled_static_function (QualifiedCppName.to_qual_string name)) + -> let file_opt = (fst decl_info.Clang_ast_t.di_source_range).Clang_ast_t.sl_file |> Option.map ~f:SourceFile.from_abs_path @@ -645,7 +645,7 @@ and procname_from_decl ?tenv ?block_return_type ?outer_proc meth_decl = meth_decl in let parameter_types = - List.map ~f:(fun ({typ}: CMethodSignature.param_type) -> typ) parameters + List.map ~f:(fun ({typ} : CMethodSignature.param_type) -> typ) parameters in let captured_vars_types = BuildMethodSignature.types_of_captured_vars qual_type_to_sil_type tenv meth_decl @@ -696,8 +696,7 @@ and get_record_struct_type tenv definition_decl : Typ.desc = match definition_decl with | ClassTemplateSpecializationDecl (_, _, type_ptr, _, _, _, record_decl_info, _, _, _) | CXXRecordDecl (_, _, type_ptr, _, _, _, record_decl_info, _) - | RecordDecl (_, _, type_ptr, _, _, _, record_decl_info) - -> ( + | RecordDecl (_, _, type_ptr, _, _, _, record_decl_info) -> ( let sil_typename = get_record_typename ~tenv definition_decl in let sil_desc = Typ.Tstruct sil_typename in match Tenv.lookup tenv sil_typename with diff --git a/infer/src/clang/CType_decl.mli b/infer/src/clang/CType_decl.mli index 2284b7da7..f282efce1 100644 --- a/infer/src/clang/CType_decl.mli +++ b/infer/src/clang/CType_decl.mli @@ -9,8 +9,11 @@ open! IStd module CProcname : sig val from_decl : - ?tenv:Tenv.t -> ?block_return_type:Clang_ast_t.qual_type -> ?outer_proc:Typ.Procname.t - -> Clang_ast_t.decl -> Typ.Procname.t + ?tenv:Tenv.t + -> ?block_return_type:Clang_ast_t.qual_type + -> ?outer_proc:Typ.Procname.t + -> Clang_ast_t.decl + -> Typ.Procname.t (** Given decl, return its procname. This function should be used for all procedures present in original AST *) @@ -48,11 +51,17 @@ val class_from_pointer_type : Tenv.t -> Clang_ast_t.qual_type -> Typ.Name.t val get_type_from_expr_info : Clang_ast_t.expr_info -> Tenv.t -> Typ.t val method_signature_of_decl : - Tenv.t -> Clang_ast_t.decl -> ?block_return_type:Clang_ast_t.qual_type -> Typ.Procname.t + Tenv.t + -> Clang_ast_t.decl + -> ?block_return_type:Clang_ast_t.qual_type + -> Typ.Procname.t -> CMethodSignature.t val method_signature_body_of_decl : - Tenv.t -> Clang_ast_t.decl -> ?block_return_type:Clang_ast_t.qual_type -> Typ.Procname.t + Tenv.t + -> Clang_ast_t.decl + -> ?block_return_type:Clang_ast_t.qual_type + -> Typ.Procname.t -> CMethodSignature.t * Clang_ast_t.stmt option * [> `CXXConstructorInit of Clang_ast_t.cxx_ctor_initializer] list diff --git a/infer/src/clang/Capture.ml b/infer/src/clang/Capture.ml index fdac132ff..dcccae681 100644 --- a/infer/src/clang/Capture.ml +++ b/infer/src/clang/Capture.ml @@ -152,7 +152,7 @@ let cc1_capture clang_cmd = L.(debug Capture Quiet) "@\n*** Beginning capture of file %s ***@\n" source_path ; if Config.equal_analyzer Config.analyzer Config.CompileOnly - || not Config.skip_analysis_in_path_skips_compilation + || (not Config.skip_analysis_in_path_skips_compilation) && CLocation.is_file_blacklisted source_path then ( L.(debug Capture Quiet) "@\n Skip the analysis of source file %s@\n@\n" source_path ; diff --git a/infer/src/clang/ClangCommand.ml b/infer/src/clang/ClangCommand.ml index b1ed8a051..cd069d1eb 100644 --- a/infer/src/clang/ClangCommand.ml +++ b/infer/src/clang/ClangCommand.ml @@ -65,7 +65,8 @@ let can_attach_ast_exporter cmd = in (* -Eonly is -cc1 flag that gets produced by 'clang -M -### ...' *) let is_preprocessor_only cmd = has_flag cmd "-E" || has_flag cmd "-Eonly" in - (cmd.is_driver || has_flag cmd "-cc1") && is_supported_language cmd + (cmd.is_driver || has_flag cmd "-cc1") + && is_supported_language cmd && not (is_preprocessor_only cmd) @@ -84,8 +85,8 @@ let include_override_regex = Option.map ~f:Str.regexp Config.clang_include_to_ov (** Filter arguments from [args], looking into argfiles too. [replace_options_arg prev arg] returns [arg'], where [arg'] is the new version of [arg] given the preceding arguments (in reverse order) [prev]. *) -let filter_and_replace_unsupported_args ?(replace_options_arg= fun _ s -> s) - ?(blacklisted_flags= []) ?(blacklisted_flags_with_arg= []) ?(post_args= []) args = +let filter_and_replace_unsupported_args ?(replace_options_arg = fun _ s -> s) + ?(blacklisted_flags = []) ?(blacklisted_flags_with_arg = []) ?(post_args = []) args = (* [prev] is the previously seen argument, [res_rev] is the reversed result, [changed] is true if some change has been performed *) let rec aux in_argfiles (prev_is_blacklisted_with_arg, res_rev, changed) args = @@ -98,7 +99,7 @@ let filter_and_replace_unsupported_args ?(replace_options_arg= fun _ s -> s) aux in_argfiles (false, res_rev, true) tl | at_argfile :: tl when String.is_prefix at_argfile ~prefix:"@" && not (String.Set.mem in_argfiles at_argfile) - -> ( + -> ( let in_argfiles' = String.Set.add in_argfiles at_argfile in let argfile = String.slice at_argfile 1 (String.length at_argfile) in match In_channel.read_lines argfile with @@ -169,7 +170,8 @@ let clang_cc1_cmd_sanitizer cmd = if Config.bufferoverrun && not Config.biabduction then ["-D__INFER_BUFFEROVERRUN"] else [] in let post_args_rev = - [] |> List.rev_append ["-include"; Config.lib_dir ^/ "clang_wrappers" ^/ "global_defines.h"] + [] + |> List.rev_append ["-include"; Config.lib_dir ^/ "clang_wrappers" ^/ "global_defines.h"] |> List.rev_append args_defines |> (* Never error on warnings. Clang is often more strict than Apple's version. These arguments are appended at the end to override previous opposite settings. How it's done: suppress @@ -214,7 +216,8 @@ let to_unescaped_args cmd = let pp f cmd = to_unescaped_args cmd |> Pp.cli_args f let command_to_run cmd = - to_unescaped_args cmd |> List.map ~f:(ClangQuotes.quote cmd.quoting_style) + to_unescaped_args cmd + |> List.map ~f:(ClangQuotes.quote cmd.quoting_style) |> String.concat ~sep:" " diff --git a/infer/src/clang/ClangLogging.ml b/infer/src/clang/ClangLogging.ml index 03ce73a53..2188bd901 100644 --- a/infer/src/clang/ClangLogging.ml +++ b/infer/src/clang/ClangLogging.ml @@ -6,7 +6,7 @@ *) open! IStd -let log_frontend_exception (trans_unit_ctx: CFrontend_config.translation_unit_context) +let log_frontend_exception (trans_unit_ctx : CFrontend_config.translation_unit_context) exception_type exception_triggered_location (source_location_start, source_location_end) ast_node = let frontend_exception = diff --git a/infer/src/clang/ClangLogging.mli b/infer/src/clang/ClangLogging.mli index f3e460454..e12ae1214 100644 --- a/infer/src/clang/ClangLogging.mli +++ b/infer/src/clang/ClangLogging.mli @@ -8,12 +8,19 @@ open! IStd val log_caught_exception : - CFrontend_config.translation_unit_context -> string -> Logging.ocaml_pos - -> Clang_ast_t.source_location * Clang_ast_t.source_location -> string option -> unit + CFrontend_config.translation_unit_context + -> string + -> Logging.ocaml_pos + -> Clang_ast_t.source_location * Clang_ast_t.source_location + -> string option + -> unit val log_broken_cfg : broken_node:[`Join | `Other] -> Procdesc.t -> Logging.ocaml_pos -> lang:string -> unit val log_unexpected_decl : - CFrontend_config.translation_unit_context -> Logging.ocaml_pos - -> Clang_ast_t.source_location * Clang_ast_t.source_location -> string option -> unit + CFrontend_config.translation_unit_context + -> Logging.ocaml_pos + -> Clang_ast_t.source_location * Clang_ast_t.source_location + -> string option + -> unit diff --git a/infer/src/clang/ClangPointers.ml b/infer/src/clang/ClangPointers.ml index 6715d50f5..f7b212135 100644 --- a/infer/src/clang/ClangPointers.ml +++ b/infer/src/clang/ClangPointers.ml @@ -20,8 +20,8 @@ let pointer_type_table = Int.Table.create ~size:256 () let empty_v = Clang_ast_visit.empty_visitor (* This function is not thread-safe *) -let visit_ast ?(visit_decl= empty_v) ?(visit_stmt= empty_v) ?(visit_type= empty_v) - ?(visit_src_loc= empty_v) top_decl = +let visit_ast ?(visit_decl = empty_v) ?(visit_stmt = empty_v) ?(visit_type = empty_v) + ?(visit_src_loc = empty_v) top_decl = Clang_ast_visit.decl_visitor := visit_decl ; Clang_ast_visit.stmt_visitor := visit_stmt ; Clang_ast_visit.type_visitor := visit_type ; diff --git a/infer/src/clang/ClangWrapper.ml b/infer/src/clang/ClangWrapper.ml index dc5e21143..bbaa70ff0 100644 --- a/infer/src/clang/ClangWrapper.ml +++ b/infer/src/clang/ClangWrapper.ml @@ -9,6 +9,7 @@ is being done and which source files are being compiled, if any, then replace compilation commands by our own clang with our plugin attached for each source file. *) open! IStd + module L = Logging type action_item = @@ -35,11 +36,9 @@ let check_for_existing_file args = () | option :: rest -> if String.equal option "-c" then - match - (* infer-capture-all flavour of buck produces path to generated file that doesn't exist. + (* infer-capture-all flavour of buck produces path to generated file that doesn't exist. Create empty file empty file and pass that to clang. This is to enable compilation to continue *) - (clang_ignore_regex, List.hd rest) - with + match (clang_ignore_regex, List.hd rest) with | Some regexp, Some arg -> if Str.string_match regexp arg 0 && Sys.file_exists arg <> `Yes then ( Unix.mkdir_p (Filename.dirname arg) ; @@ -80,11 +79,11 @@ let clang_driver_action_items : ClangCommand.t -> action_item list = let one_line line = if String.is_prefix ~prefix:" \"" line then CanonicalCommand - ( match - (* massage line to remove edge-cases for splitting *) - "\"" ^ line ^ " \"" |> (* split by whitespace *) - Str.split (Str.regexp_string "\" \"") - with + ( (* massage line to remove edge-cases for splitting *) + match + "\"" ^ line ^ " \"" |> (* split by whitespace *) + Str.split (Str.regexp_string "\" \"") + with | prog :: args -> ClangCommand.mk ~is_driver:false ClangQuotes.EscapedDoubleQuotes ~prog ~args | [] -> @@ -183,5 +182,5 @@ let exe ~prog ~args = "WARNING: `clang -### ` returned an empty set of commands to run and no error. Will \ run the original command directly:@\n \ %s@\n" - (String.concat ~sep:" " @@ prog :: args) ; + (String.concat ~sep:" " @@ (prog :: args)) ; Process.create_process_and_wait ~prog ~args ) diff --git a/infer/src/clang/ComponentKit.ml b/infer/src/clang/ComponentKit.ml index 7254c0c49..17429229d 100644 --- a/infer/src/clang/ComponentKit.ml +++ b/infer/src/clang/ComponentKit.ml @@ -30,8 +30,9 @@ let is_in_main_file translation_unit_context an = translation_unit_context.CFrontend_config.source_file -let is_ck_context (context: CLintersContext.context) an = - context.is_ck_translation_unit && is_in_main_file context.translation_unit_context an +let is_ck_context (context : CLintersContext.context) an = + context.is_ck_translation_unit + && is_in_main_file context.translation_unit_context an && CGeneral_utils.is_objc_extension context.translation_unit_context @@ -89,7 +90,7 @@ and contains_ck_impl decl_list = ``` *) let mutable_local_vars_advice context an = try - let rec get_referenced_type (qual_type: Clang_ast_t.qual_type) : Clang_ast_t.decl option = + let rec get_referenced_type (qual_type : Clang_ast_t.qual_type) : Clang_ast_t.decl option = let typ_opt = CAst_utils.get_desugared_type qual_type.qt_type_ptr in match (typ_opt : Clang_ast_t.c_type option) with | Some (ObjCInterfaceType (_, decl_ptr)) | Some (RecordType (_, decl_ptr)) -> @@ -138,10 +139,12 @@ let mutable_local_vars_advice context an = false in let should_not_report_mutable_local = - CAst_utils.is_syntactically_global_var decl || CAst_utils.is_static_local_var decl + CAst_utils.is_syntactically_global_var decl + || CAst_utils.is_static_local_var decl || is_const || is_of_whitelisted_type qual_type || decl_info.di_is_implicit || context.CLintersContext.in_for_loop_declaration - || CAst_utils.is_std_vector qual_type || CAst_utils.has_block_attribute decl + || CAst_utils.is_std_vector qual_type + || CAst_utils.has_block_attribute decl || name_is decl "weakSelf" || name_is decl "strongSelf" in if should_not_report_mutable_local then None @@ -152,7 +155,8 @@ let mutable_local_vars_advice context an = ; severity= Exceptions.Advice ; mode= CIssue.On ; description= - "Local variable " ^ MF.monospaced_to_string named_decl_info.ni_name + "Local variable " + ^ MF.monospaced_to_string named_decl_info.ni_name ^ " should be const to avoid reassignment" ; suggestion= Some "Add a const (after the asterisk for pointer types)." ; doc_url= None @@ -180,7 +184,7 @@ let component_factory_function_advice context an = if is_ck_context context an then match an with | Ctl_parser_types.Decl - (Clang_ast_t.FunctionDecl (decl_info, _, (qual_type: Clang_ast_t.qual_type), _)) -> + (Clang_ast_t.FunctionDecl (decl_info, _, (qual_type : Clang_ast_t.qual_type), _)) -> let objc_interface = CAst_utils.qual_type_to_objc_interface qual_type in if is_component_if objc_interface then Some @@ -228,7 +232,8 @@ let component_with_unconventional_superclass_advice context an = ; "CKCompositeComponent" ; "CKStatefulViewComponent" ; "CKStatefulViewComponentController" - ; "NTNativeTemplateComponent" ] name -> + ; "NTNativeTemplateComponent" ] + name -> true | _ -> false @@ -280,7 +285,7 @@ let component_with_multiple_factory_methods_advice context an = let is_unavailable_attr attr = match attr with Clang_ast_t.UnavailableAttr _ -> true | _ -> false in - let is_available_factory_method if_decl (decl: Clang_ast_t.decl) = + let is_available_factory_method if_decl (decl : Clang_ast_t.decl) = match decl with | ObjCMethodDecl (decl_info, _, _) -> let unavailable_attrs = @@ -314,8 +319,7 @@ let component_with_multiple_factory_methods_advice context an = assert false in match an with - | Ctl_parser_types.Decl (Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info)) - -> ( + | Ctl_parser_types.Decl (Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info)) -> ( let if_decl_opt = CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface in @@ -324,13 +328,13 @@ let component_with_multiple_factory_methods_advice context an = [] -let in_ck_class (context: CLintersContext.context) = +let in_ck_class (context : CLintersContext.context) = Option.value_map ~f:is_component_or_controller_descendant_impl ~default:false context.current_objc_class && CGeneral_utils.is_objc_extension context.translation_unit_context -let is_in_factory_method (context: CLintersContext.context) = +let is_in_factory_method (context : CLintersContext.context) = let interface_decl_opt = match context.current_objc_class with | Some (ObjCImplementationDecl (_, _, _, _, impl_decl_info)) -> @@ -359,7 +363,7 @@ let is_in_factory_method (context: CLintersContext.context) = relies on other threads (dispatch_sync). Other side-effects, like reading of global variables, is not checked by this analyzer, although still an infraction of the rule. *) -let rec component_initializer_with_side_effects_advice_ (context: CLintersContext.context) +let rec component_initializer_with_side_effects_advice_ (context : CLintersContext.context) call_stmt = let condition = in_ck_class context && is_in_factory_method context @@ -374,8 +378,7 @@ let rec component_initializer_with_side_effects_advice_ (context: CLintersContex match call_stmt with | Clang_ast_t.ImplicitCastExpr (_, stmt :: _, _, _) -> component_initializer_with_side_effects_advice_ context stmt - | Clang_ast_t.DeclRefExpr (_, _, _, decl_ref_expr_info) - -> ( + | Clang_ast_t.DeclRefExpr (_, _, _, decl_ref_expr_info) -> ( let refs = [decl_ref_expr_info.drti_decl_ref; decl_ref_expr_info.drti_found_decl_ref] in match List.find_map ~f:CAst_utils.name_of_decl_ref_opt refs with | Some "dispatch_after" | Some "dispatch_async" | Some "dispatch_sync" -> @@ -396,7 +399,7 @@ let rec component_initializer_with_side_effects_advice_ (context: CLintersContex else None -let component_initializer_with_side_effects_advice (context: CLintersContext.context) an = +let component_initializer_with_side_effects_advice (context : CLintersContext.context) an = match an with | Ctl_parser_types.Stmt (CallExpr (_, called_func_stmt :: _, _)) -> component_initializer_with_side_effects_advice_ context called_func_stmt @@ -410,7 +413,7 @@ let component_initializer_with_side_effects_advice (context: CLintersContext.con This still needs to be in infer b/c only files that have a valid component kit class impl should be analyzed. *) -let component_file_line_count_info (context: CLintersContext.context) dec = +let component_file_line_count_info (context : CLintersContext.context) dec = let condition = Config.compute_analytics && context.is_ck_translation_unit in match dec with | Ctl_parser_types.Decl (Clang_ast_t.TranslationUnitDecl _) when condition -> @@ -436,7 +439,7 @@ let component_file_line_count_info (context: CLintersContext.context) dec = Somewhat borrowed from https://github.com/oclint/oclint/blob/5889b5ec168185513ba69ce83821ea1cc8e63fbe /oclint-metrics/lib/CyclomaticComplexityMetric.cpp *) -let component_file_cyclomatic_complexity_info (context: CLintersContext.context) an = +let component_file_cyclomatic_complexity_info (context : CLintersContext.context) an = let is_cyclo_stmt stmt = match stmt with | Clang_ast_t.IfStmt _ diff --git a/infer/src/clang/SwitchCase.mli b/infer/src/clang/SwitchCase.mli index 1c9707e04..0795b19fb 100644 --- a/infer/src/clang/SwitchCase.mli +++ b/infer/src/clang/SwitchCase.mli @@ -16,6 +16,6 @@ val in_switch_body : f:('a -> 'b) -> 'a -> t list * 'b val add : t -> unit -val pp_condition : F.formatter -> condition -> unit [@@warning "-32"] +val pp_condition : F.formatter -> condition -> unit [@@warning "-32"] -val pp : F.formatter -> t -> unit [@@warning "-32"] +val pp : F.formatter -> t -> unit [@@warning "-32"] diff --git a/infer/src/clang/ast_expressions.ml b/infer/src/clang/ast_expressions.ml index 68279a8d7..947587583 100644 --- a/infer/src/clang/ast_expressions.ml +++ b/infer/src/clang/ast_expressions.ml @@ -14,7 +14,7 @@ let stmt_info_with_fresh_pointer stmt_info = ; si_source_range= stmt_info.Clang_ast_t.si_source_range } -let create_qual_type ?(quals= Typ.mk_type_quals ()) qt_type_ptr = +let create_qual_type ?(quals = Typ.mk_type_quals ()) qt_type_ptr = { Clang_ast_t.qt_type_ptr ; qt_is_const= Typ.is_const quals ; qt_is_volatile= Typ.is_volatile quals @@ -159,7 +159,7 @@ let make_next_object_exp stmt_info item items = (Clang_ast_t.DeclRefExpr (stmt_info_var, [], expr_info, decl_ref_expr_info), var_qual_type) | Clang_ast_t.DeclRefExpr (_, _, expr_info, _) -> (item, expr_info.Clang_ast_t.ei_qual_type) - | stmt -> + | stmt -> ( let _, stmts = Clang_ast_proj.get_stmt_tuple stmt in match stmts with | [stmt] -> @@ -168,7 +168,7 @@ let make_next_object_exp stmt_info item items = CFrontend_config.incorrect_assumption __POS__ stmt_info.Clang_ast_t.si_source_range "unexpected item %a" (Pp.to_string ~f:Clang_ast_j.string_of_stmt) - item + item ) in let var_decl_ref, var_type = get_decl_ref item in let message_call = diff --git a/infer/src/clang/cArithmetic_trans.ml b/infer/src/clang/cArithmetic_trans.ml index e7c63bda4..f7d8cbfae 100644 --- a/infer/src/clang/cArithmetic_trans.ml +++ b/infer/src/clang/cArithmetic_trans.ml @@ -49,7 +49,7 @@ let compound_assignment_binary_operation_instruction boi_kind (e1, t1) typ e2 lo calculating an expression "instructions" is not empty when the binary operator is actually a statement like an assignment. *) let binary_operation_instruction source_range boi ((e1, t1) as e1_with_typ) typ (e2, t2) loc = - let binop_exp ?(change_order= false) op = + let binop_exp ?(change_order = false) op = if change_order then Exp.BinOp (op, e2, e1) else Exp.BinOp (op, e1, e2) in match boi.Clang_ast_t.boi_kind with @@ -58,8 +58,7 @@ let binary_operation_instruction source_range boi ((e1, t1) as e1_with_typ) typ an integer offset, which is itself semantically ok though too low-level, but the translation of the argument expressions does not compute such offsets and instead passes the member pointer at type 'void'. *) - | `PtrMemD - | `PtrMemI -> + | `PtrMemD | `PtrMemI -> CFrontend_config.unimplemented __POS__ source_range "Pointer-to-member constructs are unsupported. Got '%a'." (Pp.to_string ~f:Clang_ast_j.string_of_binary_operator_info) diff --git a/infer/src/clang/cArithmetic_trans.mli b/infer/src/clang/cArithmetic_trans.mli index d0cebed22..5db1b10e4 100644 --- a/infer/src/clang/cArithmetic_trans.mli +++ b/infer/src/clang/cArithmetic_trans.mli @@ -12,14 +12,23 @@ open! IStd val bin_op_to_string : Clang_ast_t.binary_operator_info -> string val binary_operation_instruction : - Clang_ast_t.source_range -> Clang_ast_t.binary_operator_info -> Exp.t * Typ.t -> Typ.t - -> Exp.t * Typ.t -> Location.t -> Exp.t * Sil.instr list + Clang_ast_t.source_range + -> Clang_ast_t.binary_operator_info + -> Exp.t * Typ.t + -> Typ.t + -> Exp.t * Typ.t + -> Location.t + -> Exp.t * Sil.instr list (** Returns a pair ([binary_expression], instructions). "binary_expression" is returned when we are calculating an expression "instructions" is not empty when the binary operator is actually a statement like an assignment. *) val unary_operation_instruction : - CFrontend_config.translation_unit_context -> Clang_ast_t.unary_operator_info -> Exp.t -> Typ.t - -> Location.t -> Exp.t * Sil.instr list + CFrontend_config.translation_unit_context + -> Clang_ast_t.unary_operator_info + -> Exp.t + -> Typ.t + -> Location.t + -> Exp.t * Sil.instr list val sil_const_plus_one : Exp.t -> Exp.t diff --git a/infer/src/clang/cAst_utils.ml b/infer/src/clang/cAst_utils.ml index e3c6cec2a..b40681515 100644 --- a/infer/src/clang/cAst_utils.ml +++ b/infer/src/clang/cAst_utils.ml @@ -15,8 +15,11 @@ module L = Logging type qual_type_to_sil_type = Tenv.t -> Clang_ast_t.qual_type -> Typ.t type procname_from_decl = - ?tenv:Tenv.t -> ?block_return_type:Clang_ast_t.qual_type -> ?outer_proc:Typ.Procname.t - -> Clang_ast_t.decl -> Typ.Procname.t + ?tenv:Tenv.t + -> ?block_return_type:Clang_ast_t.qual_type + -> ?outer_proc:Typ.Procname.t + -> Clang_ast_t.decl + -> Typ.Procname.t let sanitize_name s = Str.global_replace (Str.regexp "[/ ]") "_" s @@ -24,7 +27,7 @@ let get_qual_name qual_name_list = List.map ~f:sanitize_name qual_name_list |> QualifiedCppName.of_rev_list -let get_qualified_name ?(linters_mode= false) name_info = +let get_qualified_name ?(linters_mode = false) name_info = if not linters_mode then get_qual_name name_info.Clang_ast_t.ni_qual_name else (* Because we are in linters mode, we can't get precise info about templates, @@ -142,8 +145,7 @@ let get_type type_ptr = let get_desugared_type type_ptr = let typ_opt = get_type type_ptr in match typ_opt with - | Some typ - -> ( + | Some typ -> ( let type_info = Clang_ast_proj.get_type_tuple typ in match type_info.Clang_ast_t.ti_desugared_type with Some ptr -> get_type ptr | _ -> typ_opt ) | _ -> @@ -201,7 +203,7 @@ let name_opt_of_typedef_qual_type qual_type = let qual_type_of_decl_ptr decl_ptr = { (* This function needs to be in this module - CAst_utils can't depend on Ast_expressions *) - Clang_ast_t.qt_type_ptr= Clang_ast_extend.DeclPtr decl_ptr + Clang_ast_t.qt_type_ptr= Clang_ast_extend.DeclPtr decl_ptr ; qt_is_const= false ; qt_is_volatile= false ; qt_is_restrict= false } @@ -239,7 +241,7 @@ let get_function_decl_with_body decl_ptr = | _ -> Some decl_ptr in - if [%compare.equal : int option] 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' @@ -349,7 +351,7 @@ let get_impl_decl_info dec = let default_blacklist = CFrontend_config.[nsobject_cl; nsproxy_cl] -let rec is_objc_if_descendant ?(blacklist= default_blacklist) if_decl ancestors = +let rec is_objc_if_descendant ?(blacklist = default_blacklist) if_decl ancestors = (* List of ancestors to check for and list of classes to short-circuit to false can't intersect *) if not String.Set.(is_empty (inter (of_list blacklist) (of_list ancestors))) then @@ -358,7 +360,7 @@ let rec is_objc_if_descendant ?(blacklist= default_blacklist) if_decl ancestors match if_decl with | Some (Clang_ast_t.ObjCInterfaceDecl (_, ndi, _, _, _)) -> let in_list some_list = List.mem ~equal:String.equal some_list ndi.Clang_ast_t.ni_name in - not (in_list blacklist) + (not (in_list blacklist)) && (in_list ancestors || is_objc_if_descendant ~blacklist (get_super_if if_decl) ancestors) | _ -> false @@ -373,7 +375,7 @@ and ctype_to_objc_interface typ_opt = match (typ_opt : Clang_ast_t.c_type option) with | Some (ObjCInterfaceType (_, decl_ptr)) -> get_decl decl_ptr - | Some (ObjCObjectPointerType (_, (inner_qual_type: Clang_ast_t.qual_type))) -> + | Some (ObjCObjectPointerType (_, (inner_qual_type : Clang_ast_t.qual_type))) -> qual_type_to_objc_interface inner_qual_type | Some (FunctionProtoType (_, function_type_info, _)) | Some (FunctionNoProtoType (_, function_type_info)) -> @@ -402,7 +404,7 @@ let return_type_matches_class_type result_type interface_decl = if is_instance_type result_type then true else let return_type_decl_opt = qual_type_to_objc_interface result_type in - [%compare.equal : int option] + [%compare.equal: int option] (if_decl_to_di_pointer_opt interface_decl) (if_decl_to_di_pointer_opt return_type_decl_opt) @@ -411,13 +413,13 @@ let is_objc_factory_method ~class_decl:interface_decl ~method_decl:meth_decl_opt let open Clang_ast_t in match meth_decl_opt with | Some (ObjCMethodDecl (_, _, omdi)) -> - not omdi.omdi_is_instance_method + (not omdi.omdi_is_instance_method) && return_type_matches_class_type omdi.omdi_result_type interface_decl | _ -> false -let name_of_decl_ref_opt (decl_ref_opt: Clang_ast_t.decl_ref option) = +let name_of_decl_ref_opt (decl_ref_opt : Clang_ast_t.decl_ref option) = match decl_ref_opt with | Some decl_ref -> ( match decl_ref.dr_name with Some named_decl_info -> Some named_decl_info.ni_name | _ -> None ) @@ -529,7 +531,7 @@ let is_implicit_decl decl = decl_info.Clang_ast_t.di_is_implicit -let get_superclass_curr_class_objc_from_decl (decl: Clang_ast_t.decl) = +let get_superclass_curr_class_objc_from_decl (decl : Clang_ast_t.decl) = match decl with | ObjCInterfaceDecl (_, _, _, _, otdi) -> otdi.otdi_super diff --git a/infer/src/clang/cAst_utils.mli b/infer/src/clang/cAst_utils.mli index ab3abefed..dbbeec715 100644 --- a/infer/src/clang/cAst_utils.mli +++ b/infer/src/clang/cAst_utils.mli @@ -63,8 +63,11 @@ val name_opt_of_typedef_qual_type : Clang_ast_t.qual_type -> QualifiedCppName.t type qual_type_to_sil_type = Tenv.t -> Clang_ast_t.qual_type -> Typ.t type procname_from_decl = - ?tenv:Tenv.t -> ?block_return_type:Clang_ast_t.qual_type -> ?outer_proc:Typ.Procname.t - -> Clang_ast_t.decl -> Typ.Procname.t + ?tenv:Tenv.t + -> ?block_return_type:Clang_ast_t.qual_type + -> ?outer_proc:Typ.Procname.t + -> Clang_ast_t.decl + -> Typ.Procname.t val qual_type_of_decl_ptr : Clang_ast_t.pointer -> Clang_ast_t.qual_type diff --git a/infer/src/clang/cContext.mli b/infer/src/clang/cContext.mli index 936946a1f..5cd467078 100644 --- a/infer/src/clang/cContext.mli +++ b/infer/src/clang/cContext.mli @@ -44,8 +44,15 @@ val is_objc_method : t -> bool val is_objc_class_method : t -> bool val create_context : - CFrontend_config.translation_unit_context -> Tenv.t -> Cfg.t -> Procdesc.t -> curr_class - -> Typ.t option -> t option -> Clang_ast_t.decl list StmtMap.t -> t + CFrontend_config.translation_unit_context + -> Tenv.t + -> Cfg.t + -> Procdesc.t + -> curr_class + -> Typ.t option + -> t option + -> Clang_ast_t.decl list StmtMap.t + -> t val add_block_static_var : t -> Typ.Procname.t -> Pvar.t * Typ.t -> unit diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index 6e0837c69..df88dc074 100644 --- a/infer/src/clang/cField_decl.ml +++ b/infer/src/clang/cField_decl.ml @@ -66,13 +66,12 @@ let build_sil_field qual_type_to_sil_type tenv class_tname field_name qual_type (* Given a list of declarations in an interface returns a list of fields *) let get_fields qual_type_to_sil_type tenv class_tname decl_list = let open Clang_ast_t in - let get_sil_field name_info (qt: qual_type) property_attributes = + let get_sil_field name_info (qt : qual_type) property_attributes = build_sil_field qual_type_to_sil_type tenv class_tname name_info qt property_attributes in let rec get_field fields decl = match decl with - | ObjCPropertyDecl (_, _, obj_c_property_decl_info) - -> ( + | ObjCPropertyDecl (_, _, obj_c_property_decl_info) -> ( let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in let property_attributes = obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes in match CAst_utils.get_decl_opt_with_decl_ref ivar_decl_ref with @@ -81,8 +80,7 @@ let get_fields qual_type_to_sil_type tenv class_tname decl_list = CGeneral_utils.add_no_duplicates_fields field fields | _ -> fields ) - | ObjCPropertyImplDecl (_, obj_c_property_impl_decl_info) - -> ( + | ObjCPropertyImplDecl (_, obj_c_property_impl_decl_info) -> ( let property_decl_opt = obj_c_property_impl_decl_info.Clang_ast_t.opidi_property_decl in match CAst_utils.get_decl_opt_with_decl_ref property_decl_opt with | Some decl -> diff --git a/infer/src/clang/cField_decl.mli b/infer/src/clang/cField_decl.mli index cd174af17..2b869738e 100644 --- a/infer/src/clang/cField_decl.mli +++ b/infer/src/clang/cField_decl.mli @@ -12,7 +12,10 @@ open! IStd type field_type = Typ.Fieldname.t * Typ.t * (Annot.t * bool) list val get_fields : - CAst_utils.qual_type_to_sil_type -> Tenv.t -> Typ.Name.t -> Clang_ast_t.decl list + CAst_utils.qual_type_to_sil_type + -> Tenv.t + -> Typ.Name.t + -> Clang_ast_t.decl list -> field_type list val fields_superclass : Tenv.t -> Clang_ast_t.obj_c_interface_decl_info -> field_type list diff --git a/infer/src/clang/cFrontend.ml b/infer/src/clang/cFrontend.ml index de69dc9c9..bbd70eb2c 100644 --- a/infer/src/clang/cFrontend.ml +++ b/infer/src/clang/cFrontend.ml @@ -42,7 +42,7 @@ let init_global_state_capture () = CFrontend_config.reset_block_counter () -let do_source_file (translation_unit_context: CFrontend_config.translation_unit_context) ast = +let do_source_file (translation_unit_context : CFrontend_config.translation_unit_context) ast = let tenv = Tenv.create () in CType_decl.add_predefined_types tenv ; init_global_state_capture () ; diff --git a/infer/src/clang/cFrontend_checkers.ml b/infer/src/clang/cFrontend_checkers.ml index e6b476876..274e616a7 100644 --- a/infer/src/clang/cFrontend_checkers.ml +++ b/infer/src/clang/cFrontend_checkers.ml @@ -101,8 +101,7 @@ let receiver_method_call an = let ivar_name an = let open Clang_ast_t in match an with - | Ctl_parser_types.Stmt (ObjCIvarRefExpr (_, _, _, rei)) - -> ( + | Ctl_parser_types.Stmt (ObjCIvarRefExpr (_, _, _, rei)) -> ( let dr_ref = rei.ovrei_decl_ref in let ivar_pointer = dr_ref.dr_decl_pointer in match CAst_utils.get_decl ivar_pointer with @@ -144,8 +143,7 @@ let class_name node = "" in match CPredicates.get_ast_node_type_ptr node with - | Some type_ptr - -> ( + | Some type_ptr -> ( let typ = CAst_utils.get_desugared_type type_ptr in match typ with | Some (ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr})) -> diff --git a/infer/src/clang/cFrontend_checkers_main.ml b/infer/src/clang/cFrontend_checkers_main.ml index b65acf83d..ce5df2b8f 100644 --- a/infer/src/clang/cFrontend_checkers_main.ml +++ b/infer/src/clang/cFrontend_checkers_main.ml @@ -175,7 +175,7 @@ let rec get_ios_available_version stmt = None -let compute_if_context (context: CLintersContext.context) stmt = +let compute_if_context (context : CLintersContext.context) stmt = let selector = get_responds_to_selector stmt in let receiver_class_method_call = match @@ -205,7 +205,7 @@ let compute_if_context (context: CLintersContext.context) stmt = in Some ( {within_responds_to_selector_block; within_available_class_block; ios_version_guard} - : CLintersContext.if_context ) + : CLintersContext.if_context ) let get_method_body_opt decl = @@ -230,8 +230,8 @@ let call_tableaux cxt an map_active = if CFrontend_config.tableaux_evaluation then Tableaux.build_valuation an cxt map_active -let rec do_frontend_checks_stmt (context: CLintersContext.context) - (map_act: Tableaux.context_linter_map) stmt = +let rec do_frontend_checks_stmt (context : CLintersContext.context) + (map_act : Tableaux.context_linter_map) stmt = let open Clang_ast_t in let an = Ctl_parser_types.Stmt stmt in (*L.(debug Linters Medium) @@ -304,8 +304,8 @@ and do_frontend_checks_via_transition context map_active an trans = succs -and do_frontend_checks_decl (context: CLintersContext.context) - (map_act: Tableaux.context_linter_map) decl = +and do_frontend_checks_decl (context : CLintersContext.context) + (map_act : Tableaux.context_linter_map) decl = let open Clang_ast_t in if CAst_utils.is_implicit_decl decl then () (* do not analyze implicit declarations *) else @@ -373,7 +373,7 @@ let linters_files = List.dedup_and_sort ~compare:String.compare (find_linters_files () @ Config.linters_def_file) -let do_frontend_checks (trans_unit_ctx: CFrontend_config.translation_unit_context) ast = +let do_frontend_checks (trans_unit_ctx : CFrontend_config.translation_unit_context) ast = L.(debug Capture Quiet) "Loading the following linters files: %a@\n" (Pp.comma_seq Format.pp_print_string) diff --git a/infer/src/clang/cFrontend_config.ml b/infer/src/clang/cFrontend_config.ml index 1012f14c3..8ba3a1deb 100644 --- a/infer/src/clang/cFrontend_config.ml +++ b/infer/src/clang/cFrontend_config.ml @@ -12,11 +12,11 @@ module F = Format type clang_lang = C | CPP | ObjC | ObjCPP [@@deriving compare] -let string_of_clang_lang (lang: clang_lang) : string = +let string_of_clang_lang (lang : clang_lang) : string = match lang with C -> "C" | CPP -> "CPP" | ObjC -> "ObjC" | ObjCPP -> "ObjCPP" -let equal_clang_lang = [%compare.equal : clang_lang] +let equal_clang_lang = [%compare.equal: clang_lang] type exception_details = { msg: string diff --git a/infer/src/clang/cFrontend_config.mli b/infer/src/clang/cFrontend_config.mli index d3967022a..bec9bc372 100644 --- a/infer/src/clang/cFrontend_config.mli +++ b/infer/src/clang/cFrontend_config.mli @@ -24,16 +24,22 @@ type exception_details = exception Unimplemented of exception_details val unimplemented : - Logging.ocaml_pos -> Clang_ast_t.source_range -> ?ast_node:string - -> ('a, Format.formatter, unit, _) format4 -> 'a + Logging.ocaml_pos + -> Clang_ast_t.source_range + -> ?ast_node:string + -> ('a, Format.formatter, unit, _) format4 + -> 'a (** Raise Unimplemented. This is caught at the level of translating a method and makes the frontend give up on that method. *) exception IncorrectAssumption of exception_details val incorrect_assumption : - Logging.ocaml_pos -> Clang_ast_t.source_range -> ?ast_node:string - -> ('a, Format.formatter, unit, _) format4 -> 'a + Logging.ocaml_pos + -> Clang_ast_t.source_range + -> ?ast_node:string + -> ('a, Format.formatter, unit, _) format4 + -> 'a (** Used to mark places in the frontend that incorrectly assume something to be impossible. TODO(t21762295) get rid of all instances of this. *) diff --git a/infer/src/clang/cFrontend_decl.ml b/infer/src/clang/cFrontend_decl.ml index e0209fcaa..817f4e11a 100644 --- a/infer/src/clang/cFrontend_decl.ml +++ b/infer/src/clang/cFrontend_decl.ml @@ -12,7 +12,7 @@ module F = Format module L = Logging -let protect ~f ~recover ~pp_context (trans_unit_ctx: CFrontend_config.translation_unit_context) = +let protect ~f ~recover ~pp_context (trans_unit_ctx : CFrontend_config.translation_unit_context) = let log_and_recover ~print fmt = recover () ; incr CFrontend_config.procedures_failed ; @@ -41,10 +41,10 @@ let protect ~f ~recover ~pp_context (trans_unit_ctx: CFrontend_config.translatio module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFrontend = struct - let model_exists procname = not Config.models_mode && Summary.has_model procname + let model_exists procname = (not Config.models_mode) && Summary.has_model procname (** Translates the method/function's body into nodes of the cfg. *) - let add_method ?(is_destructor_wrapper= false) trans_unit_ctx tenv cfg class_decl_opt procname + let add_method ?(is_destructor_wrapper = false) trans_unit_ctx tenv cfg class_decl_opt procname body ms has_return_param outer_context_opt extra_instrs = L.(debug Capture Verbose) "@\n@\n>>---------- ADDING METHOD: '%a' ---------<<@\n@\n" Typ.Procname.pp procname ; @@ -60,8 +60,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron in let f () = match Typ.Procname.Hash.find cfg procname with - | procdesc when Procdesc.is_defined procdesc && not (model_exists procname) - -> ( + | procdesc when Procdesc.is_defined procdesc && not (model_exists procname) -> ( let vars_to_destroy = CTrans_utils.Scope.compute_vars_to_destroy body in let context = CContext.create_context trans_unit_ctx tenv cfg procdesc class_decl_opt @@ -126,7 +125,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron e.source_range e.ast_node - let process_method_decl ?(set_objc_accessor_attr= false) ?(is_destructor= false) trans_unit_ctx + let process_method_decl ?(set_objc_accessor_attr = false) ?(is_destructor = false) trans_unit_ctx tenv cfg curr_class meth_decl = try let ms, body_opt, extra_instrs = @@ -301,7 +300,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron false - let should_translate_decl trans_unit_ctx (dec: Clang_ast_t.decl) decl_trans_context = + let should_translate_decl trans_unit_ctx (dec : Clang_ast_t.decl) decl_trans_context = let info = Clang_ast_proj.get_decl_tuple dec in let source_range = info.Clang_ast_t.di_source_range in let translate_when_used = @@ -339,7 +338,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron | _ -> false in - not never_translate_decl && translate_location + (not never_translate_decl) && translate_location (* Translate one global declaration *) @@ -349,114 +348,112 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron Ident.NameGenerator.reset () ; let translate dec = translate_one_declaration trans_unit_ctx tenv cfg decl_trans_context dec in ( if should_translate_decl trans_unit_ctx dec decl_trans_context then - let dec_ptr = (Clang_ast_proj.get_decl_tuple dec).di_pointer in - match dec with - | FunctionDecl (_, _, _, _) -> - function_decl trans_unit_ctx tenv cfg dec None - | ObjCInterfaceDecl (_, _, decl_list, _, _) -> - let curr_class = CContext.ContextClsDeclPtr dec_ptr in - ignore - (ObjcInterface_decl.interface_declaration CType_decl.qual_type_to_sil_type - CType_decl.CProcname.from_decl tenv dec) ; - process_methods trans_unit_ctx tenv cfg curr_class decl_list - | ObjCProtocolDecl (_, _, decl_list, _, _) -> - let curr_class = CContext.ContextClsDeclPtr dec_ptr in - ignore (ObjcProtocol_decl.protocol_decl CType_decl.qual_type_to_sil_type tenv dec) ; - process_methods trans_unit_ctx tenv cfg curr_class decl_list - | ObjCCategoryDecl (_, _, decl_list, _, _) -> - let curr_class = CContext.ContextClsDeclPtr dec_ptr in - ignore - (ObjcCategory_decl.category_decl CType_decl.qual_type_to_sil_type - CType_decl.CProcname.from_decl tenv dec) ; - process_methods trans_unit_ctx tenv cfg curr_class decl_list - | ObjCCategoryImplDecl (_, _, decl_list, _, _) -> - let curr_class = CContext.ContextClsDeclPtr dec_ptr in - ignore - (ObjcCategory_decl.category_impl_decl CType_decl.qual_type_to_sil_type - CType_decl.CProcname.from_decl tenv dec) ; - process_methods trans_unit_ctx tenv cfg curr_class decl_list - | ObjCImplementationDecl (_, _, decl_list, _, _) -> - let curr_class = CContext.ContextClsDeclPtr dec_ptr in - let qual_type_to_sil_type = CType_decl.qual_type_to_sil_type in - ignore - (ObjcInterface_decl.interface_impl_declaration qual_type_to_sil_type - CType_decl.CProcname.from_decl tenv dec) ; - process_methods trans_unit_ctx tenv cfg curr_class decl_list - | CXXMethodDecl (decl_info, _, _, _, _) - | CXXConstructorDecl (decl_info, _, _, _, _) - | CXXConversionDecl (decl_info, _, _, _, _) - | CXXDestructorDecl (decl_info, _, _, _, _) - -> ( - (* di_parent_pointer has pointer to lexical context such as class.*) - let parent_ptr = Option.value_exn decl_info.Clang_ast_t.di_parent_pointer in - let class_decl = CAst_utils.get_decl parent_ptr in - match class_decl with - | (Some (CXXRecordDecl _) | Some (ClassTemplateSpecializationDecl _)) when Config.cxx -> - let curr_class = CContext.ContextClsDeclPtr parent_ptr in - process_methods trans_unit_ctx tenv cfg curr_class [dec] - | Some dec -> - L.(debug Capture Verbose) - "Methods of %s skipped@\n" - (Clang_ast_proj.get_decl_kind_string dec) - | None -> - () ) - | VarDecl (decl_info, named_decl_info, qt, ({vdi_is_global; vdi_init_expr} as vdi)) - when String.is_prefix ~prefix:"__infer_" named_decl_info.ni_name - || (vdi_is_global && Option.is_some vdi_init_expr) -> - (* create a fake procedure that initializes the global variable so that the variable + let dec_ptr = (Clang_ast_proj.get_decl_tuple dec).di_pointer in + match dec with + | FunctionDecl (_, _, _, _) -> + function_decl trans_unit_ctx tenv cfg dec None + | ObjCInterfaceDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in + ignore + (ObjcInterface_decl.interface_declaration CType_decl.qual_type_to_sil_type + CType_decl.CProcname.from_decl tenv dec) ; + process_methods trans_unit_ctx tenv cfg curr_class decl_list + | ObjCProtocolDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in + ignore (ObjcProtocol_decl.protocol_decl CType_decl.qual_type_to_sil_type tenv dec) ; + process_methods trans_unit_ctx tenv cfg curr_class decl_list + | ObjCCategoryDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in + ignore + (ObjcCategory_decl.category_decl CType_decl.qual_type_to_sil_type + CType_decl.CProcname.from_decl tenv dec) ; + process_methods trans_unit_ctx tenv cfg curr_class decl_list + | ObjCCategoryImplDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in + ignore + (ObjcCategory_decl.category_impl_decl CType_decl.qual_type_to_sil_type + CType_decl.CProcname.from_decl tenv dec) ; + process_methods trans_unit_ctx tenv cfg curr_class decl_list + | ObjCImplementationDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in + let qual_type_to_sil_type = CType_decl.qual_type_to_sil_type in + ignore + (ObjcInterface_decl.interface_impl_declaration qual_type_to_sil_type + CType_decl.CProcname.from_decl tenv dec) ; + process_methods trans_unit_ctx tenv cfg curr_class decl_list + | CXXMethodDecl (decl_info, _, _, _, _) + | CXXConstructorDecl (decl_info, _, _, _, _) + | CXXConversionDecl (decl_info, _, _, _, _) + | CXXDestructorDecl (decl_info, _, _, _, _) -> ( + (* di_parent_pointer has pointer to lexical context such as class.*) + let parent_ptr = Option.value_exn decl_info.Clang_ast_t.di_parent_pointer in + let class_decl = CAst_utils.get_decl parent_ptr in + match class_decl with + | (Some (CXXRecordDecl _) | Some (ClassTemplateSpecializationDecl _)) when Config.cxx -> + let curr_class = CContext.ContextClsDeclPtr parent_ptr in + process_methods trans_unit_ctx tenv cfg curr_class [dec] + | Some dec -> + L.(debug Capture Verbose) + "Methods of %s skipped@\n" + (Clang_ast_proj.get_decl_kind_string dec) + | None -> + () ) + | VarDecl (decl_info, named_decl_info, qt, ({vdi_is_global; vdi_init_expr} as vdi)) + when String.is_prefix ~prefix:"__infer_" named_decl_info.ni_name + || (vdi_is_global && Option.is_some vdi_init_expr) -> + (* create a fake procedure that initializes the global variable so that the variable initializer can be analyzed by the backend (eg, the SIOF checker) *) - let procname = - (* create the corresponding global variable to get the right pname for its + let procname = + (* create the corresponding global variable to get the right pname for its initializer *) - let global = - CGeneral_utils.mk_sil_global_var trans_unit_ctx decl_info named_decl_info vdi qt - in - (* safe to Option.get because it's a global *) - Option.value_exn (Pvar.get_initializer_pname global) - in - let ms = - CMethodSignature.mk procname None [] (Typ.void, Annot.Item.empty) [] - decl_info.Clang_ast_t.di_source_range ClangMethodKind.C_FUNCTION None None None - `None - in - let stmt_info = - { si_pointer= CAst_utils.get_fresh_pointer () - ; si_source_range= decl_info.di_source_range } + let global = + CGeneral_utils.mk_sil_global_var trans_unit_ctx decl_info named_decl_info vdi qt in - let body = Clang_ast_t.DeclStmt (stmt_info, [], [dec]) in - ignore (CMethod_trans.create_local_procdesc trans_unit_ctx cfg tenv ms [body] []) ; - add_method trans_unit_ctx tenv cfg CContext.ContextNoCls procname body ms None None [] - (* Note that C and C++ records are treated the same way + (* safe to Option.get because it's a global *) + Option.value_exn (Pvar.get_initializer_pname global) + in + let ms = + CMethodSignature.mk procname None [] (Typ.void, Annot.Item.empty) [] + decl_info.Clang_ast_t.di_source_range ClangMethodKind.C_FUNCTION None None None `None + in + let stmt_info = + { si_pointer= CAst_utils.get_fresh_pointer () + ; si_source_range= decl_info.di_source_range } + in + let body = Clang_ast_t.DeclStmt (stmt_info, [], [dec]) in + ignore (CMethod_trans.create_local_procdesc trans_unit_ctx cfg tenv ms [body] []) ; + add_method trans_unit_ctx tenv cfg CContext.ContextNoCls procname body ms None None [] + (* Note that C and C++ records are treated the same way Skip translating implicit struct declarations, unless they have full definition (which happens with C++ lambdas) *) - | ClassTemplateSpecializationDecl (di, _, _, decl_list, _, _, rdi, _, _, _) - | CXXRecordDecl (di, _, _, decl_list, _, _, rdi, _) - | RecordDecl (di, _, _, decl_list, _, _, rdi) - when not di.di_is_implicit || rdi.rdi_is_complete_definition -> - let is_method_decl decl = - match decl with - | CXXMethodDecl _ - | CXXConstructorDecl _ - | CXXConversionDecl _ - | CXXDestructorDecl _ - | FunctionTemplateDecl _ -> - true - | _ -> - false - in - let method_decls, no_method_decls = List.partition_tf ~f:is_method_decl decl_list in - List.iter ~f:translate no_method_decls ; - protect - ~f:(fun () -> ignore (CType_decl.add_types_from_decl_to_tenv tenv dec)) - ~recover:Fn.id - ~pp_context:(fun fmt () -> - F.fprintf fmt "Error adding types from decl '%a'" - (Pp.to_string ~f:Clang_ast_j.string_of_decl) - dec ) - trans_unit_ctx ; - List.iter ~f:translate method_decls - | _ -> - () ) ; + | ClassTemplateSpecializationDecl (di, _, _, decl_list, _, _, rdi, _, _, _) + | CXXRecordDecl (di, _, _, decl_list, _, _, rdi, _) + | RecordDecl (di, _, _, decl_list, _, _, rdi) + when (not di.di_is_implicit) || rdi.rdi_is_complete_definition -> + let is_method_decl decl = + match decl with + | CXXMethodDecl _ + | CXXConstructorDecl _ + | CXXConversionDecl _ + | CXXDestructorDecl _ + | FunctionTemplateDecl _ -> + true + | _ -> + false + in + let method_decls, no_method_decls = List.partition_tf ~f:is_method_decl decl_list in + List.iter ~f:translate no_method_decls ; + protect + ~f:(fun () -> ignore (CType_decl.add_types_from_decl_to_tenv tenv dec)) + ~recover:Fn.id + ~pp_context:(fun fmt () -> + F.fprintf fmt "Error adding types from decl '%a'" + (Pp.to_string ~f:Clang_ast_j.string_of_decl) + dec ) + trans_unit_ctx ; + List.iter ~f:translate method_decls + | _ -> + () ) ; match dec with | EnumDecl _ -> ignore (CEnum_decl.enum_decl dec) @@ -465,7 +462,8 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron List.iter ~f:translate decl_list | NamespaceDecl (_, _, decl_list, _, _) -> List.iter ~f:translate decl_list - | ClassTemplateDecl (_, _, template_decl_info) | FunctionTemplateDecl (_, _, template_decl_info) -> + | ClassTemplateDecl (_, _, template_decl_info) | FunctionTemplateDecl (_, _, template_decl_info) + -> let decl_list = template_decl_info.Clang_ast_t.tdi_specializations in List.iter ~f:translate decl_list | _ -> diff --git a/infer/src/clang/cFrontend_errors.ml b/infer/src/clang/cFrontend_errors.ml index 5180512ad..155fa3118 100644 --- a/infer/src/clang/cFrontend_errors.ml +++ b/infer/src/clang/cFrontend_errors.ml @@ -27,7 +27,7 @@ let filter_parsed_linters_developer parsed_linters = important for debugging the rule. Pass the flag --linter to specify the linter \ you want to debug." | Some lint -> - List.filter ~f:(fun (rule: linter) -> String.equal rule.issue_desc.id lint) parsed_linters + List.filter ~f:(fun (rule : linter) -> String.equal rule.issue_desc.id lint) parsed_linters else parsed_linters @@ -183,9 +183,9 @@ let string_to_issue_mode m = L.die InternalError "Mode %s does not exist. Please specify ON/OFF" s -let post_process_linter_definition (linter: linter) = +let post_process_linter_definition (linter : linter) = match - List.find Config.linters_doc_url ~f:(fun (linter_doc_url: Config.linter_doc_url) -> + List.find Config.linters_doc_url ~f:(fun (linter_doc_url : Config.linter_doc_url) -> String.equal linter.issue_desc.id linter_doc_url.linter ) with | Some linter_doc_url -> @@ -303,15 +303,14 @@ let expand_formula phi map_ error_msg_ = match acc with | True | False -> acc - | Atomic ((ALVar.Formula_id name as av), actual_param) - -> ( + | Atomic ((ALVar.Formula_id name as av), actual_param) -> ( (* it may be a macro *) let error_msg' = error_msg ^ " -Expanding formula identifier '" ^ name ^ "'@\n" in try match ALVar.FormulaIdMap.find av map with | true, _, _ -> fail_with_circular_macro_definition name error_msg' - | false, fparams, f1 -> + | false, fparams, f1 -> ( (* in this case it should be a defined macro *) match List.zip fparams actual_param with | Some sub -> @@ -321,6 +320,7 @@ let expand_formula phi map_ error_msg_ = | None -> L.(die ExternalError) "Formula identifier '%s' is not called with the right number of parameters" name + ) with Caml.Not_found -> acc (* in this case it should be a predicate *) ) | Not f1 -> @@ -434,8 +434,8 @@ let expand_checkers macro_map path_map checkers = (** Add a frontend warning with a description desc at location loc to the errlog of a proc desc *) -let log_frontend_issue method_decl_opt (node: Ctl_parser_types.ast_node) - (issue_desc: CIssue.issue_desc) linters_def_file = +let log_frontend_issue method_decl_opt (node : Ctl_parser_types.ast_node) + (issue_desc : CIssue.issue_desc) linters_def_file = let procname = match method_decl_opt with | Some method_decl -> @@ -461,7 +461,7 @@ let log_frontend_issue method_decl_opt (node: Ctl_parser_types.ast_node) ~ltr:trace ~node_key ~linters_def_file ~doc_url:issue_desc.doc_url -let fill_issue_desc_info_and_log context ~witness ~current_node (issue_desc: CIssue.issue_desc) +let fill_issue_desc_info_and_log context ~witness ~current_node (issue_desc : CIssue.issue_desc) linters_def_file loc = let process_message message = remove_new_lines_and_whitespace (expand_message_string context message current_node) @@ -478,7 +478,7 @@ let fill_issue_desc_info_and_log context ~witness ~current_node (issue_desc: CIs (* Calls the set of hard coded checkers (if any) *) -let invoke_set_of_hard_coded_checkers_an context (an: Ctl_parser_types.ast_node) = +let invoke_set_of_hard_coded_checkers_an context (an : Ctl_parser_types.ast_node) = let checkers = match an with Decl _ -> decl_checkers_list | Stmt _ -> stmt_checkers_list in List.iter ~f:(fun checker -> @@ -493,9 +493,9 @@ let invoke_set_of_hard_coded_checkers_an context (an: Ctl_parser_types.ast_node) (* Calls the set of checkers parsed from files (if any) *) -let invoke_set_of_parsed_checkers_an parsed_linters context (an: Ctl_parser_types.ast_node) = +let invoke_set_of_parsed_checkers_an parsed_linters context (an : Ctl_parser_types.ast_node) = List.iter - ~f:(fun (linter: linter) -> + ~f:(fun (linter : linter) -> if CIssue.should_run_check linter.issue_desc.CIssue.mode then match CTL.eval_formula linter.condition an context with | None -> diff --git a/infer/src/clang/cFrontend_errors.mli b/infer/src/clang/cFrontend_errors.mli index ad448d3f3..9a0a06f2e 100644 --- a/infer/src/clang/cFrontend_errors.mli +++ b/infer/src/clang/cFrontend_errors.mli @@ -49,6 +49,10 @@ val create_parsed_linters : string -> CTL.ctl_checker list -> linter list val remove_new_lines_and_whitespace : string -> string val fill_issue_desc_info_and_log : - CLintersContext.context -> witness:Ctl_parser_types.ast_node - -> current_node:Ctl_parser_types.ast_node -> CIssue.issue_desc -> string option -> Location.t + CLintersContext.context + -> witness:Ctl_parser_types.ast_node + -> current_node:Ctl_parser_types.ast_node + -> CIssue.issue_desc + -> string option + -> Location.t -> unit diff --git a/infer/src/clang/cGeneral_utils.ml b/infer/src/clang/cGeneral_utils.ml index 38263f17b..cd6d2acef 100644 --- a/infer/src/clang/cGeneral_utils.ml +++ b/infer/src/clang/cGeneral_utils.ml @@ -105,7 +105,7 @@ let get_var_name_mangled decl_info name_info var_decl_info = (name_string, mangled) -let mk_sil_global_var {CFrontend_config.source_file} ?(mk_name= fun _ x -> x) decl_info +let mk_sil_global_var {CFrontend_config.source_file} ?(mk_name = fun _ x -> x) decl_info named_decl_info var_decl_info qt = let name_string, simple_name = get_var_name_mangled decl_info named_decl_info var_decl_info in let translation_unit = @@ -130,7 +130,8 @@ let mk_sil_global_var {CFrontend_config.source_file} ?(mk_name= fun _ x -> x) de None ) |> Option.value_map ~default:true ~f:(function | Clang_ast_t.CXXRecordDecl (_, _, _, _, _, _, _, {xrdi_is_pod}) - | Clang_ast_t.ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) -> + | Clang_ast_t.ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) + -> xrdi_is_pod | _ -> true ) @@ -138,7 +139,7 @@ let mk_sil_global_var {CFrontend_config.source_file} ?(mk_name= fun _ x -> x) de let is_static_global = var_decl_info.Clang_ast_t.vdi_is_global (* only top level declarations are really have file scope, static field members have a global scope *) - && not var_decl_info.Clang_ast_t.vdi_is_static_data_member + && (not var_decl_info.Clang_ast_t.vdi_is_static_data_member) && match var_decl_info.Clang_ast_t.vdi_storage_class with Some "static" -> true | _ -> false in Pvar.mk_global ~is_constexpr ~is_pod diff --git a/infer/src/clang/cGeneral_utils.mli b/infer/src/clang/cGeneral_utils.mli index 71fdf03f0..f2060ba0d 100644 --- a/infer/src/clang/cGeneral_utils.mli +++ b/infer/src/clang/cGeneral_utils.mli @@ -26,17 +26,27 @@ val list_range : int -> int -> int list val mk_class_field_name : Typ.Name.t -> string -> Typ.Fieldname.t val get_var_name_mangled : - Clang_ast_t.decl_info -> Clang_ast_t.named_decl_info -> Clang_ast_t.var_decl_info + Clang_ast_t.decl_info + -> Clang_ast_t.named_decl_info + -> Clang_ast_t.var_decl_info -> string * Mangled.t val mk_sil_global_var : - CFrontend_config.translation_unit_context -> ?mk_name:(string -> Mangled.t -> Mangled.t) - -> Clang_ast_t.decl_info -> Clang_ast_t.named_decl_info -> Clang_ast_t.var_decl_info - -> Clang_ast_t.qual_type -> Pvar.t + CFrontend_config.translation_unit_context + -> ?mk_name:(string -> Mangled.t -> Mangled.t) + -> Clang_ast_t.decl_info + -> Clang_ast_t.named_decl_info + -> Clang_ast_t.var_decl_info + -> Clang_ast_t.qual_type + -> Pvar.t val mk_sil_var : - CFrontend_config.translation_unit_context -> Clang_ast_t.named_decl_info -> var_info option - -> Typ.Procname.t -> Typ.Procname.t -> Pvar.t + CFrontend_config.translation_unit_context + -> Clang_ast_t.named_decl_info + -> var_info option + -> Typ.Procname.t + -> Typ.Procname.t + -> Pvar.t val is_cpp_translation : CFrontend_config.translation_unit_context -> bool (** true if the current language is C++ or ObjC++ *) diff --git a/infer/src/clang/cLocation.ml b/infer/src/clang/cLocation.ml index c36f50ac1..5f4eebb55 100644 --- a/infer/src/clang/cLocation.ml +++ b/infer/src/clang/cLocation.ml @@ -44,7 +44,8 @@ let should_do_frontend_check translation_unit (loc_start, _) = translate the headers that are part of the project. However, in testing mode, we don't want to translate the headers because the dot files in the frontend tests should contain nothing else than the source file to avoid conflicts between different versions of the libraries. *) -let should_translate translation_unit (loc_start, loc_end) decl_trans_context ~translate_when_used = +let should_translate translation_unit (loc_start, loc_end) decl_trans_context ~translate_when_used + = let map_file_of pred loc = match Option.map ~f:SourceFile.from_abs_path loc.Clang_ast_t.sl_file with | Some f -> @@ -68,14 +69,17 @@ let should_translate translation_unit (loc_start, loc_end) decl_trans_context ~t let file_in_models = map_file_of SourceFile.is_cpp_model loc_end || map_file_of SourceFile.is_cpp_model loc_start in - map_file_of equal_current_source loc_end || map_file_of equal_current_source loc_start - || file_in_models || (Config.cxx && map_file_of equal_header_of_current_source loc_start) - || Config.cxx && decl_trans_context = `Translation && translate_on_demand - && not Config.testing_mode + map_file_of equal_current_source loc_end + || map_file_of equal_current_source loc_start + || file_in_models + || (Config.cxx && map_file_of equal_header_of_current_source loc_start) + || Config.cxx + && decl_trans_context = `Translation + && translate_on_demand && not Config.testing_mode let should_translate_lib translation_unit source_range decl_trans_context ~translate_when_used = - not Config.no_translate_libs + (not Config.no_translate_libs) || should_translate translation_unit source_range decl_trans_context ~translate_when_used @@ -87,8 +91,9 @@ let is_file_blacklisted file = is_file_blacklisted -let location_of_source_range ?(pick_location= `Start) default_source_file source_range = - source_range |> (match pick_location with `Start -> fst | `End -> snd) +let location_of_source_range ?(pick_location = `Start) default_source_file source_range = + source_range + |> (match pick_location with `Start -> fst | `End -> snd) |> clang_to_sil_location default_source_file diff --git a/infer/src/clang/cLocation.mli b/infer/src/clang/cLocation.mli index 2fe41d84e..468407d79 100644 --- a/infer/src/clang/cLocation.mli +++ b/infer/src/clang/cLocation.mli @@ -12,8 +12,11 @@ open! IStd val clang_to_sil_location : SourceFile.t -> Clang_ast_t.source_location -> Location.t val should_translate_lib : - SourceFile.t -> Clang_ast_t.source_range -> CModule_type.decl_trans_context - -> translate_when_used:bool -> bool + SourceFile.t + -> Clang_ast_t.source_range + -> CModule_type.decl_trans_context + -> translate_when_used:bool + -> bool val should_do_frontend_check : SourceFile.t -> Clang_ast_t.source_range -> bool diff --git a/infer/src/clang/cMethodSignature.ml b/infer/src/clang/cMethodSignature.ml index 2525a97a5..532e64399 100644 --- a/infer/src/clang/cMethodSignature.ml +++ b/infer/src/clang/cMethodSignature.ml @@ -15,8 +15,8 @@ module F = Format type param_type = {name: Mangled.t; typ: Typ.t; is_pointer_to_const: bool; is_value: bool; annot: Annot.Item.t} -let mk_param_type ?(is_value= false) ?(is_pointer_to_const= false) ?(annot= Annot.Item.empty) name - typ = +let mk_param_type ?(is_value = false) ?(is_pointer_to_const = false) ?(annot = Annot.Item.empty) + name typ = {name; typ; is_value; is_pointer_to_const; annot} @@ -50,9 +50,9 @@ let is_setter {pointer_to_property_opt; params} = Option.is_some pointer_to_property_opt && Int.equal (List.length params) 1 -let mk name class_param params ret_type ?(has_added_return_param= false) attributes loc method_kind - ?(is_cpp_virtual= false) ?(is_cpp_nothrow= false) ?(is_variadic= false) pointer_to_parent - pointer_to_property_opt return_param_typ access = +let mk name class_param params ret_type ?(has_added_return_param = false) attributes loc + method_kind ?(is_cpp_virtual = false) ?(is_cpp_nothrow = false) ?(is_variadic = false) + pointer_to_parent pointer_to_property_opt return_param_typ access = { name ; access ; class_param diff --git a/infer/src/clang/cMethodSignature.mli b/infer/src/clang/cMethodSignature.mli index d0d1d69f9..3b34f03b6 100644 --- a/infer/src/clang/cMethodSignature.mli +++ b/infer/src/clang/cMethodSignature.mli @@ -36,14 +36,29 @@ val is_getter : t -> bool val is_setter : t -> bool val mk : - Typ.Procname.t -> param_type option -> param_type list -> Typ.t * Annot.Item.t - -> ?has_added_return_param:bool -> Clang_ast_t.attribute list -> Clang_ast_t.source_range - -> ClangMethodKind.t -> ?is_cpp_virtual:bool -> ?is_cpp_nothrow:bool -> ?is_variadic:bool - -> Clang_ast_t.pointer option -> Clang_ast_t.pointer option -> Typ.t option - -> Clang_ast_t.access_specifier -> t + Typ.Procname.t + -> param_type option + -> param_type list + -> Typ.t * Annot.Item.t + -> ?has_added_return_param:bool + -> Clang_ast_t.attribute list + -> Clang_ast_t.source_range + -> ClangMethodKind.t + -> ?is_cpp_virtual:bool + -> ?is_cpp_nothrow:bool + -> ?is_variadic:bool + -> Clang_ast_t.pointer option + -> Clang_ast_t.pointer option + -> Typ.t option + -> Clang_ast_t.access_specifier + -> t val pp : Format.formatter -> t -> unit val mk_param_type : - ?is_value:bool -> ?is_pointer_to_const:bool -> ?annot:Annot.Item.t -> Mangled.t -> Typ.t + ?is_value:bool + -> ?is_pointer_to_const:bool + -> ?annot:Annot.Item.t + -> Mangled.t + -> Typ.t -> param_type diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index 9e56bda77..210fcfae4 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -18,7 +18,7 @@ module L = Logging called will be determined at compile time *) type method_call_type = MCVirtual | MCNoVirtual | MCStatic [@@deriving compare] -let equal_method_call_type = [%compare.equal : method_call_type] +let equal_method_call_type = [%compare.equal: method_call_type] let method_signature_of_pointer tenv pointer = try @@ -36,8 +36,7 @@ let get_method_name_from_clang tenv ms_opt = match ms_opt with | Some ms -> ( match CAst_utils.get_decl_opt ms.CMethodSignature.pointer_to_parent with - | Some decl - -> ( + | Some decl -> ( ignore (CType_decl.add_types_from_decl_to_tenv tenv decl) ; match ObjcCategory_decl.get_base_class_name_from_category decl with | Some class_typename -> @@ -162,15 +161,15 @@ let get_const_params_indices ~shift params = let rec aux result = function | [] -> List.rev result - | ({is_pointer_to_const}: CMethodSignature.param_type) :: tl -> + | ({is_pointer_to_const} : CMethodSignature.param_type) :: tl -> incr i ; - if is_pointer_to_const then aux (!i - 1 :: result) tl else aux result tl + if is_pointer_to_const then aux ((!i - 1) :: result) tl else aux result tl in aux [] params let get_byval_params_indices ~shift params = - List.filter_mapi params ~f:(fun index ({is_value}: CMethodSignature.param_type) -> + List.filter_mapi params ~f:(fun index ({is_value} : CMethodSignature.param_type) -> let index' = index + shift in Option.some_if is_value index' ) @@ -178,12 +177,10 @@ let get_byval_params_indices ~shift params = let get_objc_property_accessor tenv ms = let open Clang_ast_t in match CAst_utils.get_decl_opt ms.CMethodSignature.pointer_to_property_opt with - | Some (ObjCPropertyDecl (_, _, obj_c_property_decl_info)) - -> ( + | Some (ObjCPropertyDecl (_, _, obj_c_property_decl_info)) -> ( let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in match CAst_utils.get_decl_opt_with_decl_ref ivar_decl_ref with - | Some (ObjCIvarDecl (_, name_decl_info, _, _, _)) - -> ( + | Some (ObjCIvarDecl (_, name_decl_info, _, _, _)) -> ( let class_tname = Typ.Name.Objc.from_qual_name (QualifiedCppName.from_field_qualified_name @@ -191,8 +188,7 @@ let get_objc_property_accessor tenv ms = in let field_name = CGeneral_utils.mk_class_field_name class_tname name_decl_info.ni_name in match Tenv.lookup tenv class_tname with - | Some {fields} - -> ( + | Some {fields} -> ( let field_opt = List.find ~f:(fun (name, _, _) -> Typ.Fieldname.equal name field_name) fields in @@ -212,7 +208,7 @@ let get_objc_property_accessor tenv ms = (** Creates a procedure description. *) -let create_local_procdesc ?(set_objc_accessor_attr= false) trans_unit_ctx cfg tenv ms fbody +let create_local_procdesc ?(set_objc_accessor_attr = false) trans_unit_ctx cfg tenv ms fbody captured = let defined = not (List.is_empty fbody) in let proc_name = ms.CMethodSignature.name in @@ -234,13 +230,13 @@ let create_local_procdesc ?(set_objc_accessor_attr= false) trans_unit_ctx cfg te let create_new_procdesc () = let all_params = Option.to_list ms.CMethodSignature.class_param @ ms.CMethodSignature.params in let params_annots = - List.map ~f:(fun ({annot}: CMethodSignature.param_type) -> annot) all_params + List.map ~f:(fun ({annot} : CMethodSignature.param_type) -> annot) all_params in let return_annot = snd ms.CMethodSignature.ret_type in let has_added_return_param = ms.CMethodSignature.has_added_return_param in let method_annotation = (return_annot, params_annots) in let formals = - List.map ~f:(fun ({name; typ}: CMethodSignature.param_type) -> (name, typ)) all_params + List.map ~f:(fun ({name; typ} : CMethodSignature.param_type) -> (name, typ)) all_params in let captured_mangled = List.map ~f:(fun (var, t) -> (Pvar.get_name var, t)) captured in (* Captured variables for blocks are treated as parameters *) diff --git a/infer/src/clang/cMethod_trans.mli b/infer/src/clang/cMethod_trans.mli index d036fe6d0..2c7d31e65 100644 --- a/infer/src/clang/cMethod_trans.mli +++ b/infer/src/clang/cMethod_trans.mli @@ -19,12 +19,22 @@ type method_call_type = MCVirtual | MCNoVirtual | MCStatic [@@deriving compare] val equal_method_call_type : method_call_type -> method_call_type -> bool val create_local_procdesc : - ?set_objc_accessor_attr:bool -> CFrontend_config.translation_unit_context -> Cfg.t -> Tenv.t - -> CMethodSignature.t -> Clang_ast_t.stmt list -> (Pvar.t * Typ.t) list -> bool + ?set_objc_accessor_attr:bool + -> CFrontend_config.translation_unit_context + -> Cfg.t + -> Tenv.t + -> CMethodSignature.t + -> Clang_ast_t.stmt list + -> (Pvar.t * Typ.t) list + -> bool val create_external_procdesc : - CFrontend_config.translation_unit_context -> Cfg.t -> Typ.Procname.t -> ClangMethodKind.t - -> (Typ.t * Typ.t list) option -> unit + CFrontend_config.translation_unit_context + -> Cfg.t + -> Typ.Procname.t + -> ClangMethodKind.t + -> (Typ.t * Typ.t list) option + -> unit val get_objc_method_data : Clang_ast_t.obj_c_message_expr_info -> string * Clang_ast_t.pointer option * method_call_type diff --git a/infer/src/clang/cModule_type.ml b/infer/src/clang/cModule_type.ml index 7fcaf6c11..2a52c3382 100644 --- a/infer/src/clang/cModule_type.ml +++ b/infer/src/clang/cModule_type.ml @@ -18,8 +18,12 @@ module type CTranslation = sig (** Translates instructions: (statements and expressions) from the ast into sil *) val instructions_trans : - CContext.t -> Clang_ast_t.stmt -> instr_type list -> Procdesc.Node.t - -> is_destructor_wrapper:bool -> Procdesc.Node.t list + CContext.t + -> Clang_ast_t.stmt + -> instr_type list + -> Procdesc.Node.t + -> is_destructor_wrapper:bool + -> Procdesc.Node.t list (** It receives the context, a list of statements from clang ast, list of custom statments to be added before clang statements and the exit node and it returns a list of cfg nodes that represent the translation of the stmts into sil. *) @@ -27,10 +31,18 @@ end module type CFrontend = sig val function_decl : - CFrontend_config.translation_unit_context -> Tenv.t -> Cfg.t -> Clang_ast_t.decl - -> block_data option -> unit + CFrontend_config.translation_unit_context + -> Tenv.t + -> Cfg.t + -> Clang_ast_t.decl + -> block_data option + -> unit val translate_one_declaration : - CFrontend_config.translation_unit_context -> Tenv.t -> Cfg.t -> decl_trans_context - -> Clang_ast_t.decl -> unit + CFrontend_config.translation_unit_context + -> Tenv.t + -> Cfg.t + -> decl_trans_context + -> Clang_ast_t.decl + -> unit end diff --git a/infer/src/clang/cPredicates.ml b/infer/src/clang/cPredicates.ml index 2b5ca77f1..24fcb451e 100644 --- a/infer/src/clang/cPredicates.ml +++ b/infer/src/clang/cPredicates.ml @@ -161,8 +161,7 @@ let declaration_has_name an name = let rec is_subclass_of decl name = match CAst_utils.get_superclass_curr_class_objc_from_decl decl with - | Some super_ref - -> ( + | Some super_ref -> ( let ndi = match super_ref.Clang_ast_t.dr_name with Some ni -> ni | _ -> assert false in if ALVar.compare_str_with_alexp ndi.ni_name name then true else @@ -347,8 +346,7 @@ let is_objc_method_exposed context an = if is_objc_method_overriding an then true else match an with - | Ctl_parser_types.Decl (ObjCMethodDecl (_, ndi, mdi)) - -> ( + | Ctl_parser_types.Decl (ObjCMethodDecl (_, ndi, mdi)) -> ( let method_name = ndi.ni_name in let is_instance_method = mdi.omdi_is_instance_method in match current_objc_container context with @@ -389,7 +387,8 @@ let get_selector an = let receiver_objc_type_name an = match an with - | Ctl_parser_types.Stmt (ObjCMessageExpr (_, receiver :: _, _, {omei_receiver_kind= `Instance})) -> + | Ctl_parser_types.Stmt (ObjCMessageExpr (_, receiver :: _, _, {omei_receiver_kind= `Instance})) + -> Clang_ast_proj.get_expr_tuple receiver |> Option.bind ~f:(fun (_, _, expr_info) -> CAst_utils.name_opt_of_typedef_qual_type expr_info.Clang_ast_t.ei_qual_type ) @@ -427,7 +426,7 @@ let objc_message_receiver context an = None ) | `Class qt -> CAst_utils.get_decl_from_typ_ptr qt.qt_type_ptr - | `Instance -> + | `Instance -> ( match args with | receiver :: _ -> ( match receiver with @@ -442,7 +441,7 @@ let objc_message_receiver context an = | _ -> None ) | [] -> - None ) + None ) ) | _ -> None @@ -512,8 +511,7 @@ let decl_ref_name ?kind name st = match st with | Clang_ast_t.DeclRefExpr (_, _, _, drti) -> ( match drti.drti_decl_ref with - | Some dr - -> ( + | Some dr -> ( let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in let has_right_name = ALVar.compare_str_with_alexp ndi.ni_name name in match kind with @@ -551,8 +549,7 @@ let is_enum_constant_of_enum an name = match an with | Ctl_parser_types.Stmt (Clang_ast_t.DeclRefExpr (_, _, _, drti)) -> ( match drti.drti_decl_ref with - | Some dr - -> ( + | Some dr -> ( let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in let qual_name = CAst_utils.get_qualified_name ndi in match QualifiedCppName.extract_last qual_name with @@ -620,8 +617,7 @@ let context_in_synchronized_block context = context.CLintersContext.in_synchroni (* checks if ivar is defined among a set of fields and if it is atomic *) let is_ivar_atomic an = match an with - | Ctl_parser_types.Stmt (Clang_ast_t.ObjCIvarRefExpr (_, _, _, irei)) - -> ( + | Ctl_parser_types.Stmt (Clang_ast_t.ObjCIvarRefExpr (_, _, _, irei)) -> ( let dr_ref = irei.Clang_ast_t.ovrei_decl_ref in let ivar_pointer = dr_ref.Clang_ast_t.dr_decl_pointer in match CAst_utils.get_decl ivar_pointer with @@ -637,8 +633,7 @@ let is_ivar_atomic an = let is_method_property_accessor_of_ivar an context = let open Clang_ast_t in match an with - | Ctl_parser_types.Stmt (ObjCIvarRefExpr (_, _, _, irei)) - -> ( + | Ctl_parser_types.Stmt (ObjCIvarRefExpr (_, _, _, irei)) -> ( let dr_ref = irei.Clang_ast_t.ovrei_decl_ref in let ivar_pointer = dr_ref.Clang_ast_t.dr_decl_pointer in match context.CLintersContext.current_method with @@ -907,14 +902,14 @@ let has_cast_kind an alexp_kind = match an with | Ctl_parser_types.Decl _ -> false - | Ctl_parser_types.Stmt stmt -> + | Ctl_parser_types.Stmt stmt -> ( let str_kind = ALVar.alexp_to_string alexp_kind in match Clang_ast_proj.get_cast_kind stmt with | Some cast_kind -> let cast_kind_str = Clang_ast_proj.string_of_cast_kind cast_kind in String.equal cast_kind_str str_kind | None -> - false + false ) let is_node an nodename = @@ -972,11 +967,11 @@ let is_at_selector_with_name an re = false -let iphoneos_target_sdk_version_by_path (cxt: CLintersContext.context) = +let iphoneos_target_sdk_version_by_path (cxt : CLintersContext.context) = let source_file = cxt.translation_unit_context.source_file in let regex_version_opt = - List.find Config.iphoneos_target_sdk_version_path_regex ~f: - (fun (version_path_regex: Config.iphoneos_target_sdk_version_path_regex) -> + List.find Config.iphoneos_target_sdk_version_path_regex + ~f:(fun (version_path_regex : Config.iphoneos_target_sdk_version_path_regex) -> ALVar.str_match_forward (SourceFile.to_rel_path source_file) version_path_regex.path ) in match regex_version_opt with @@ -986,7 +981,7 @@ let iphoneos_target_sdk_version_by_path (cxt: CLintersContext.context) = Config.iphoneos_target_sdk_version -let iphoneos_target_sdk_version_greater_or_equal (cxt: CLintersContext.context) version = +let iphoneos_target_sdk_version_greater_or_equal (cxt : CLintersContext.context) version = match iphoneos_target_sdk_version_by_path cxt with | Some target_version -> Utils.compare_versions target_version version >= 0 @@ -994,7 +989,7 @@ let iphoneos_target_sdk_version_greater_or_equal (cxt: CLintersContext.context) false -let decl_unavailable_in_supported_ios_sdk (cxt: CLintersContext.context) an = +let decl_unavailable_in_supported_ios_sdk (cxt : CLintersContext.context) an = let config_iphoneos_target_sdk_version = iphoneos_target_sdk_version_by_path cxt in let allowed_os_versions = match @@ -1016,7 +1011,7 @@ let decl_unavailable_in_supported_ios_sdk (cxt: CLintersContext.context) an = false -let class_unavailable_in_supported_ios_sdk (cxt: CLintersContext.context) an = +let class_unavailable_in_supported_ios_sdk (cxt : CLintersContext.context) an = match receiver_method_call an with | Some decl -> decl_unavailable_in_supported_ios_sdk cxt (Ctl_parser_types.Decl decl) @@ -1094,8 +1089,7 @@ let get_ivar_lifetime an = match get_ast_node_type_ptr an with | Some pt -> ( match CAst_utils.get_type pt with - | Some c_type - -> ( + | Some c_type -> ( L.(debug Linters Medium) "@\nChecking type: `%s`\n" (Clang_ast_j.string_of_c_type c_type) ; let open Clang_ast_t in match c_type with @@ -1185,7 +1179,7 @@ let has_type_subprotocol_of an prot_name_ = false -let within_responds_to_selector_block (cxt: CLintersContext.context) an = +let within_responds_to_selector_block (cxt : CLintersContext.context) an = let open Clang_ast_t in match an with | Ctl_parser_types.Decl (ObjCMethodDecl (_, named_decl_info, _)) -> ( @@ -1199,10 +1193,9 @@ let within_responds_to_selector_block (cxt: CLintersContext.context) an = false -let within_available_class_block (cxt: CLintersContext.context) an = +let within_available_class_block (cxt : CLintersContext.context) an = match (receiver_method_call an, cxt.if_context) with - | Some receiver, Some if_context - -> ( + | Some receiver, Some if_context -> ( let in_available_class_block = if_context.within_available_class_block in match declaration_name receiver with | Some receiver_name -> diff --git a/infer/src/clang/cTL.ml b/infer/src/clang/cTL.ml index bbcc41749..2184e7426 100644 --- a/infer/src/clang/cTL.ml +++ b/infer/src/clang/cTL.ml @@ -32,7 +32,8 @@ type transitions = let is_transition_to_successor trans = match trans with - | Body | InitExpr | FieldName _ | Fields | ParameterName _ | ParameterPos _ | Parameters | Cond -> + | Body | InitExpr | FieldName _ | Fields | ParameterName _ | ParameterPos _ | Parameters | Cond + -> true | Super | PointerToDecl | Protocol | AccessorForProperty _ -> false @@ -65,7 +66,7 @@ type t = | ET of ALVar.alexp list * transitions option * t [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let has_transition phi = match phi with @@ -213,7 +214,7 @@ module Debug = struct (nodes_to_string arglist) pp_transition trans pp_formula phi - let pp_ast ~ast_node_to_highlight ?(prettifier= Fn.id) fmt root = + let pp_ast ~ast_node_to_highlight ?(prettifier = Fn.id) fmt root = let pp_node_info fmt an = let name = Ctl_parser_types.ast_node_name an in let typ = Ctl_parser_types.ast_node_type an in @@ -229,7 +230,7 @@ module Debug = struct pp_children pp_node wrapper fmt level nodes in let rec pp_ast_aux fmt root level prefix = - let get_node_name (an: ast_node) = + let get_node_name (an : ast_node) = match an with | Stmt stmt -> Clang_ast_proj.get_stmt_kind_string stmt @@ -266,7 +267,8 @@ module Debug = struct pp_stmts fmt next_level stmts | Decl decl -> let decls = - Clang_ast_proj.get_decl_context_tuple decl |> Option.map ~f:(fun (decls, _) -> decls) + Clang_ast_proj.get_decl_context_tuple decl + |> Option.map ~f:(fun (decls, _) -> decls) |> Option.value ~default:[] in pp_decls fmt next_level decls @@ -320,7 +322,7 @@ module Debug = struct let explain t ~eval_node ~ast_node_to_display = let line_number an = - let line_of_source_range (sr: Clang_ast_t.source_range) = + let line_of_source_range (sr : Clang_ast_t.source_range) = let loc_info, _ = sr in loc_info.sl_line in @@ -353,7 +355,9 @@ module Debug = struct let witness_str = match eval_node.content.witness with | Some witness -> - "\n- witness: " ^ Ctl_parser_types.ast_node_kind witness ^ " " + "\n- witness: " + ^ Ctl_parser_types.ast_node_kind witness + ^ " " ^ Ctl_parser_types.ast_node_name witness | None -> "" @@ -679,8 +683,7 @@ let transition_decl_to_decl_via_accessor_for_property d desired_kind = [] in match d with - | ObjCMethodDecl (di, method_decl_name, mdi) - -> ( + | ObjCMethodDecl (di, method_decl_name, mdi) -> ( (* infer whether this method may be a getter or setter (or neither) from its argument list *) let num_params = List.length mdi.omdi_parameters in @@ -707,12 +710,12 @@ let transition_decl_to_decl_via_accessor_for_property d desired_kind = match accessor_decl_ref_of_property_decl_info opdi with | None -> false - | Some dr -> + | Some dr -> ( match dr.dr_name with | Some ni -> String.equal method_decl_name.ni_name ni.ni_name | _ -> - false + false ) in let impl_decl_opt = CAst_utils.get_decl_opt di.di_parent_pointer in List.map ~f:(fun x -> Decl x) (find_property_for_accessor impl_decl_opt name_check) ) @@ -797,8 +800,7 @@ let parameter_of_corresp_name method_name args name = List.filter (String.split ~on:':' method_name) ~f:(fun label -> not (String.is_empty label)) in match List.zip names args with - | Some names_args - -> ( + | Some names_args -> ( let names_arg_opt = List.find names_args ~f:(fun (arg_label, _) -> ALVar.compare_str_with_alexp arg_label name) in @@ -863,7 +865,8 @@ let transition_via_parameter_pos an pos = transition_via_specified_parameter an let transition_via_fields an = let open Clang_ast_t in match an with - | Decl (RecordDecl (_, _, _, decls, _, _, _)) | Decl (CXXRecordDecl (_, _, _, decls, _, _, _, _)) -> + | Decl (RecordDecl (_, _, _, decls, _, _, _)) | Decl (CXXRecordDecl (_, _, _, decls, _, _, _, _)) + -> List.filter_map ~f:(fun d -> match d with FieldDecl _ -> Some (Decl d) | _ -> None) decls | Stmt (InitListExpr (_, stmts, _)) -> List.map ~f:(fun stmt -> Stmt stmt) stmts @@ -881,10 +884,9 @@ let field_has_name name node = let field_of_name name nodes = List.filter ~f:(field_has_name name) nodes -let field_of_corresp_name_from_init_list_expr name init_nodes (expr_info: Clang_ast_t.expr_info) = +let field_of_corresp_name_from_init_list_expr name init_nodes (expr_info : Clang_ast_t.expr_info) = match CAst_utils.get_decl_from_typ_ptr expr_info.ei_qual_type.qt_type_ptr with - | Some decl - -> ( + | Some decl -> ( let fields = transition_via_fields (Decl decl) in match List.zip init_nodes fields with | Some init_nodes_fields -> @@ -1182,8 +1184,8 @@ and eval_EF phi an lcxt trans = let witness_opt = eval_formula phi an lcxt in if Option.is_some witness_opt then witness_opt else - List.fold_left (Ctl_parser_types.get_direct_successor_nodes an) ~init:witness_opt ~f: - (fun acc node -> choose_witness_opt (eval_EF phi node lcxt trans) acc ) + List.fold_left (Ctl_parser_types.get_direct_successor_nodes an) ~init:witness_opt + ~f:(fun acc node -> choose_witness_opt (eval_EF phi node lcxt trans) acc ) (* an, lcxt |= EX phi <=> exists an' in Successors(st): an', lcxt |= phi diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index bab90673c..bdf783e08 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -84,8 +84,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s | BlockExpr _ -> true (* the block can be wrapped in ExprWithCleanups or ImplicitCastExpr*) - | ImplicitCastExpr (_, [s'], _, _) - | ExprWithCleanups (_, [s'], _, _) -> + | ImplicitCastExpr (_, [s'], _, _) | ExprWithCleanups (_, [s'], _, _) -> is_block_expr s' | _ -> false @@ -138,7 +137,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s , Typ.mk (Tint IULong) ) - let add_reference_if_glvalue (typ: Typ.t) expr_info = + let add_reference_if_glvalue (typ : Typ.t) expr_info = (* glvalue definition per C++11: http://en.cppreference.com/w/cpp/language/value_category *) let is_glvalue = @@ -224,16 +223,16 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let procname = Procdesc.get_proc_name pdesc in attr.formals (* remove this, which should always be the first formal parameter *) |> List.tl_exn - |> List.fold_left ~init:([], []) ~f: - (fun (forwarded_params, forwarded_init_exps) (formal, typ) -> + |> List.fold_left ~init:([], []) + ~f:(fun (forwarded_params, forwarded_init_exps) (formal, typ) -> let pvar = Pvar.mk formal procname in let id = Ident.create_fresh Ident.knormal in ( (Exp.Var id, typ) :: forwarded_params , Sil.Load (id, Exp.Lvar pvar, typ, sil_loc) :: forwarded_init_exps ) ) - let create_call_instr trans_state (return_type: Typ.t) function_sil params_sil sil_loc call_flags - ~is_objc_method ~is_inherited_ctor = + let create_call_instr trans_state (return_type : Typ.t) function_sil params_sil sil_loc + call_flags ~is_objc_method ~is_inherited_ctor = let ret_id_typ = (Ident.create_fresh Ident.knormal, return_type) in let ret_id', params, initd_exps, ret_exps = (* Assumption: should_add_return_param will return true only for struct types *) @@ -409,7 +408,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s assert false in List.map field_exp_typs ~f:(fun exp_typ -> (fill_typ_with_zero exp_typ).control) - |> collect_controls trans_state.context.procdesc |> mk_trans_result exp_typ + |> collect_controls trans_state.context.procdesc + |> mk_trans_result exp_typ | Tarray {elt= field_typ; length= Some n} -> let size = IntLit.to_int_exn n in let indices = CGeneral_utils.list_range 0 (size - 1) in @@ -417,7 +417,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let idx_exp = Exp.Const (Const.Cint (IntLit.of_int i)) in let field_exp = Exp.Lindex (exp, idx_exp) in (fill_typ_with_zero (field_exp, field_typ)).control ) - |> collect_controls trans_state.context.procdesc |> mk_trans_result exp_typ + |> collect_controls trans_state.context.procdesc + |> mk_trans_result exp_typ | Tint _ | Tfloat _ | Tptr _ -> let zero_exp = Exp.zero_of_type_exn typ in let instrs = [Sil.Store (exp, typ, zero_exp, sil_loc)] in @@ -557,7 +558,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* it's done in var_deref_trans. The only exception is during field initialization in*) (* constructor's initializer list (when reference itself is initialized) *) let should_add_deref = - not is_pointer_typ || (not is_constructor_init && CType.is_reference_type qual_type) + (not is_pointer_typ) || ((not is_constructor_init) && CType.is_reference_type qual_type) in let exp, deref_instrs = if should_add_deref then @@ -573,7 +574,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s type decl_ref_context = MemberOrIvar of trans_result | DeclRefExpr - let method_deref_trans ?(is_inner_destructor= false) trans_state ~context:decl_ref_context + let method_deref_trans ?(is_inner_destructor = false) trans_state ~context:decl_ref_context decl_ref stmt_info decl_kind = let open CContext in let context = trans_state.context in @@ -751,7 +752,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s {empty_control with root_nodes= [root_node']; leaf_nodes= trans_state.succ_nodes} - and var_deref_trans trans_state stmt_info (decl_ref: Clang_ast_t.decl_ref) = + and var_deref_trans trans_state stmt_info (decl_ref : Clang_ast_t.decl_ref) = let context = trans_state.context in let _, _, qual_type = CAst_utils.get_info_from_decl_ref decl_ref in let ast_typ = CType_decl.qual_type_to_sil_type context.tenv qual_type in @@ -795,7 +796,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s res_trans - and decl_ref_trans ?(is_constructor_init= false) ~context trans_state stmt_info decl_ref = + and decl_ref_trans ?(is_constructor_init = false) ~context trans_state stmt_info decl_ref = L.(debug Capture Verbose) " priority node free = '%s'@\n@." (string_of_bool (PriorityNode.is_priority_free trans_state)) ; @@ -835,13 +836,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with | Some stmt -> expression_trans context stmt - | None -> + | None -> ( match prev_enum_constant_opt with | Some prev_constant_pointer -> let previous_exp = get_enum_constant_expr context prev_constant_pointer in CArithmetic_trans.sil_const_plus_one previous_exp | None -> - zero ) + zero ) ) | _ -> zero @@ -940,7 +941,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* becomes the successor of the nodes that may be created when *) (* translating the operands. *) let res_trans_e1 = instruction trans_state' s1 in - let (exp1, typ1) as exp_typ1 = res_trans_e1.return in + let ((exp1, typ1) as exp_typ1) = res_trans_e1.return in let var_exp_typ = match binary_operator_info.Clang_ast_t.boi_kind with | `Assign -> @@ -971,8 +972,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s is_binary_assign_op binary_operator_info (* assignment operator result is lvalue in CPP, rvalue in C, *) (* hence the difference *) - && not (CGeneral_utils.is_cpp_translation context.translation_unit_context) - && (not creating_node || is_return_temp trans_state.continuation) + && (not (CGeneral_utils.is_cpp_translation context.translation_unit_context)) + && ((not creating_node) || is_return_temp trans_state.continuation) then (* We are in this case when an assignment is inside *) (* another operator that creates a node. Eg. another *) @@ -1093,7 +1094,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let node_name = Procdesc.Node.Call (Exp.to_string sil_method) in let all_res_trans = - result_trans_params @ res_trans_call :: Option.to_list extra_res_trans + result_trans_params @ (res_trans_call :: Option.to_list extra_res_trans) in PriorityNode.compute_results_to_parent trans_state_pri sil_loc ~node_name si ~return:res_trans_call.return all_res_trans @@ -1237,8 +1238,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s change the call from instance to static *) and objCMessageExpr_deal_with_static_self trans_state_param stmt_list obj_c_message_expr_info = match stmt_list with - | stmt :: rest - -> ( + | stmt :: rest -> ( let param_trans_results = List.map ~f:(exec_with_glvalue_as_reference instruction trans_state_param) rest in @@ -1311,7 +1311,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s else None in let all_res_trans = - res_trans_subexpr_list @ res_trans_call :: Option.to_list assertion_trans_opt + res_trans_subexpr_list @ (res_trans_call :: Option.to_list assertion_trans_opt) in PriorityNode.compute_results_to_parent trans_state_pri sil_loc ~node_name si ~return:res_trans_call.return all_res_trans @@ -1437,20 +1437,18 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let vars_to_destroy = CContext.StmtMap.find_exn map stmt_info.Clang_ast_t.si_pointer in List.filter_map ~f:(function - | Clang_ast_t.VarDecl (_, _, qual_type, _) as decl -> - let pvar = CVar_decl.sil_var_of_decl context decl procname in - if Pvar.is_static_local pvar then - (* don't call destructors on static vars *) - None - else - let exp = Exp.Lvar pvar in - let typ = CType_decl.qual_type_to_sil_type context.CContext.tenv qual_type in - let this_res_trans_destruct = mk_trans_result (exp, typ) empty_control in - cxx_destructor_call_trans trans_state_pri stmt_info_loc - this_res_trans_destruct qual_type.Clang_ast_t.qt_type_ptr - ~is_inner_destructor:false - | _ -> - assert false) + | Clang_ast_t.VarDecl (_, _, qual_type, _) as decl -> + let pvar = CVar_decl.sil_var_of_decl context decl procname in + if Pvar.is_static_local pvar then (* don't call destructors on static vars *) + None + else + let exp = Exp.Lvar pvar in + let typ = CType_decl.qual_type_to_sil_type context.CContext.tenv qual_type in + let this_res_trans_destruct = mk_trans_result (exp, typ) empty_control in + cxx_destructor_call_trans trans_state_pri stmt_info_loc this_res_trans_destruct + qual_type.Clang_ast_t.qt_type_ptr ~is_inner_destructor:false + | _ -> + assert false) vars_to_destroy with Caml.Not_found -> L.(debug Capture Verbose) "@\n Variables that go out of scope are not found...@\n@." ; @@ -1622,7 +1620,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s L.(debug Capture Verbose) " No short-circuit condition@\n" ; let res_trans_cond = if is_null_stmt cond then - mk_trans_result (Exp.Const (Const.Cint IntLit.one), Typ.mk (Tint Typ.IBool)) + mk_trans_result + (Exp.Const (Const.Cint IntLit.one), Typ.mk (Tint Typ.IBool)) empty_control (* Assumption: If it's a null_stmt, it is a loop with no bound, so we set condition to 1 *) else if is_cmp then @@ -1835,7 +1834,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Some {break= switch_exit_point; continue= []; return_temp= false} in let inner_trans_state = {trans_state_no_pri with continuation= continuation'} in - let switch_cases, (_: trans_result) = + let switch_cases, (_ : trans_result) = SwitchCase.in_switch_body ~f:(instruction inner_trans_state) body in let link_up_switch_cases curr_succ_nodes = function @@ -2058,7 +2057,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s and cxxForRangeStmt_trans trans_state stmt_info stmt_list = let open Clang_ast_t in match stmt_list with - | [iterator_decl; begin_stmt; end_stmt; exit_cond; increment; assign_current_index; loop_body] -> + | [iterator_decl; begin_stmt; end_stmt; exit_cond; increment; assign_current_index; loop_body] + -> let loop_body' = CompoundStmt (stmt_info, [assign_current_index; loop_body]) in let null_stmt = NullStmt (stmt_info, []) in let beginend_stmt = CompoundStmt (stmt_info, [begin_stmt; end_stmt]) in @@ -2335,13 +2335,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match trans_state.opaque_exp with | Some exp -> mk_trans_result exp empty_control - | None -> + | None -> ( match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with | Some stmt -> instruction trans_state stmt | None -> CFrontend_config.incorrect_assumption __POS__ source_range - "Expected source expression for OpaqueValueExpr" + "Expected source expression for OpaqueValueExpr" ) (* NOTE: This translation has several hypothesis. Need to be verified when we have more*) @@ -2720,7 +2720,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s | `LCK_This (* explicit with [this] or implicit with [&] *) | `LCK_VLAType (* capture a variable-length array by reference. we probably don't handle - this correctly elsewhere, but it's definitely not captured by value! *) -> + this correctly elsewhere, but it's definitely not captured by value! *) + -> true | `LCK_ByCopy (* explicit with [x] or implicit with [=] *) -> (* [=] captures this by reference and everything else by value *) @@ -2730,16 +2731,16 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in match (lci_captured_var, lci_init_captured_vardecl) with | Some captured_var_decl_ref, Some init_decl -> ( - match (* capture and init *) - get_captured_pvar_typ captured_var_decl_ref with + (* capture and init *) + match get_captured_pvar_typ captured_var_decl_ref with | Some pvar_typ -> ( translate_capture_init pvar_typ init_decl :: trans_results_acc , (Exp.Lvar (fst pvar_typ), fst pvar_typ, snd pvar_typ) :: captured_vars_acc ) | None -> (trans_results_acc, captured_vars_acc) ) | Some captured_var_decl_ref, None -> ( - match (* just capture *) - get_captured_pvar_typ captured_var_decl_ref with + (* just capture *) + match get_captured_pvar_typ captured_var_decl_ref with | Some pvar_typ -> translate_normal_capture ~is_by_ref pvar_typ acc | None -> @@ -2835,7 +2836,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s [init_expr_trans trans_state_init var_exp_typ init_stmt_info stmt_opt] in let all_res_trans = - Option.to_list control_size @ [res_trans_placement_control; res_trans_new.control] + Option.to_list control_size + @ [res_trans_placement_control; res_trans_new.control] @ List.map ~f:(fun {control} -> control) res_trans_init in PriorityNode.compute_controls_to_parent trans_state_pri sil_loc ~node_name:CXXNewExpr stmt_info @@ -3030,8 +3032,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let ret_exp = Exp.Var ret_id in let field_exp = Exp.Lfield (ret_exp, field_name, typ) in let args = - type_info_objc - :: (field_exp, void_typ) + type_info_objc :: (field_exp, void_typ) :: Option.value_map ~default:[] res_trans_subexpr ~f:(fun trans_result -> [trans_result.return] ) in @@ -3111,8 +3112,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s and breakStmt_trans trans_state stmt_info = match trans_state.continuation with - | Some bn - -> ( + | Some bn -> ( let trans_state' = {trans_state with succ_nodes= bn.break} in match inject_destructors trans_state' stmt_info with | Some ({control= {root_nodes= _ :: _}} as destr_trans_result) -> @@ -3128,8 +3128,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s and continueStmt_trans trans_state stmt_info = match trans_state.continuation with - | Some bn - -> ( + | Some bn -> ( let trans_state' = {trans_state with succ_nodes= bn.continue} in match inject_destructors trans_state' stmt_info with | Some ({control= {root_nodes= _ :: _}} as destr_trans_result) -> @@ -3216,7 +3215,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s trans_result - and instruction_aux trans_state (instr: Clang_ast_t.stmt) = + and instruction_aux trans_state (instr : Clang_ast_t.stmt) = match instr with | GotoStmt (stmt_info, _, {Clang_ast_t.gsi_label= label_name; _}) -> gotoStmt_trans trans_state stmt_info label_name @@ -3236,7 +3235,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s | CXXTemporaryObjectExpr (stmt_info, stmt_list, expr_info, cxx_constr_info) -> cxxConstructExpr_trans trans_state stmt_info stmt_list expr_info cxx_constr_info ~is_inherited_ctor:false - | CXXInheritedCtorInitExpr (stmt_info, stmt_list, expr_info, cxx_construct_inherited_expr_info) -> + | CXXInheritedCtorInitExpr (stmt_info, stmt_list, expr_info, cxx_construct_inherited_expr_info) + -> cxxConstructExpr_trans trans_state stmt_info stmt_list expr_info cxx_construct_inherited_expr_info ~is_inherited_ctor:true | ObjCMessageExpr (stmt_info, stmt_list, expr_info, obj_c_message_expr_info) -> @@ -3432,7 +3432,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s sub-expressions *) | ObjCAvailabilityCheckExpr (_, _, expr_info, _) -> undefined_expr trans_state expr_info - | SubstNonTypeTemplateParmExpr (_, stmts, _) | SubstNonTypeTemplateParmPackExpr (_, stmts, _) -> + | SubstNonTypeTemplateParmExpr (_, stmts, _) | SubstNonTypeTemplateParmPackExpr (_, stmts, _) + -> let[@warning "-8"] [expr] = stmts in instruction trans_state expr (* Infer somehow ended up in templated non instantiated code - right now diff --git a/infer/src/clang/cTrans_models.ml b/infer/src/clang/cTrans_models.ml index 14f267109..b4e0ea417 100644 --- a/infer/src/clang/cTrans_models.ml +++ b/infer/src/clang/cTrans_models.ml @@ -39,7 +39,8 @@ let is_modeled_attribute attr_name = let is_assert_log_s funct = - String.equal funct CFrontend_config.assert_rtn || String.equal funct CFrontend_config.assert_fail + 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 @@ -110,5 +111,6 @@ let get_predefined_ms_is_kind_of_class class_name method_name mk_procname = let get_predefined_model_method_signature class_name method_name mk_procname = let next_predefined f = function Some _ as x -> x | None -> f method_name mk_procname in - None |> next_predefined (get_predefined_ms_stringWithUTF8String class_name) + None + |> next_predefined (get_predefined_ms_stringWithUTF8String class_name) |> next_predefined (get_predefined_ms_is_kind_of_class class_name) diff --git a/infer/src/clang/cTrans_models.mli b/infer/src/clang/cTrans_models.mli index cf2cc2aec..a0c751633 100644 --- a/infer/src/clang/cTrans_models.mli +++ b/infer/src/clang/cTrans_models.mli @@ -26,5 +26,7 @@ val is_modeled_builtin : string -> bool val is_modeled_attribute : string -> bool val get_predefined_model_method_signature : - Typ.Name.t -> string -> (Typ.Name.t -> string -> Typ.Procname.ObjC_Cpp.kind -> Typ.Procname.t) + Typ.Name.t + -> string + -> (Typ.Name.t -> string -> Typ.Procname.ObjC_Cpp.kind -> Typ.Procname.t) -> CMethodSignature.t option diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index 7203c3ab8..bdb70fea2 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -152,7 +152,7 @@ type trans_result = let empty_control = {root_nodes= []; leaf_nodes= []; instrs= []; initd_exps= []} -let mk_trans_result ?method_name ?(is_cpp_call_virtual= false) return control = +let mk_trans_result ?method_name ?(is_cpp_call_virtual = false) return control = {control; return; method_name; is_cpp_call_virtual} @@ -177,8 +177,8 @@ let collect_controls pdesc l = let collect_trans_results pdesc ~return trans_results = - List.map trans_results ~f:(fun {control} -> control) |> collect_controls pdesc - |> mk_trans_result return + List.map trans_results ~f:(fun {control} -> control) + |> collect_controls pdesc |> mk_trans_result return module PriorityNode = struct @@ -232,7 +232,8 @@ module PriorityNode = struct let compute_results_to_parent trans_state loc ~node_name stmt_info ~return trans_results = List.map trans_results ~f:(fun trans_result -> trans_result.control) - |> compute_controls_to_parent trans_state loc ~node_name stmt_info |> mk_trans_result return + |> compute_controls_to_parent trans_state loc ~node_name stmt_info + |> mk_trans_result return let compute_control_to_parent trans_state loc ~node_name stmt_info control = @@ -445,7 +446,7 @@ let dereference_var_sil (exp, typ) sil_loc = ([sil_instr], Exp.Var id) -let dereference_value_from_result ?(strip_pointer= false) source_range sil_loc trans_result = +let dereference_value_from_result ?(strip_pointer = false) source_range sil_loc trans_result = let obj_sil, class_typ = trans_result.return in let typ_no_ptr = match class_typ.Typ.desc with @@ -498,7 +499,7 @@ let cast_operation cast_kind ((exp, typ) as exp_typ) cast_typ sil_loc = ([], (exp, cast_typ)) -let trans_assertion_failure sil_loc (context: CContext.t) = +let trans_assertion_failure sil_loc (context : CContext.t) = let assert_fail_builtin = Exp.Const (Const.Cfun BuiltinDecl.__infer_fail) in let args = [(Exp.Const (Const.Cstr Config.default_failure_name), Typ.mk Tvoid)] in let ret_id = Ident.create_fresh Ident.knormal in @@ -515,7 +516,7 @@ let trans_assertion_failure sil_loc (context: CContext.t) = mk_trans_result (Exp.Var ret_id, ret_typ) {empty_control with root_nodes= [failure_node]} -let trans_assume_false sil_loc (context: CContext.t) succ_nodes = +let trans_assume_false sil_loc (context : CContext.t) succ_nodes = let if_kind = Sil.Ik_land_lor in let instrs_cond = [Sil.Prune (Exp.zero, sil_loc, true, if_kind)] in let prune_node = @@ -523,7 +524,8 @@ let trans_assume_false sil_loc (context: CContext.t) succ_nodes = instrs_cond in Procdesc.node_set_succs_exn context.procdesc prune_node succ_nodes [] ; - mk_trans_result (Exp.zero, Typ.(mk (Tint IInt))) + mk_trans_result + (Exp.zero, Typ.(mk (Tint IInt))) {empty_control with root_nodes= [prune_node]; leaf_nodes= [prune_node]} @@ -630,12 +632,12 @@ let rec contains_opaque_value_expr s = match s with | Clang_ast_t.OpaqueValueExpr _ -> true - | _ -> + | _ -> ( match snd (Clang_ast_proj.get_stmt_tuple s) with | [] -> false | s'' :: _ -> - contains_opaque_value_expr s'' + contains_opaque_value_expr s'' ) (* checks if a unary operator is a logic negation applied to integers*) diff --git a/infer/src/clang/cTrans_utils.mli b/infer/src/clang/cTrans_utils.mli index 3d98d0ef6..f010b2cad 100644 --- a/infer/src/clang/cTrans_utils.mli +++ b/infer/src/clang/cTrans_utils.mli @@ -56,7 +56,10 @@ type trans_result = val empty_control : control val mk_trans_result : - ?method_name:BuiltinDecl.t -> ?is_cpp_call_virtual:bool -> Exp.t * Typ.typ -> control + ?method_name:BuiltinDecl.t + -> ?is_cpp_call_virtual:bool + -> Exp.t * Typ.typ + -> control -> trans_result val undefined_expression : unit -> Exp.t @@ -93,16 +96,29 @@ val trans_assertion : trans_state -> Location.t -> trans_result val contains_opaque_value_expr : Clang_ast_t.stmt -> bool val builtin_trans : - trans_state -> Clang_ast_t.source_range -> Location.t -> trans_result list -> Typ.Procname.t + trans_state + -> Clang_ast_t.source_range + -> Location.t + -> trans_result list + -> Typ.Procname.t -> trans_result option val cxx_method_builtin_trans : - trans_state -> Clang_ast_t.source_range -> Location.t -> trans_result list -> Typ.Procname.t + trans_state + -> Clang_ast_t.source_range + -> Location.t + -> trans_result list + -> Typ.Procname.t -> trans_result option val new_or_alloc_trans : - trans_state -> Location.t -> Clang_ast_t.stmt_info -> Clang_ast_t.qual_type -> Typ.Name.t option - -> string -> trans_result + trans_state + -> Location.t + -> Clang_ast_t.stmt_info + -> Clang_ast_t.qual_type + -> Typ.Name.t option + -> string + -> trans_result val cpp_new_trans : Location.t -> Typ.t -> Exp.t option -> (Exp.t * Typ.typ) list -> trans_result @@ -111,8 +127,14 @@ module Nodes : sig val is_binary_assign_op : Clang_ast_t.binary_operator_info -> bool val create_prune_node : - Procdesc.t -> branch:bool -> negate_cond:bool -> Exp.t -> Sil.instr list -> Location.t - -> Sil.if_kind -> Procdesc.Node.t + Procdesc.t + -> branch:bool + -> negate_cond:bool + -> Exp.t + -> Sil.instr list + -> Location.t + -> Sil.if_kind + -> Procdesc.Node.t val is_true_prune_node : Procdesc.Node.t -> bool end @@ -138,20 +160,33 @@ module PriorityNode : sig val own_priority_node : t -> Clang_ast_t.stmt_info -> bool val compute_controls_to_parent : - trans_state -> Location.t -> node_name:Procdesc.Node.stmt_nodekind -> Clang_ast_t.stmt_info - -> control list -> control + trans_state + -> Location.t + -> node_name:Procdesc.Node.stmt_nodekind + -> Clang_ast_t.stmt_info + -> control list + -> control (** Used by translation functions to handle potential cfg nodes. It connects nodes returned by the translation of stmt children and deals with creating or not a cfg node depending of owning the priority_node. It returns the [control] that should be passed to the parent. *) val compute_results_to_parent : - trans_state -> Location.t -> node_name:Procdesc.Node.stmt_nodekind -> Clang_ast_t.stmt_info - -> return:Exp.t * Typ.t -> trans_result list -> trans_result + trans_state + -> Location.t + -> node_name:Procdesc.Node.stmt_nodekind + -> Clang_ast_t.stmt_info + -> return:Exp.t * Typ.t + -> trans_result list + -> trans_result (** convenience wrapper around [compute_controls_to_parent] *) val compute_result_to_parent : - trans_state -> Location.t -> node_name:Procdesc.Node.stmt_nodekind -> Clang_ast_t.stmt_info - -> trans_result -> trans_result + trans_state + -> Location.t + -> node_name:Procdesc.Node.stmt_nodekind + -> Clang_ast_t.stmt_info + -> trans_result + -> trans_result (** convenience function like [compute_results_to_parent] when there is a single [trans_result] to consider *) end @@ -195,8 +230,12 @@ module Self : sig ; source_range: Clang_ast_t.source_range } val add_self_parameter_for_super_instance : - Clang_ast_t.stmt_info -> CContext.t -> Typ.Procname.t -> Location.t - -> Clang_ast_t.obj_c_message_expr_info -> trans_result option + Clang_ast_t.stmt_info + -> CContext.t + -> Typ.Procname.t + -> Location.t + -> Clang_ast_t.obj_c_message_expr_info + -> trans_result option val is_var_self : Pvar.t -> bool -> bool end diff --git a/infer/src/clang/cType_to_sil_type.ml b/infer/src/clang/cType_to_sil_type.ml index 004a59d70..f17beb048 100644 --- a/infer/src/clang/cType_to_sil_type.ml +++ b/infer/src/clang/cType_to_sil_type.ml @@ -73,7 +73,7 @@ let type_desc_of_builtin_type_kind builtin_type_kind = Typ.Tvoid -let type_of_builtin_type_kind ?(is_const= false) builtin_type_kind = +let type_of_builtin_type_kind ?(is_const = false) builtin_type_kind = let desc = type_desc_of_builtin_type_kind builtin_type_kind in let quals = Typ.mk_type_quals ~is_const () in Typ.mk ~quals desc @@ -91,7 +91,7 @@ let pointer_attribute_of_objc_attribute attr_info = Typ.Pk_objc_autoreleasing -let rec build_array_type translate_decl tenv (qual_type: Clang_ast_t.qual_type) length_opt +let rec build_array_type translate_decl tenv (qual_type : Clang_ast_t.qual_type) length_opt stride_opt = let array_type = qual_type_to_sil_type translate_decl tenv qual_type in let length = Option.map ~f:IntLit.of_int length_opt in @@ -157,7 +157,7 @@ and type_desc_of_c_type translate_decl tenv c_type : Typ.desc = | AttributedType (type_info, attr_info) -> (* TODO desugar to qualtyp *) type_desc_of_attr_type translate_decl tenv type_info attr_info - | _ -> + | _ -> ( (* TypedefType, etc *) let type_info = Clang_ast_proj.get_type_tuple c_type in match type_info.Clang_ast_t.ti_desugared_type with @@ -165,13 +165,13 @@ and type_desc_of_c_type translate_decl tenv c_type : Typ.desc = | Some typ -> type_ptr_to_type_desc translate_decl tenv typ | None -> - Typ.Tvoid + Typ.Tvoid ) and decl_ptr_to_type_desc translate_decl tenv decl_ptr : Typ.desc = let open Clang_ast_t in let typ = Clang_ast_extend.DeclPtr decl_ptr in try Clang_ast_extend.TypePointerMap.find typ !CFrontend_config.sil_types_map - with Caml.Not_found -> + with Caml.Not_found -> ( match CAst_utils.get_decl decl_ptr with | Some (CXXRecordDecl _ as d) | Some (RecordDecl _ as d) @@ -192,18 +192,18 @@ and decl_ptr_to_type_desc translate_decl tenv decl_ptr : Typ.desc = L.(debug Capture Verbose) "Warning: Decl pointer %s not found." (Clang_ast_j.string_of_pointer decl_ptr) ; - Typ.Tvoid + Typ.Tvoid ) and clang_type_ptr_to_type_desc translate_decl tenv type_ptr = try Clang_ast_extend.TypePointerMap.find type_ptr !CFrontend_config.sil_types_map - with Caml.Not_found -> + with Caml.Not_found -> ( match CAst_utils.get_type type_ptr with | Some c_type -> let type_desc = type_desc_of_c_type translate_decl tenv c_type in CAst_utils.update_sil_types_map type_ptr type_desc ; type_desc | _ -> - Typ.Tvoid + Typ.Tvoid ) and type_ptr_to_type_desc translate_decl tenv type_ptr : Typ.desc = match type_ptr with diff --git a/infer/src/clang/cVar_decl.ml b/infer/src/clang/cVar_decl.ml index 809f2188c..49a3c560e 100644 --- a/infer/src/clang/cVar_decl.ml +++ b/infer/src/clang/cVar_decl.ml @@ -38,7 +38,7 @@ let sil_var_of_decl_ref context source_range decl_ref procname = let outer_procname = CContext.get_outer_procname context in let trans_unit_ctx = context.CContext.translation_unit_context in CGeneral_utils.mk_sil_var trans_unit_ctx name None procname outer_procname - | _ -> + | _ -> ( let pointer = decl_ref.Clang_ast_t.dr_decl_pointer in if is_custom_var_pointer pointer then Pvar.mk (Mangled.from_string name.Clang_ast_t.ni_name) procname @@ -51,7 +51,7 @@ let sil_var_of_decl_ref context source_range decl_ref procname = CFrontend_config.incorrect_assumption __POS__ source_range "pointer '%d' for var decl not found. The var decl was: %a" pointer (Pp.to_string ~f:Clang_ast_j.string_of_decl_ref) - decl_ref + decl_ref ) let get_var_attribute decl_info = diff --git a/infer/src/clang/cVar_decl.mli b/infer/src/clang/cVar_decl.mli index 99837b7fa..ae1475ad1 100644 --- a/infer/src/clang/cVar_decl.mli +++ b/infer/src/clang/cVar_decl.mli @@ -19,9 +19,14 @@ val sil_var_of_decl_ref : val add_var_to_locals : Procdesc.t -> Clang_ast_t.decl -> Typ.t -> Pvar.t -> unit val sil_var_of_captured_var : - CContext.t -> Clang_ast_t.source_range -> Typ.Procname.t -> Clang_ast_t.decl_ref + CContext.t + -> Clang_ast_t.source_range + -> Typ.Procname.t + -> Clang_ast_t.decl_ref -> (Pvar.t * Typ.typ) option val captured_vars_from_block_info : - CContext.t -> Clang_ast_t.source_range -> Clang_ast_t.block_captured_variable list + CContext.t + -> Clang_ast_t.source_range + -> Clang_ast_t.block_captured_variable list -> (Pvar.t * Typ.t) list diff --git a/infer/src/clang/clang_ast_extend.ml b/infer/src/clang/clang_ast_extend.ml index 4bf5ec90b..a214bb32c 100644 --- a/infer/src/clang/clang_ast_extend.ml +++ b/infer/src/clang/clang_ast_extend.ml @@ -88,7 +88,7 @@ module TypePointerOrd = struct L.(die InternalError) "unexpected type_ptr variants: %s, %s" (type_ptr_to_string t1) (type_ptr_to_string t2) - and compare_qual_type (qt1: Clang_ast_t.qual_type) (qt2: Clang_ast_t.qual_type) = + and compare_qual_type (qt1 : Clang_ast_t.qual_type) (qt2 : Clang_ast_t.qual_type) = if phys_equal qt1 qt2 then 0 else (* enable warning here to warn and update comparison funtion when new field is added *) diff --git a/infer/src/clang/ctl_parser_types.ml b/infer/src/clang/ctl_parser_types.ml index 653cd695d..83c4c0ca5 100644 --- a/infer/src/clang/ctl_parser_types.ml +++ b/infer/src/clang/ctl_parser_types.ml @@ -63,8 +63,8 @@ let rec ast_node_name an = name | _ -> "" ) - | `PropertyRef decl_ref -> - match decl_ref.dr_name with Some name -> name.ni_name | None -> "" + | `PropertyRef decl_ref -> ( + match decl_ref.dr_name with Some name -> name.ni_name | None -> "" ) in ast_node_name (Stmt stmt) ^ "." ^ property_str | Stmt (StringLiteral (_, _, _, l)) -> @@ -110,12 +110,12 @@ let ast_node_cast_kind an = match an with | Decl _ -> "" - | Stmt stmt -> + | Stmt stmt -> ( match Clang_ast_proj.get_cast_kind stmt with | Some cast_kind -> Clang_ast_proj.string_of_cast_kind cast_kind | None -> - "" + "" ) let ast_node_equal node1 node2 = Int.equal (ast_node_pointer node1) (ast_node_pointer node2) @@ -141,7 +141,7 @@ let get_successor_decls_of_decl decl = match Clang_ast_proj.get_decl_context_tuple decl with | Some (decls, _) -> decls - | None -> + | None -> ( match decl with | FunctionDecl (_, _, _, fdi) | CXXMethodDecl (_, _, _, fdi, _) @@ -154,7 +154,7 @@ let get_successor_decls_of_decl decl = | BlockDecl (_, block_decl_info) -> block_decl_info.Clang_ast_t.bdi_parameters | _ -> - [] + [] ) let get_successor_stmts_of_decl decl = @@ -202,12 +202,12 @@ let rec is_node_successor_of ~is_successor:succ_node node = match succ_node with | Stmt _ -> let node_succ_stmts = get_successor_stmts node in - List.exists node_succ_stmts ~f:(fun (s: Clang_ast_t.stmt) -> + List.exists node_succ_stmts ~f:(fun (s : Clang_ast_t.stmt) -> ast_node_equal (Stmt s) succ_node || is_node_successor_of ~is_successor:succ_node (Stmt s) ) | Decl _ -> let node_succ_decls = get_successor_decls node in - List.exists node_succ_decls ~f:(fun (d: Clang_ast_t.decl) -> + List.exists node_succ_decls ~f:(fun (d : Clang_ast_t.decl) -> ast_node_equal (Decl d) succ_node || is_node_successor_of ~is_successor:succ_node (Decl d) ) @@ -225,12 +225,12 @@ let get_direct_successor_nodes an = let _, succs_st = Clang_ast_proj.get_stmt_tuple st in let succs = List.map ~f:(fun s -> Stmt s) succs_st in succs @ get_decl_of_stmt st - | Decl dec -> + | Decl dec -> ( match Clang_ast_proj.get_decl_context_tuple dec with | Some (decl_list, _) -> List.map ~f:(fun d -> Decl d) decl_list | None -> - [] + [] ) let infer_prefix = "__infer_ctl_" @@ -274,7 +274,7 @@ type builtin_kind = | OCLReserveID | Dependent | Overload | BoundMember | PseudoObject | UnknownAny | BuiltinFn | ARCUnbridgedCast | OMPArraySection *) -let equal_builtin_kind = [%compare.equal : builtin_kind] +let equal_builtin_kind = [%compare.equal: builtin_kind] let builtin_kind_to_string t = match t with @@ -395,7 +395,7 @@ let builtin_type_kind_assoc = ; (`Half, Half) ] -let builtin_equal (bi: Clang_ast_t.builtin_type_kind) (abi: builtin_kind) = +let builtin_equal (bi : Clang_ast_t.builtin_type_kind) (abi : builtin_kind) = match List.Assoc.find ~equal:PolyVariantEqual.( = ) builtin_type_kind_assoc bi with | Some assoc_abi when equal_builtin_kind assoc_abi abi -> true @@ -486,7 +486,8 @@ and c_type_equal c_type abs_ctype = check_type_ptr tdi.tti_child_type.qt_type_ptr abs_ctype | PointerType _, BuiltIn _ | PointerType _, Pointer _ | ObjCObjectPointerType _, Pointer _ -> pointer_type_equal c_type abs_ctype - | LValueReferenceType (_, qt), Reference abs_typ | RValueReferenceType (_, qt), Reference abs_typ -> + | LValueReferenceType (_, qt), Reference abs_typ | RValueReferenceType (_, qt), Reference abs_typ + -> check_type_ptr qt.qt_type_ptr abs_typ | ObjCObjectPointerType (_, qt), ObjCGenProt _ -> check_type_ptr qt.qt_type_ptr abs_ctype @@ -555,20 +556,19 @@ let ast_node_type an = typ_string_of_type_ptr expr_info.ei_qual_type.qt_type_ptr | _ -> "" ) - | Decl decl -> + | Decl decl -> ( match CAst_utils.type_of_decl decl with | Some type_ptr -> typ_string_of_type_ptr type_ptr | _ -> - "" + "" ) in if String.length typ_str > 0 then typ_str else "" let stmt_node_child_type an = match an with - | Stmt stmt - -> ( + | Stmt stmt -> ( let _, stmts = Clang_ast_proj.get_stmt_tuple stmt in match stmts with [stmt] -> ast_node_type (Stmt stmt) | _ -> "" ) | _ -> diff --git a/infer/src/clang/objcCategory_decl.mli b/infer/src/clang/objcCategory_decl.mli index 637ceabcd..7456fbbc5 100644 --- a/infer/src/clang/objcCategory_decl.mli +++ b/infer/src/clang/objcCategory_decl.mli @@ -12,11 +12,17 @@ open! IStd (** is saved in the tenv as a struct with the corresponding fields and methods , and the class it belongs to *) val category_decl : - CAst_utils.qual_type_to_sil_type -> CAst_utils.procname_from_decl -> Tenv.t -> Clang_ast_t.decl + CAst_utils.qual_type_to_sil_type + -> CAst_utils.procname_from_decl + -> Tenv.t + -> Clang_ast_t.decl -> Typ.desc val category_impl_decl : - CAst_utils.qual_type_to_sil_type -> CAst_utils.procname_from_decl -> Tenv.t -> Clang_ast_t.decl + CAst_utils.qual_type_to_sil_type + -> CAst_utils.procname_from_decl + -> Tenv.t + -> Clang_ast_t.decl -> Typ.desc val get_base_class_name_from_category : Clang_ast_t.decl -> Typ.Name.t option diff --git a/infer/src/clang/objcInterface_decl.ml b/infer/src/clang/objcInterface_decl.ml index d37116740..31d07002f 100644 --- a/infer/src/clang/objcInterface_decl.ml +++ b/infer/src/clang/objcInterface_decl.ml @@ -74,7 +74,8 @@ let get_interface_supers super_opt protocols = super_classes -let create_supers_fields qual_type_to_sil_type tenv class_tname decl_list otdi_super otdi_protocols = +let create_supers_fields qual_type_to_sil_type tenv class_tname decl_list otdi_super otdi_protocols + = let super = get_super_interface_decl otdi_super in let protocols = get_protocols otdi_protocols in let supers = get_interface_supers super protocols in @@ -101,7 +102,7 @@ let add_class_to_tenv qual_type_to_sil_type procname_from_decl tenv decl_info na in let fields_sc = CField_decl.fields_superclass tenv ocidi in (*In case we found categories, or partial definition of this class earlier and they are already in the tenv *) - let fields, (supers: Typ.Name.t list), methods = + let fields, (supers : Typ.Name.t list), methods = match Tenv.lookup tenv interface_name with | Some {fields; supers; methods} -> ( CGeneral_utils.append_no_duplicates_fields decl_fields fields diff --git a/infer/src/clang/objcInterface_decl.mli b/infer/src/clang/objcInterface_decl.mli index eb4e93c1c..64fe25e28 100644 --- a/infer/src/clang/objcInterface_decl.mli +++ b/infer/src/clang/objcInterface_decl.mli @@ -11,9 +11,15 @@ open! IStd struct with the corresponding fields, potential superclass and list of defined methods *) val interface_declaration : - CAst_utils.qual_type_to_sil_type -> CAst_utils.procname_from_decl -> Tenv.t -> Clang_ast_t.decl + CAst_utils.qual_type_to_sil_type + -> CAst_utils.procname_from_decl + -> Tenv.t + -> Clang_ast_t.decl -> Typ.desc val interface_impl_declaration : - CAst_utils.qual_type_to_sil_type -> CAst_utils.procname_from_decl -> Tenv.t -> Clang_ast_t.decl + CAst_utils.qual_type_to_sil_type + -> CAst_utils.procname_from_decl + -> Tenv.t + -> Clang_ast_t.decl -> Typ.desc diff --git a/infer/src/clang/objcMethod_decl.ml b/infer/src/clang/objcMethod_decl.ml index 1d99aa10b..5ab9b2097 100644 --- a/infer/src/clang/objcMethod_decl.ml +++ b/infer/src/clang/objcMethod_decl.ml @@ -8,7 +8,7 @@ open! IStd -let get_methods (from_decl: CAst_utils.procname_from_decl) tenv decl_list = +let get_methods (from_decl : CAst_utils.procname_from_decl) tenv decl_list = let get_method list_methods decl = match decl with | Clang_ast_t.ObjCMethodDecl _ -> diff --git a/infer/src/clang/tableaux.ml b/infer/src/clang/tableaux.ml index c3eb311f6..9797652eb 100644 --- a/infer/src/clang/tableaux.ml +++ b/infer/src/clang/tableaux.ml @@ -142,8 +142,7 @@ let rec normalize phi = Not (Or (EU (trans, Not phi2', Not (Or (phi1', phi2'))), EG (trans, phi2'))) | EH (cl, phi1) -> normalize (ET (cl, None, EX (Some Super, EF (Some Super, phi1)))) - | ET (tl, trs, phi1) - -> ( + | ET (tl, trs, phi1) -> ( let phi1' = normalize phi1 in match trs with | Some _ -> @@ -339,7 +338,7 @@ let build_valuation an lcxt linter_map_context = add_formula_to_valuation (node_pointer, linter.issue_desc.id) sat_set ) in List.iter - ~f:(fun (linter: linter) -> + ~f:(fun (linter : linter) -> if CIssue.should_run_check linter.issue_desc.CIssue.mode && check_linter_map linter_map_context linter.condition diff --git a/infer/src/concurrency/RacerD.ml b/infer/src/concurrency/RacerD.ml index 5db84aee7..165f6062d 100644 --- a/infer/src/concurrency/RacerD.ml +++ b/infer/src/concurrency/RacerD.ml @@ -13,9 +13,9 @@ module MF = MarkupFormatter module Payload = SummaryPayload.Make (struct type t = RacerDDomain.summary - let update_payloads post (payloads: Payloads.t) = {payloads with racerd= Some post} + let update_payloads post (payloads : Payloads.t) = {payloads with racerd= Some post} - let of_payloads (payloads: Payloads.t) = payloads.racerd + let of_payloads (payloads : Payloads.t) = payloads.racerd end) module TransferFunctions (CFG : ProcCfg.S) = struct @@ -41,15 +41,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct false - let add_unannotated_call_access pname actuals (call_flags: CallFlags.t) loc tenv ~locks ~threads - attribute_map (proc_data: extras ProcData.t) = + let add_unannotated_call_access pname actuals (call_flags : CallFlags.t) loc tenv ~locks ~threads + attribute_map (proc_data : extras ProcData.t) = let open RacerDConfig in let thread_safe_or_thread_confined annot = Annotations.ia_is_thread_safe annot || Annotations.ia_is_thread_confined annot in let is_receiver_safe = function - | HilExp.AccessExpression receiver_access_exp :: _ - -> ( + | HilExp.AccessExpression receiver_access_exp :: _ -> ( let receiver_access_path = AccessExpression.to_access_path receiver_access_exp in match AccessPath.truncate receiver_access_path with | receiver_prefix, Some receiver_field -> @@ -61,11 +60,11 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in if call_flags.cf_interface && Typ.Procname.is_java pname - && not (Models.is_java_library pname || Models.is_builder_function pname) + && (not (Models.is_java_library pname || Models.is_builder_function pname)) (* can't ask anyone to annotate interfaces in library code, and Builder's should always be thread-safe (would be unreasonable to ask everyone to annotate them) *) - && not (PatternMatch.check_class_attributes thread_safe_or_thread_confined tenv pname) - && not (Models.has_return_annot thread_safe_or_thread_confined pname) + && (not (PatternMatch.check_class_attributes thread_safe_or_thread_confined tenv pname)) + && (not (Models.has_return_annot thread_safe_or_thread_confined pname)) && not (is_receiver_safe actuals) then let open Domain in @@ -76,12 +75,12 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let add_access exp loc ~is_write_access accesses locks threads ownership - (proc_data: extras ProcData.t) = + (proc_data : extras ProcData.t) = let open Domain in let rec add_field_accesses prefix_path access_acc = function | [] -> access_acc - | access :: access_list -> + | access :: access_list -> ( let prefix_path' = (fst prefix_path, snd prefix_path @ [access]) in let add_field_access pre = let access_acc' = AccessDomain.add pre access_acc in @@ -106,7 +105,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct add_field_accesses prefix_path' access_acc access_list | OwnershipAbstractValue.Unowned -> let pre = AccessSnapshot.make access locks threads False proc_data.pdesc in - add_field_access pre + add_field_access pre ) in List.fold ~f:(fun acc access_expr -> @@ -115,7 +114,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct ~init:accesses (HilExp.get_access_exprs exp) - let is_synchronized_container callee_pname ((_, (base_typ: Typ.t)), accesses) tenv = + let is_synchronized_container callee_pname ((_, (base_typ : Typ.t)), accesses) tenv = let open RacerDConfig in if Models.is_threadsafe_collection callee_pname tenv then true else @@ -145,7 +144,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let make_container_access callee_pname ~is_write receiver_ap callee_loc tenv caller_pdesc - (astate: Domain.astate) = + (astate : Domain.astate) = (* create a dummy write that represents mutating the contents of the container *) let open Domain in let callee_accesses = @@ -156,7 +155,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in let snapshot = AccessSnapshot.make container_access astate.locks astate.threads - (AccessSnapshot.OwnershipPrecondition.Conjunction (IntSet.singleton 0)) caller_pdesc + (AccessSnapshot.OwnershipPrecondition.Conjunction (IntSet.singleton 0)) + caller_pdesc in AccessDomain.singleton snapshot in @@ -177,7 +177,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct ; wobbly_paths= StabilityDomain.empty } - let get_summary caller_pdesc callee_pname actuals callee_loc tenv (astate: Domain.astate) = + let get_summary caller_pdesc callee_pname actuals callee_loc tenv (astate : Domain.astate) = let open RacerDConfig in let get_receiver_ap actuals = match List.hd actuals with @@ -234,24 +234,23 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | None -> path in - let expand_precondition (snapshot: AccessSnapshot.t) = + let expand_precondition (snapshot : AccessSnapshot.t) = let access = TraceElem.map ~f:expand_path snapshot.access in AccessSnapshot.make_from_snapshot access snapshot in AccessDomain.map expand_precondition accesses - let add_callee_accesses (caller_astate: Domain.astate) callee_accesses locks threads actuals + let add_callee_accesses (caller_astate : Domain.astate) callee_accesses locks threads actuals callee_pname pdesc loc = let open Domain in - let conjoin_ownership_precondition actual_exp actual_indexes - : AccessSnapshot.OwnershipPrecondition.t = + let conjoin_ownership_precondition actual_exp actual_indexes : + AccessSnapshot.OwnershipPrecondition.t = match actual_exp with | HilExp.Constant _ -> (* the actual is a constant, so it's owned in the caller. *) Conjunction actual_indexes - | HilExp.AccessExpression access_expr - -> ( + | HilExp.AccessExpression access_expr -> ( let actual_access_path = AccessExpression.to_access_path access_expr in if OwnershipDomain.is_owned actual_access_path caller_astate.ownership then (* the actual passed to the current callee is owned. drop all the conditional accesses @@ -274,21 +273,21 @@ module TransferFunctions (CFG : ProcCfg.S) = struct (* couldn't find access path, don't know if it's owned. assume not *) False in - let update_ownership_precondition actual_index (acc: AccessSnapshot.OwnershipPrecondition.t) = + let update_ownership_precondition actual_index (acc : AccessSnapshot.OwnershipPrecondition.t) = match acc with | False -> (* precondition can't be satisfied *) acc - | Conjunction actual_indexes -> + | Conjunction actual_indexes -> ( match List.nth actuals actual_index with | Some actual -> conjoin_ownership_precondition actual actual_indexes | None -> L.internal_error "Bad actual index %d for callee %a with %d actuals." actual_index Typ.Procname.pp callee_pname (List.length actuals) ; - acc + acc ) in - let update_callee_access (snapshot: AccessSnapshot.t) acc = + let update_callee_access (snapshot : AccessSnapshot.t) acc = let access = TraceElem.with_callsite snapshot.access (CallSite.make callee_pname loc) in let locks = if snapshot.lock then LocksDomain.acquire_lock locks else locks in let thread = @@ -318,8 +317,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let call_without_summary callee_pname ret_access_path call_flags actuals astate = let open RacerDConfig in let open RacerDDomain in - let should_assume_returns_ownership (call_flags: CallFlags.t) actuals = - not call_flags.cf_interface && List.is_empty actuals + let should_assume_returns_ownership (call_flags : CallFlags.t) actuals = + (not call_flags.cf_interface) && List.is_empty actuals in let is_abstract_getthis_like callee = Ondemand.get_proc_desc callee @@ -363,8 +362,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct else astate - let exec_instr (astate: Domain.astate) ({ProcData.tenv; pdesc} as proc_data) _ - (instr: HilInstr.t) = + let exec_instr (astate : Domain.astate) ({ProcData.tenv; pdesc} as proc_data) _ + (instr : HilInstr.t) = let open Domain in let open RacerDConfig in match instr with @@ -436,7 +435,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct astate.attribute_map in {astate with attribute_map; threads= update_for_lock_use astate.threads} - | NoEffect -> + | NoEffect -> ( let summary_opt = get_summary pdesc callee_pname actuals loc tenv astate in let callee_pdesc = Ondemand.get_proc_desc callee_pname in match @@ -479,7 +478,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in {locks; threads; accesses; ownership; attribute_map; wobbly_paths} | None -> - call_without_summary callee_pname ret_access_path call_flags actuals astate + call_without_summary callee_pname ret_access_path call_flags actuals astate ) in let add_if_annotated predicate attribute attribute_map = if PatternMatch.override_exists predicate tenv callee_pname then @@ -510,7 +509,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct AccessExpression.to_access_paths (HilExp.get_access_exprs rhs_exp) in let is_functional = - not (List.is_empty rhs_access_paths) + (not (List.is_empty rhs_access_paths)) && List.for_all ~f:(fun access_path -> AttributeMapDomain.has_attribute access_path Functional astate.attribute_map ) @@ -575,7 +574,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct (* non-boolean expression; can't evaluate it *) None in - let add_choice bool_value (acc: Domain.astate) = function + let add_choice bool_value (acc : Domain.astate) = function | Choice.LockHeld -> let locks = if bool_value then LocksDomain.acquire_lock acc.locks @@ -594,8 +593,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in let astate' = match HilExp.get_access_exprs assume_exp with - | [access_expr] - -> ( + | [access_expr] -> ( let access_path = AccessExpression.to_access_path access_expr in let choices = AttributeMapDomain.get_choices access_path astate.attribute_map in match eval_bexp access_path assume_exp with @@ -609,12 +607,12 @@ module TransferFunctions (CFG : ProcCfg.S) = struct astate in {astate' with accesses} - | Call (_, Indirect _, _, _, _) -> + | Call (_, Indirect _, _, _, _) -> ( match Procdesc.get_proc_name pdesc with | Typ.Procname.Java _ -> L.(die InternalError) "Unexpected indirect call instruction %a" HilInstr.pp instr | _ -> - astate + astate ) let pp_session_name _node fmt = F.pp_print_string fmt "racerd" @@ -652,7 +650,7 @@ let analyze_procedure {Callbacks.proc_desc; tenv; summary} = then ThreadsDomain.AnyThread else ThreadsDomain.NoThread in - let add_owned_local acc (var_data: ProcAttributes.var_data) = + let add_owned_local acc (var_data : ProcAttributes.var_data) = let pvar = Pvar.mk var_data.name (Procdesc.get_proc_name proc_desc) in let base = AccessPath.base_of_pvar pvar var_data.typ in OwnershipDomain.add (base, []) OwnershipAbstractValue.owned acc @@ -752,19 +750,19 @@ let get_reporting_explanation_java report_kind tenv pname thread = match FbThreadSafety.get_fbthreadsafe_class_annot pname tenv with | Some (qual, annot) -> Some (FbThreadSafety.message_fbthreadsafe_class qual annot) - | None -> + | None -> ( match Models.get_current_class_and_threadsafe_superclasses tenv pname with | Some (current_class, (thread_safe_class :: _ as thread_safe_annotated_classes)) -> Some ( if List.mem ~equal:Typ.Name.equal thread_safe_annotated_classes current_class then - F.asprintf "@\n Reporting because the current class is annotated %a" - MF.pp_monospaced "@ThreadSafe" + F.asprintf "@\n Reporting because the current class is annotated %a" + MF.pp_monospaced "@ThreadSafe" else F.asprintf "@\n Reporting because a superclass %a is annotated %a" (MF.wrap_monospaced Typ.Name.pp) thread_safe_class MF.pp_monospaced "@ThreadSafe" ) | _ -> - None + None ) in match (report_kind, annotation_explanation_opt) with | UnannotatedInterface, Some threadsafe_explanation -> @@ -884,7 +882,7 @@ let make_trace ~report_kind original_path pdesc = let second_trace_spacer = Errlog.make_trace_element 0 (get_start_loc conflict_trace) label2 [] in - ( first_trace_spacer :: original_trace @ second_trace_spacer :: conflict_trace + ( (first_trace_spacer :: original_trace) @ (second_trace_spacer :: conflict_trace) , original_end , conflict_end ) in @@ -929,8 +927,8 @@ let report_thread_safety_violation tenv pdesc ~make_description ~report_kind acc let is_full_trace = TraceElem.is_direct final_sink in (* Traces can be truncated due to limitations of our Buck integration. If we have a truncated trace, it's probably going to be too confusing to be actionable. Skip it. *) - if not Config.filtering || not (Typ.Procname.is_java pname) || is_full_trace then - if not Config.racerd_use_path_stability || not (is_contaminated access wobbly_paths) then + if (not Config.filtering) || (not (Typ.Procname.is_java pname)) || is_full_trace then + if (not Config.racerd_use_path_stability) || not (is_contaminated access wobbly_paths) then let final_sink_site = PathDomain.Sink.call_site final_sink in let initial_sink_site = PathDomain.Sink.call_site initial_sink in let loc = CallSite.loc initial_sink_site in @@ -981,7 +979,7 @@ type reported_access = ; procdesc: Procdesc.t ; wobbly_paths: RacerDDomain.StabilityDomain.astate } -let make_read_write_race_description ~read_is_sync (conflict: reported_access) pname +let make_read_write_race_description ~read_is_sync (conflict : reported_access) pname final_sink_site initial_sink_site final_sink = let pp_conflict fmt {procdesc} = F.pp_print_string fmt @@ -1046,7 +1044,7 @@ let empty_reported = currently not distinguishing different locks, and are treating "known to be confined to a thread" as if "known to be confined to UI thread". *) -let report_unsafe_accesses (aggregated_access_map: reported_access list AccessListMap.t) = +let report_unsafe_accesses (aggregated_access_map : reported_access list AccessListMap.t) = let open RacerDDomain in let open RacerDConfig in let is_duplicate_report access pname @@ -1080,14 +1078,16 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi {reported with reported_unannotated_calls; reported_sites} else reported in - let report_unsafe_access {snapshot; threads; tenv; procdesc; wobbly_paths} accesses reported_acc = + let report_unsafe_access {snapshot; threads; tenv; procdesc; wobbly_paths} accesses reported_acc + = let pname = Procdesc.get_proc_name procdesc in if is_duplicate_report snapshot.access pname reported_acc then reported_acc else match TraceElem.kind snapshot.access with | Access.InterfaceCall unannoted_call_pname -> if - AccessSnapshot.is_unprotected snapshot && ThreadsDomain.is_any threads + AccessSnapshot.is_unprotected snapshot + && ThreadsDomain.is_any threads && Models.is_marked_thread_safe procdesc tenv then ( (* un-annotated interface call + no lock in method marked thread-safe. warn *) @@ -1117,7 +1117,7 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi in if AccessSnapshot.is_unprotected snapshot - && (not (List.is_empty writes_on_background_thread) || ThreadsDomain.is_any threads) + && ((not (List.is_empty writes_on_background_thread)) || ThreadsDomain.is_any threads) then ( let conflict = List.hd writes_on_background_thread in report_thread_safety_violation tenv procdesc @@ -1135,7 +1135,7 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi let is_cpp_protected_write snapshot = Typ.Procname.is_java pname || not (AccessSnapshot.is_unprotected snapshot) in - let is_conflict (snapshot: AccessSnapshot.t) other_thread = + let is_conflict (snapshot : AccessSnapshot.t) other_thread = TraceElem.is_write snapshot.access && if Typ.Procname.is_java pname then @@ -1157,7 +1157,7 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi else reported_acc | Access.Read _ | ContainerRead _ -> (* protected read. report unprotected writes and opposite protected writes as conflicts *) - let can_conflict (snapshot1: AccessSnapshot.t) (snapshot2: AccessSnapshot.t) = + let can_conflict (snapshot1 : AccessSnapshot.t) (snapshot2 : AccessSnapshot.t) = if snapshot1.lock && snapshot2.lock then false else ThreadsDomain.can_conflict snapshot1.thread snapshot2.thread in @@ -1182,7 +1182,7 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi else reported_acc in AccessListMap.fold - (fun _ (grouped_accesses: reported_access list) reported_acc -> + (fun _ (grouped_accesses : reported_access list) reported_acc -> (* reset the reported reads and writes for each memory location *) let reported = { reported_acc with @@ -1206,7 +1206,7 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi (or an override or superclass is), or - any access is in a field marked thread-safe (or an override) *) List.exists - ~f:(fun ({threads}: reported_access) -> ThreadsDomain.is_any threads) + ~f:(fun ({threads} : reported_access) -> ThreadsDomain.is_any threads) grouped_accesses && Models.should_report_on_proc pdesc tenv | ObjC_Cpp objc_cpp -> @@ -1243,7 +1243,7 @@ module SyntacticQuotientedAccessListMap : QuotientedAccessListMap = struct type var_ = Var.t - let compare_var_ (u: Var.t) (v: Var.t) = + let compare_var_ (u : Var.t) (v : Var.t) = if phys_equal u v then 0 else match (u, v) with @@ -1255,12 +1255,12 @@ module SyntacticQuotientedAccessListMap : QuotientedAccessListMap = struct Pervasives.compare u v - let compare (x: t) (y: t) = + let compare (x : t) (y : t) = match (x, y) with | (Read ap1 | Write ap1), (Read ap2 | Write ap2) | ( (ContainerRead (ap1, _) | ContainerWrite (ap1, _)) , (ContainerRead (ap2, _) | ContainerWrite (ap2, _)) ) -> - [%compare : (var_ * Typ.t) * AccessPath.access list] ap1 ap2 + [%compare: (var_ * Typ.t) * AccessPath.access list] ap1 ap2 | (InterfaceCall _ | Read _ | Write _ | ContainerRead _ | ContainerWrite _), _ -> RacerDDomain.Access.compare x y end) @@ -1295,7 +1295,8 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct match (fst p1, fst p2) with | (Var.ProgramVar pvar1, typ1), (Var.ProgramVar pvar2, typ2) when Pvar.is_this pvar1 && Pvar.is_this pvar2 - && ( Typ.equal typ1 typ2 || Prover.Subtyping_check.check_subtype tenv typ1 typ2 + && ( Typ.equal typ1 typ2 + || Prover.Subtyping_check.check_subtype tenv typ1 typ2 || Prover.Subtyping_check.check_subtype tenv typ2 typ1 ) -> (* the `this` used in C.foo and C.bar will compare unequal if we're not careful `this` is represented as a local pvar, and a local pvar contains its parent procedure name. Count diff --git a/infer/src/concurrency/RacerDConfig.ml b/infer/src/concurrency/RacerDConfig.ml index bedc6ca31..7905ed3b8 100644 --- a/infer/src/concurrency/RacerDConfig.ml +++ b/infer/src/concurrency/RacerDConfig.ml @@ -108,8 +108,7 @@ module Models = struct in fun pname actuals -> match pname with - | Typ.Procname.Java java_pname - -> ( + | Typ.Procname.Java java_pname -> ( if is_thread_utils_method "assertHoldsLock" (Typ.Procname.Java java_pname) then Lock else match @@ -190,7 +189,8 @@ module Models = struct | "setValueAt" ) ) -> Some ContainerWrite | ( ("android.util.SparseArray" | "android.support.v4.util.SparseArrayCompat") - , ("clone" | "get" | "indexOfKey" | "indexOfValue" | "keyAt" | "size" | "valueAt") ) -> + , ("clone" | "get" | "indexOfKey" | "indexOfValue" | "keyAt" | "size" | "valueAt") ) + -> Some ContainerRead | ( "android.support.v4.util.SimpleArrayMap" , ( "clear" @@ -251,8 +251,7 @@ module Models = struct (* 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[]. *) - | (Typ.Procname.ObjC_Cpp _ | C _) as pname - when is_cpp_container_write pname -> + | (Typ.Procname.ObjC_Cpp _ | C _) as pname when is_cpp_container_write pname -> Some ContainerWrite | (Typ.Procname.ObjC_Cpp _ | C _) as pname when is_cpp_container_read pname -> Some ContainerRead @@ -279,12 +278,12 @@ module Models = struct ; "std::vector" ]) in function - | Typ.Procname.ObjC_Cpp cpp_pname as pname -> - Typ.Procname.ObjC_Cpp.is_destructor cpp_pname - || QualifiedCppName.Match.match_qualifiers (Lazy.force matcher) - (Typ.Procname.get_qualifiers pname) - | _ -> - false + | Typ.Procname.ObjC_Cpp cpp_pname as pname -> + Typ.Procname.ObjC_Cpp.is_destructor cpp_pname + || QualifiedCppName.Match.match_qualifiers (Lazy.force matcher) + (Typ.Procname.get_qualifiers pname) + | _ -> + false (** return true if this function is library code from the JDK core libraries or Android *) @@ -437,7 +436,7 @@ module Models = struct (* returns true if the annotation is @ThreadSafe, @ThreadSafe(enableChecks = true), or is defined as an alias of @ThreadSafe in a .inferconfig file. *) let is_thread_safe item_annot = - let f ((annot: Annot.t), _) = + let f ((annot : Annot.t), _) = List.exists ~f:(fun annot_string -> Annotations.annot_ends_with annot annot_string @@ -469,15 +468,16 @@ module Models = struct find more bugs. this is just a temporary measure to avoid obvious false positives *) let should_analyze_proc pdesc tenv = let pn = Procdesc.get_proc_name pdesc in - not - ( match pn with - | Typ.Procname.Java java_pname -> - Typ.Procname.Java.is_class_initializer java_pname - || Typ.Name.Java.is_external (Typ.Procname.Java.get_class_type_name java_pname) - (* third party code may be hard to change, not useful to report races there *) - | _ -> - false ) - && not (FbThreadSafety.is_logging_method pn) && not (pdesc_is_assumed_thread_safe pdesc tenv) + (not + ( match pn with + | Typ.Procname.Java java_pname -> + Typ.Procname.Java.is_class_initializer java_pname + || Typ.Name.Java.is_external (Typ.Procname.Java.get_class_type_name java_pname) + (* third party code may be hard to change, not useful to report races there *) + | _ -> + false )) + && (not (FbThreadSafety.is_logging_method pn)) + && (not (pdesc_is_assumed_thread_safe pdesc tenv)) && not (should_skip pn) @@ -509,7 +509,8 @@ module Models = struct let is_annot annot = Annotations.ia_is_ui_thread annot || Annotations.ia_is_on_bind annot || Annotations.ia_is_on_event annot || Annotations.ia_is_on_mount annot - || Annotations.ia_is_on_unbind annot || Annotations.ia_is_on_unmount annot + || Annotations.ia_is_on_unbind annot + || Annotations.ia_is_on_unmount annot in let pname = Procdesc.get_proc_name proc_desc in if @@ -535,7 +536,7 @@ module Models = struct (MF.wrap_monospaced Typ.Procname.pp) override_pname (MF.monospaced_to_string Annotations.ui_thread)) - | None -> + | None -> ( match get_current_class_and_annotated_superclasses Annotations.ia_is_ui_thread tenv pname with @@ -558,7 +559,7 @@ module Models = struct middle (MF.monospaced_to_string Annotations.ui_thread)) | _ -> - None + None ) let get_current_class_and_threadsafe_superclasses tenv pname = @@ -566,9 +567,9 @@ module Models = struct let is_thread_safe_class pname tenv = - not - ((* current class not marked thread-safe *) - PatternMatch.check_current_class_attributes Annotations.ia_is_not_thread_safe tenv pname) + (not + ((* current class not marked thread-safe *) + PatternMatch.check_current_class_attributes Annotations.ia_is_not_thread_safe tenv pname)) && (* current class or superclass is marked thread-safe *) match get_current_class_and_threadsafe_superclasses tenv pname with @@ -592,18 +593,18 @@ module Models = struct let should_report_on_proc proc_desc tenv = let proc_name = Procdesc.get_proc_name proc_desc in is_thread_safe_method proc_name tenv - || not - ( match proc_name with - | Typ.Procname.Java java_pname -> - Typ.Procname.Java.is_autogen_method java_pname - | _ -> - false ) + || (not + ( match proc_name with + | Typ.Procname.Java java_pname -> + Typ.Procname.Java.is_autogen_method java_pname + | _ -> + false )) && Procdesc.get_access proc_desc <> PredSymb.Private && not (Annotations.pdesc_return_annot_ends_with proc_desc Annotations.visibleForTesting) - let is_call_of_class ?(search_superclasses= true) ?(method_prefix= false) - ?(actuals_pred= fun _ -> true) class_names method_name = + let is_call_of_class ?(search_superclasses = true) ?(method_prefix = false) + ?(actuals_pred = fun _ -> true) class_names method_name = let is_target_class = let target_set = List.map class_names ~f:Typ.Name.Java.from_string |> Typ.Name.Set.of_list in fun tname -> Typ.Name.Set.mem tname target_set @@ -675,8 +676,8 @@ module Models = struct | [_; snd_arg] -> (* this is an Object.wait(_) call, second argument should be a duration in milliseconds *) duration_of_exp snd_arg - |> Option.value_map ~default:false ~f:(fun duration -> - is_excessive_secs (0.001 *. duration) ) + |> Option.value_map ~default:false ~f:(fun duration -> is_excessive_secs (0.001 *. duration) + ) | [_; snd_arg; third_arg] -> (* this is either a call to Object.wait(_, _) or to a java.util.concurent.lock(_, _) method. In the first case the arguments are a duration in milliseconds and an extra duration in @@ -703,7 +704,8 @@ module Models = struct (** is the method called CountDownLath.await or on subclass? *) let is_countdownlatch_await = is_call_of_class ~actuals_pred:empty_or_excessive_timeout - ["java.util.concurrent.CountDownLatch"] "await" + ["java.util.concurrent.CountDownLatch"] + "await" |> Staged.unstage @@ -757,7 +759,7 @@ module Models = struct let is_synchronized_library_call = let targets = ["java.lang.StringBuffer"; "java.util.Hashtable"; "java.util.Vector"] in fun tenv pn -> - not (Typ.Procname.is_constructor pn) + (not (Typ.Procname.is_constructor pn)) && match pn with | Typ.Procname.Java java_pname -> diff --git a/infer/src/concurrency/RacerDDomain.ml b/infer/src/concurrency/RacerDDomain.ml index ae5711feb..3b3e32b89 100644 --- a/infer/src/concurrency/RacerDDomain.ml +++ b/infer/src/concurrency/RacerDDomain.ml @@ -15,7 +15,7 @@ module F = Format This is here and not in RacerDConfig to avoid dependency cycles. *) let should_skip_var v = - not (Var.appears_in_source_code v) + (not (Var.appears_in_source_code v)) || match v with Var.ProgramVar pvar -> Pvar.is_static_local pvar | _ -> false @@ -28,7 +28,7 @@ module Access = struct | InterfaceCall of Typ.Procname.t [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let suffix_matches (_, accesses1) (_, accesses2) = match (List.rev accesses1, List.rev accesses2) with @@ -306,7 +306,8 @@ module AccessSnapshot = struct let is_unprotected {thread; lock; ownership_precondition} = - not (ThreadsDomain.is_any_but_self thread) && not lock + (not (ThreadsDomain.is_any_but_self thread)) + && (not lock) && not (OwnershipPrecondition.is_true ownership_precondition) @@ -432,7 +433,8 @@ module OwnershipDomain = struct let propagate_return ret_access_path return_ownership actuals ownership = let get_ownership formal_index acc = - List.nth actuals formal_index |> Option.map ~f:(fun expr -> ownership_of_expr expr ownership) + List.nth actuals formal_index + |> Option.map ~f:(fun expr -> ownership_of_expr expr ownership) (* simply skip formal if we cannot find its actual, as opposed to assuming non-ownership *) |> Option.fold ~init:acc ~f:OwnershipAbstractValue.join in @@ -550,7 +552,8 @@ module StabilityDomain = struct let add_path path_to_add t = if - not Config.racerd_use_path_stability || should_skip_var (fst path_to_add |> fst) + (not Config.racerd_use_path_stability) + || should_skip_var (fst path_to_add |> fst) || exists_prefix path_to_add t then t else filter (fun path -> is_prefix path_to_add path |> not) t |> add path_to_add @@ -579,7 +582,8 @@ module StabilityDomain = struct let rebase actuals pdesc t = let formal_map = FormalMap.make pdesc in let expand_path ((base, accesses) as p) = - FormalMap.get_formal_index base formal_map |> Option.bind ~f:(List.nth actuals) + FormalMap.get_formal_index base formal_map + |> Option.bind ~f:(List.nth actuals) |> Option.bind ~f:actual_to_access_path |> Option.value_map ~default:p ~f:(fun ap -> AccessPath.append ap accesses) in @@ -629,7 +633,8 @@ let empty = let is_empty {threads; locks; accesses; ownership; attribute_map; wobbly_paths} = ThreadsDomain.is_empty threads && LocksDomain.is_empty locks && AccessDomain.is_empty accesses - && OwnershipDomain.is_empty ownership && AttributeMapDomain.is_empty attribute_map + && OwnershipDomain.is_empty ownership + && AttributeMapDomain.is_empty attribute_map && StabilityDomain.is_empty wobbly_paths diff --git a/infer/src/concurrency/RacerDDomain.mli b/infer/src/concurrency/RacerDDomain.mli index 040d96332..77099c3f4 100644 --- a/infer/src/concurrency/RacerDDomain.mli +++ b/infer/src/concurrency/RacerDDomain.mli @@ -117,8 +117,12 @@ module AccessSnapshot : sig include PrettyPrintable.PrintableOrderedType with type t := t val make : - PathDomain.Sink.t -> LocksDomain.astate -> ThreadsDomain.astate -> OwnershipPrecondition.t - -> Procdesc.t -> t + PathDomain.Sink.t + -> LocksDomain.astate + -> ThreadsDomain.astate + -> OwnershipPrecondition.t + -> Procdesc.t + -> t val make_from_snapshot : PathDomain.Sink.t -> t -> t @@ -155,7 +159,7 @@ module OwnershipDomain : sig val is_owned : AccessPath.t -> astate -> bool - val find : [`Use_get_owned_instead] [@@warning "-32"] + val find : [`Use_get_owned_instead] [@@warning "-32"] val propagate_assignment : AccessPath.t -> HilExp.t -> astate -> astate diff --git a/infer/src/concurrency/starvation.ml b/infer/src/concurrency/starvation.ml index 449f31df5..e4a6b0b70 100644 --- a/infer/src/concurrency/starvation.ml +++ b/infer/src/concurrency/starvation.ml @@ -31,9 +31,9 @@ let is_nonblocking tenv proc_desc = module Payload = SummaryPayload.Make (struct type t = StarvationDomain.summary - let update_payloads post (payloads: Payloads.t) = {payloads with starvation= Some post} + let update_payloads post (payloads : Payloads.t) = {payloads with starvation= Some post} - let of_payloads (payloads: Payloads.t) = payloads.starvation + let of_payloads (payloads : Payloads.t) = payloads.starvation end) (* using an indentifier for a class object, create an access path representing that lock; @@ -62,7 +62,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct type extras = FormalMap.t - let exec_instr (astate: Domain.astate) {ProcData.pdesc; tenv; extras} _ (instr: HilInstr.t) = + let exec_instr (astate : Domain.astate) {ProcData.pdesc; tenv; extras} _ (instr : HilInstr.t) = let open RacerDConfig in let is_formal base = FormalMap.is_formal base extras in let get_path actuals = @@ -104,7 +104,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | NoEffect when is_on_ui_thread callee -> let explanation = F.asprintf "it calls %a" (MF.wrap_monospaced Typ.Procname.pp) callee in Domain.set_on_ui_thread astate explanation - | NoEffect -> + | NoEffect -> ( let caller = Procdesc.get_proc_name pdesc in match Models.may_block tenv callee actuals with | Some sev -> @@ -119,7 +119,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct if is_call_to_superclass tenv ~caller ~callee then summary else {summary with Domain.order= Domain.OrderDomain.empty} in - Domain.integrate_summary astate callee loc summary ) ) + Domain.integrate_summary astate callee loc summary ) ) ) | _ -> astate @@ -150,8 +150,8 @@ let analyze_procedure {Callbacks.proc_desc; tenv; summary} = match pname with | Typ.Procname.Java java_pname when Typ.Procname.Java.is_static java_pname -> (* this is crafted so as to match synchronized(CLASSNAME.class) constructs *) - Typ.Procname.Java.get_class_type_name java_pname |> Typ.Name.name - |> Ident.string_to_name |> lock_of_class |> Option.some + Typ.Procname.Java.get_class_type_name java_pname + |> Typ.Name.name |> Ident.string_to_name |> lock_of_class |> Option.some | _ -> FormalMap.get_formal_base 0 formals |> Option.map ~f:(fun base -> (base, [])) in @@ -172,7 +172,8 @@ let analyze_procedure {Callbacks.proc_desc; tenv; summary} = order } else Fn.id in - Analyzer.compute_post proc_data ~initial |> Option.map ~f:filter_blocks + Analyzer.compute_post proc_data ~initial + |> Option.map ~f:filter_blocks |> Option.value_map ~default:summary ~f:(fun astate -> Payload.update_summary astate summary) @@ -185,8 +186,14 @@ module ReportMap : sig val add_deadlock : Tenv.t -> Procdesc.t -> Location.t -> Errlog.loc_trace -> string -> t -> t val add_starvation : - Tenv.t -> StarvationDomain.Event.severity_t -> Procdesc.t -> Location.t -> Errlog.loc_trace - -> string -> t -> t + Tenv.t + -> StarvationDomain.Event.severity_t + -> Procdesc.t + -> Location.t + -> Errlog.loc_trace + -> string + -> t + -> t val log : t -> unit end = struct @@ -203,7 +210,7 @@ end = struct let empty : t = LocMap.empty - let add_deadlock tenv pdesc loc ltr message (map: t) = + let add_deadlock tenv pdesc loc ltr message (map : t) = let pname = Procdesc.get_proc_name pdesc in if Reporting.is_suppressed tenv pdesc IssueType.deadlock ~field_name:None then map else @@ -282,7 +289,7 @@ let should_report pdesc = match Procdesc.get_proc_name pdesc with | Typ.Procname.Java java_pname -> Procdesc.get_access pdesc <> PredSymb.Private - && not (Typ.Procname.Java.is_autogen_method java_pname) + && (not (Typ.Procname.Java.is_autogen_method java_pname)) && not (Typ.Procname.Java.is_class_initializer java_pname) | _ -> L.(die InternalError "Not supposed to run on non-Java code.") @@ -297,7 +304,8 @@ let fold_reportable_summaries (tenv, current_pdesc) clazz ~init ~f = Ondemand.get_proc_desc mthd |> Option.value_map ~default:acc ~f:(fun other_pdesc -> if should_report other_pdesc then - Payload.read current_pdesc mthd |> Option.map ~f:(fun payload -> (mthd, payload)) + Payload.read current_pdesc mthd + |> Option.map ~f:(fun payload -> (mthd, payload)) |> Option.fold ~init:acc ~f else acc ) in @@ -370,8 +378,8 @@ let report_deadlocks env {StarvationDomain.order; ui} report_map' = (* get the class of the root variable of the lock in the endpoint elem and retrieve all the summaries of the methods of that class *) (* for each summary related to the endpoint, analyse and report on its pairs *) - fold_reportable_summaries env endpoint_class ~init:report_map ~f: - (fun acc (endp_pname, endpoint_summary) -> + fold_reportable_summaries env endpoint_class ~init:report_map + ~f:(fun acc (endp_pname, endpoint_summary) -> let endp_order = endpoint_summary.order in let endp_ui = endpoint_summary.ui in if UIThreadDomain.is_empty ui || UIThreadDomain.is_empty endp_ui then @@ -421,8 +429,8 @@ let report_starvation env {StarvationDomain.events; ui} report_map' = (* get the class of the root variable of the lock in the endpoint elem and retrieve all the summaries of the methods of that class *) (* for each summary related to the endpoint, analyse and report on its pairs *) - fold_reportable_summaries env endpoint_class ~init:report_map ~f: - (fun acc (endpoint_pname, {order; ui}) -> + fold_reportable_summaries env endpoint_class ~init:report_map + ~f:(fun acc (endpoint_pname, {order; ui}) -> (* skip methods known to run on ui thread, as they cannot run in parallel to us *) if UIThreadDomain.is_empty ui then OrderDomain.fold @@ -443,8 +451,8 @@ let reporting {Callbacks.procedures; source_file} = if should_report proc_desc then Payload.read proc_desc (Procdesc.get_proc_name proc_desc) |> Option.iter ~f:(fun summary -> - report_deadlocks env summary ReportMap.empty |> report_starvation env summary - |> ReportMap.log ) + report_deadlocks env summary ReportMap.empty + |> report_starvation env summary |> ReportMap.log ) in List.iter procedures ~f:report_procedure ; IssueLog.store Config.starvation_issues_dir_name source_file diff --git a/infer/src/concurrency/starvationDomain.ml b/infer/src/concurrency/starvationDomain.ml index d4e925b79..65543ab79 100644 --- a/infer/src/concurrency/starvationDomain.ml +++ b/infer/src/concurrency/starvationDomain.ml @@ -66,8 +66,7 @@ module type TraceElem = sig end module MakeTraceElem (Elem : PrettyPrintable.PrintableOrderedType) : - TraceElem with type elem_t = Elem.t = -struct + TraceElem with type elem_t = Elem.t = struct type elem_t = Elem.t type t = {elem: Elem.t; loc: Location.t; trace: CallSite.t list [@compare.ignore]} @@ -79,7 +78,7 @@ struct let get_loc {loc; trace} = List.hd trace |> Option.value_map ~default:loc ~f:CallSite.loc - let make_loc_trace ?(nesting= 0) e = + let make_loc_trace ?(nesting = 0) e = let call_trace, nesting = List.fold e.trace ~init:([], nesting) ~f:(fun (tr, ns) callsite -> let elem_descr = @@ -126,7 +125,7 @@ module Event = struct make (MayBlock (descr, sev)) loc - let make_trace ?(header= "") pname elem = + let make_trace ?(header = "") pname elem = let trace = make_loc_trace elem in let trace_descr = Format.asprintf "%s%a" header (MF.wrap_monospaced Typ.Procname.pp) pname in let start_loc = get_loc elem in @@ -162,14 +161,14 @@ module Order = struct false - let make_loc_trace ?(nesting= 0) ({elem= {eventually}} as order) = + let make_loc_trace ?(nesting = 0) ({elem= {eventually}} as order) = let first_trace = make_loc_trace ~nesting order in let first_nesting = List.length first_trace in let eventually_trace = Event.make_loc_trace ~nesting:first_nesting eventually in first_trace @ eventually_trace - let make_trace ?(header= "") pname elem = + let make_trace ?(header = "") pname elem = let trace = make_loc_trace elem in let trace_descr = Format.asprintf "%s%a" header (MF.wrap_monospaced Typ.Procname.pp) pname in let start_loc = get_loc elem in diff --git a/infer/src/concurrency/starvationDomain.mli b/infer/src/concurrency/starvationDomain.mli index 92abccd7c..01ec2d95d 100644 --- a/infer/src/concurrency/starvationDomain.mli +++ b/infer/src/concurrency/starvationDomain.mli @@ -94,7 +94,11 @@ val acquire : astate -> Location.t -> Lock.t -> astate val release : astate -> Lock.t -> astate val blocking_call : - caller:Typ.Procname.t -> callee:Typ.Procname.t -> Event.severity_t -> Location.t -> astate + caller:Typ.Procname.t + -> callee:Typ.Procname.t + -> Event.severity_t + -> Location.t + -> astate -> astate val set_on_ui_thread : astate -> string -> astate diff --git a/infer/src/deadcode/dune.in b/infer/src/deadcode/dune.in index c227a1b71..42d4cb148 100644 --- a/infer/src/deadcode/dune.in +++ b/infer/src/deadcode/dune.in @@ -1,8 +1,9 @@ (* -*- tuareg -*- *) (* NOTE: prepend dune.common to this file! *) -;; Format.sprintf - {| +;; +Format.sprintf + {| (executable (name all_infer_in_one_file) (flags (%s -w +60)) @@ -12,7 +13,7 @@ (preprocess (pps ppx_compare ppx_sexp_conv -no-check)) ) |} - (String.concat " " common_cflags) - (String.concat " " common_optflags) - (String.concat " " common_libraries) - |> Jbuild_plugin.V1.send + (String.concat " " common_cflags) + (String.concat " " common_optflags) + (String.concat " " common_libraries) +|> Jbuild_plugin.V1.send diff --git a/infer/src/dune.in b/infer/src/dune.in index 5689a5738..cdc539cc7 100644 --- a/infer/src/dune.in +++ b/infer/src/dune.in @@ -105,4 +105,5 @@ let stanzas = |> List.concat ) -;; String.concat "\n" stanzas |> Jbuild_plugin.V1.send +;; +String.concat "\n" stanzas |> Jbuild_plugin.V1.send diff --git a/infer/src/eradicate/Checkers.ml b/infer/src/eradicate/Checkers.ml index 02bc76502..bc094299a 100644 --- a/infer/src/eradicate/Checkers.ml +++ b/infer/src/eradicate/Checkers.ml @@ -10,8 +10,8 @@ open! IStd (** Module for user-defined checkers. *) module ST = struct - let report_error tenv proc_name proc_desc kind loc ?(field_name= None) ?(origin_loc= None) - ?(exception_kind= fun k d -> Exceptions.Checkers (k, d)) ?(severity= Exceptions.Warning) + let report_error tenv proc_name proc_desc kind loc ?(field_name = None) ?(origin_loc = None) + ?(exception_kind = fun k d -> Exceptions.Checkers (k, d)) ?(severity = Exceptions.Warning) description = let suppressed = Reporting.is_suppressed tenv proc_desc kind ~field_name in if not suppressed then diff --git a/infer/src/eradicate/Checkers.mli b/infer/src/eradicate/Checkers.mli index c9461cfa7..56e8dcccb 100644 --- a/infer/src/eradicate/Checkers.mli +++ b/infer/src/eradicate/Checkers.mli @@ -11,9 +11,16 @@ open! IStd module ST : sig val report_error : - Tenv.t -> Typ.Procname.t -> Procdesc.t -> IssueType.t -> Location.t - -> ?field_name:Typ.Fieldname.t option -> ?origin_loc:Location.t option - -> ?exception_kind:(IssueType.t -> Localise.error_desc -> exn) -> ?severity:Exceptions.severity - -> string -> unit + Tenv.t + -> Typ.Procname.t + -> Procdesc.t + -> IssueType.t + -> Location.t + -> ?field_name:Typ.Fieldname.t option + -> ?origin_loc:Location.t option + -> ?exception_kind:(IssueType.t -> Localise.error_desc -> exn) + -> ?severity:Exceptions.severity + -> string + -> unit (** Report an error. *) end diff --git a/infer/src/eradicate/eradicate.ml b/infer/src/eradicate/eradicate.ml index 6b39f594a..3426cb168 100644 --- a/infer/src/eradicate/eradicate.ml +++ b/infer/src/eradicate/eradicate.ml @@ -46,8 +46,8 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct List.fold ~f:add_formal ~init:typestate_empty annotated_signature.AnnotatedSignature.params in (* Check the nullable flag computed for the return value and report inconsistencies. *) - let check_return find_canonical_duplicate exit_node final_typestate annotated_signature loc - : unit = + let check_return find_canonical_duplicate exit_node final_typestate annotated_signature loc : + unit = let _, ret_type = annotated_signature.AnnotatedSignature.ret in let ret_pvar = Procdesc.get_ret_var curr_pdesc in let ret_range = TypeState.lookup_pvar ret_pvar final_typestate in @@ -145,11 +145,11 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let module Initializers = struct type init = Typ.Procname.t * Procdesc.t - let equal_class_opt = [%compare.equal : string option] + 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 = + let get_private_called (initializers : init list) : init list = let res = ref [] in let do_proc (init_pn, init_pd) = let filter callee_pn callee_attributes = @@ -188,7 +188,7 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let initializers_base_case = initializers_current_class in let res = ref [] in let seen = ref Typ.Procname.Set.empty in - let mark_seen (initializers: init list) : unit = + let mark_seen (initializers : init list) : unit = List.iter ~f:(fun (pn, _) -> seen := Typ.Procname.Set.add pn !seen) initializers ; res := !res @ initializers in @@ -278,7 +278,7 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let do_typestate typestate = let start_node = Procdesc.get_start_node curr_pdesc in if - not calls_this + (not calls_this) (* if 'this(...)' is called, no need to check initialization *) && checks.TypeCheck.eradicate then @@ -335,7 +335,7 @@ end (* MkCallback *) module EmptyExtension : ExtensionT = struct - let update_payloads typestate_opt (payloads: Payloads.t) = + let update_payloads typestate_opt (payloads : Payloads.t) = {payloads with typestate= typestate_opt} end diff --git a/infer/src/eradicate/eradicateChecks.ml b/infer/src/eradicate/eradicateChecks.ml index afa6868f0..630123bd9 100644 --- a/infer/src/eradicate/eradicateChecks.ml +++ b/infer/src/eradicate/eradicateChecks.ml @@ -61,8 +61,8 @@ let is_virtual = function (** 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 = +let check_field_access tenv find_canonical_duplicate curr_pname node instr_ref exp fname ta loc : + unit = if TypeAnnotation.get_value AnnotatedSignature.Nullable ta then let origin_descr = TypeAnnotation.descr_origin ta in report_error tenv find_canonical_duplicate @@ -90,7 +90,7 @@ type from_call = | From_containsKey (** x.containsKey *) [@@deriving compare] -let equal_from_call = [%compare.equal : from_call] +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 node e typ ta true_branch @@ -132,18 +132,21 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc node e ty (* heuristic to check if the condition is the translation of try-with-resources *) match Printer.LineReader.from_loc linereader loc with | Some line -> - not (String.is_substring ~substring:"==" line || String.is_substring ~substring:"!=" line) - && String.is_substring ~substring:"}" line && contains_instanceof_throwable curr_pdesc node + (not (String.is_substring ~substring:"==" line || String.is_substring ~substring:"!=" line)) + && String.is_substring ~substring:"}" line + && contains_instanceof_throwable curr_pdesc node | None -> false in let is_temp = Idenv.exp_is_temp idenv e in let nonnull = is_fun_nonnull ta in let should_report = - not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta) - && (Config.eradicate_condition_redundant || nonnull) && true_branch && (not is_temp || nonnull) - && PatternMatch.type_is_class typ && not (from_try_with_resources ()) - && equal_from_call from_call From_condition && not (TypeAnnotation.origin_is_fun_library ta) + (not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta)) + && (Config.eradicate_condition_redundant || nonnull) + && true_branch && ((not is_temp) || nonnull) && PatternMatch.type_is_class typ + && (not (from_try_with_resources ())) + && 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 @@ -167,11 +170,13 @@ let check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_r let curr_pname = Procdesc.get_proc_name curr_pdesc in let t_lhs, ta_lhs, _ = typecheck_expr node instr_ref curr_pdesc typestate exp_lhs - (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) loc + (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) + loc in let _, ta_rhs, _ = typecheck_expr node instr_ref curr_pdesc typestate exp_rhs - (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) loc + (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) + loc in let should_report_nullable = let field_is_field_injector_readwrite () = @@ -181,21 +186,24 @@ let check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_r | _ -> false in - not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta_lhs) + (not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta_lhs)) && TypeAnnotation.get_value AnnotatedSignature.Nullable ta_rhs - && PatternMatch.type_is_class t_lhs && not (Typ.Fieldname.Java.is_outer_instance fname) + && PatternMatch.type_is_class t_lhs + && (not (Typ.Fieldname.Java.is_outer_instance fname)) && not (field_is_field_injector_readwrite ()) in let should_report_absent = - Config.eradicate_optional_present && TypeAnnotation.get_value AnnotatedSignature.Present ta_lhs - && not (TypeAnnotation.get_value AnnotatedSignature.Present ta_rhs) + Config.eradicate_optional_present + && TypeAnnotation.get_value AnnotatedSignature.Present ta_lhs + && (not (TypeAnnotation.get_value AnnotatedSignature.Present ta_rhs)) && not (Typ.Fieldname.Java.is_outer_instance fname) in let should_report_mutable = let field_is_mutable () = match t_ia_opt with Some (_, ia) -> Annotations.ia_is_mutable ia | _ -> false in - Config.eradicate_field_not_mutable && not (Typ.Procname.is_constructor curr_pname) + Config.eradicate_field_not_mutable + && (not (Typ.Procname.is_constructor curr_pname)) && ( match curr_pname with | Typ.Procname.Java java_pname -> not (Typ.Procname.Java.is_class_initializer java_pname) @@ -210,11 +218,12 @@ let check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_r if Models.Inference.enabled then Models.Inference.field_add_nullable_annotation fname ; let origin_descr = TypeAnnotation.descr_origin ta_rhs in report_error tenv find_canonical_duplicate - (TypeErr.Field_annotation_inconsistent (ann, fname, origin_descr)) (Some instr_ref) loc - curr_pdesc ) ; + (TypeErr.Field_annotation_inconsistent (ann, fname, origin_descr)) + (Some instr_ref) loc curr_pdesc ) ; if should_report_mutable then let origin_descr = TypeAnnotation.descr_origin ta_rhs in - report_error tenv find_canonical_duplicate (TypeErr.Field_not_mutable (fname, origin_descr)) + report_error tenv find_canonical_duplicate + (TypeErr.Field_not_mutable (fname, origin_descr)) (Some instr_ref) loc curr_pdesc @@ -240,11 +249,11 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu let filter_range_opt = function Some (_, ta, _) -> f ta | None -> unknown in List.exists ~f:(function - | pname, typestate -> - let pvar = - Pvar.mk (Mangled.from_string (Typ.Fieldname.to_string fn)) pname - in - filter_range_opt (TypeState.lookup_pvar pvar typestate)) + | pname, typestate -> + let pvar = + Pvar.mk (Mangled.from_string (Typ.Fieldname.to_string fn)) pname + in + filter_range_opt (TypeState.lookup_pvar pvar typestate)) list in let may_be_assigned_in_final_typestate = @@ -269,25 +278,28 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu let fld_cname = Typ.Fieldname.Java.get_class fn in String.equal (Typ.Name.name name) fld_cname in - not injector_readonly_annotated && PatternMatch.type_is_class ft && in_current_class + (not injector_readonly_annotated) && PatternMatch.type_is_class ft + && in_current_class && not (Typ.Fieldname.Java.is_outer_instance fn) in if should_check_field_initialization then ( if Models.Inference.enabled then Models.Inference.field_add_nullable_annotation fn ; (* Check if field is missing annotation. *) if - not (nullable_annotated || nonnull_annotated) + (not (nullable_annotated || nonnull_annotated)) && not may_be_assigned_in_final_typestate then report_error tenv find_canonical_duplicate - (TypeErr.Field_not_initialized (fn, curr_pname)) None loc curr_pdesc ; + (TypeErr.Field_not_initialized (fn, curr_pname)) + None loc curr_pdesc ; (* Check if field is over-annotated. *) if Config.eradicate_field_over_annotated && nullable_annotated && not (may_be_nullable_in_final_typestate ()) then report_error tenv find_canonical_duplicate - (TypeErr.Field_over_annotated (fn, curr_pname)) None loc curr_pdesc ) + (TypeErr.Field_over_annotated (fn, curr_pname)) + None loc curr_pdesc ) in List.iter ~f:do_field fields | None -> @@ -298,7 +310,7 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu (** Check the annotations when returning from a method. *) let check_return_annotation tenv find_canonical_duplicate curr_pdesc ret_range - (annotated_signature: AnnotatedSignature.t) ret_implicitly_nullable loc : unit = + (annotated_signature : AnnotatedSignature.t) ret_implicitly_nullable loc : unit = let ret_ia, _ = annotated_signature.ret in let curr_pname = Procdesc.get_proc_name curr_pdesc in let ret_annotated_nullable = @@ -323,24 +335,24 @@ let check_return_annotation tenv find_canonical_duplicate curr_pdesc ret_range let final_present = TypeAnnotation.get_value AnnotatedSignature.Present final_ta in let origin_descr = TypeAnnotation.descr_origin final_ta in let return_not_nullable = - final_nullable && not ret_annotated_nullable && not ret_implicitly_nullable + final_nullable && (not ret_annotated_nullable) && (not ret_implicitly_nullable) && not (return_nonnull_silent && ret_annotated_nonnull) in let return_value_not_present = - Config.eradicate_optional_present && not final_present && ret_annotated_present + Config.eradicate_optional_present && (not final_present) && ret_annotated_present in let return_over_annotated = - not final_nullable && ret_annotated_nullable && Config.eradicate_return_over_annotated + (not final_nullable) && ret_annotated_nullable && Config.eradicate_return_over_annotated in if return_not_nullable && Models.Inference.enabled then Models.Inference.proc_mark_return_nullable curr_pname ; ( if return_not_nullable || return_value_not_present then - let ann = - if return_not_nullable then AnnotatedSignature.Nullable else AnnotatedSignature.Present - in - report_error tenv find_canonical_duplicate - (TypeErr.Return_annotation_inconsistent (ann, curr_pname, origin_descr)) None loc - curr_pdesc ) ; + let ann = + if return_not_nullable then AnnotatedSignature.Nullable else AnnotatedSignature.Present + in + report_error tenv find_canonical_duplicate + (TypeErr.Return_annotation_inconsistent (ann, curr_pname, origin_descr)) + None loc curr_pdesc ) ; if return_over_annotated then report_error tenv find_canonical_duplicate (TypeErr.Return_over_annotated curr_pname) None loc curr_pdesc @@ -350,16 +362,18 @@ let check_return_annotation tenv find_canonical_duplicate curr_pdesc ret_range (** Check the receiver of a virtual call. *) let check_call_receiver tenv find_canonical_duplicate curr_pdesc node typestate call_params - callee_pname (instr_ref: TypeErr.InstrRef.t) loc typecheck_expr : unit = + callee_pname (instr_ref : TypeErr.InstrRef.t) loc typecheck_expr : unit = match call_params with | ((original_this_e, this_e), typ) :: _ -> let _, this_ta, _ = typecheck_expr tenv node instr_ref curr_pdesc typestate this_e - (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, []) loc + (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, []) + loc in let null_method_call = TypeAnnotation.get_value AnnotatedSignature.Nullable this_ta in let optional_get_on_absent = - Config.eradicate_optional_present && Models.is_optional_get callee_pname + Config.eradicate_optional_present + && Models.is_optional_get callee_pname && not (TypeAnnotation.get_value AnnotatedSignature.Present this_ta) in if null_method_call || optional_get_on_absent then @@ -399,8 +413,8 @@ let check_call_parameters tenv find_canonical_duplicate curr_pdesc node callee_a let callee_loc = callee_attributes.ProcAttributes.loc in report_error tenv find_canonical_duplicate (TypeErr.Parameter_annotation_inconsistent - (ann, description, param_num, callee_pname, callee_loc, origin_descr)) (Some instr_ref) - loc curr_pdesc + (ann, description, param_num, callee_pname, callee_loc, origin_descr)) + (Some instr_ref) loc curr_pdesc in let check_ann ann = let b1 = TypeAnnotation.get_value ann ta1 in @@ -422,7 +436,8 @@ let check_call_parameters tenv find_canonical_duplicate curr_pdesc node callee_a let should_check_parameters = match callee_pname with | Typ.Procname.Java java_pname -> - not (Typ.Procname.Java.is_external java_pname) || Models.is_modelled_nullable callee_pname + (not (Typ.Procname.Java.is_external java_pname)) + || Models.is_modelled_nullable callee_pname | _ -> false in @@ -447,19 +462,19 @@ let check_overridden_annotations find_canonical_duplicate tenv proc_name proc_de in if ret_is_nullable && not ret_overridden_nullable then report_error tenv find_canonical_duplicate - (TypeErr.Inconsistent_subclass_return_annotation (proc_name, overriden_proc_name)) None loc - proc_desc + (TypeErr.Inconsistent_subclass_return_annotation (proc_name, overriden_proc_name)) + None loc proc_desc and check_params overriden_proc_name overriden_signature = let compare pos current_param overriden_param : int = let current_name, current_ia, _ = current_param in let _, overriden_ia, _ = overriden_param in let () = - if not (Annotations.ia_is_nullable current_ia) && Annotations.ia_is_nullable overriden_ia + if (not (Annotations.ia_is_nullable current_ia)) && Annotations.ia_is_nullable overriden_ia then report_error tenv find_canonical_duplicate (TypeErr.Inconsistent_subclass_parameter_annotation - (Mangled.to_string current_name, pos, proc_name, overriden_proc_name)) None loc - proc_desc + (Mangled.to_string current_name, pos, proc_name, overriden_proc_name)) + None loc proc_desc in pos + 1 in diff --git a/infer/src/eradicate/immutableChecker.ml b/infer/src/eradicate/immutableChecker.ml index 7103844a1..19b7448f1 100644 --- a/infer/src/eradicate/immutableChecker.ml +++ b/infer/src/eradicate/immutableChecker.ml @@ -10,8 +10,7 @@ open! IStd (** Check an implicit cast when returning an immutable collection from a method whose type is mutable. *) let check_immutable_cast tenv curr_pname curr_pdesc typ_expected typ_found_opt loc : unit = match typ_found_opt with - | Some typ_found - -> ( + | Some typ_found -> ( let casts = [ ("java.util.List", "com.google.common.collect.ImmutableList") ; ("java.util.Map", "com.google.common.collect.ImmutableMap") diff --git a/infer/src/eradicate/models.ml b/infer/src/eradicate/models.ml index 9b2497ae5..b1c8f8c1b 100644 --- a/infer/src/eradicate/models.ml +++ b/infer/src/eradicate/models.ml @@ -139,16 +139,16 @@ let get_modelled_annotated_signature proc_attributes = if mark_r then AnnotatedSignature.mark_return AnnotatedSignature.Nullable ann_sig else ann_sig in let lookup_models_nullable ann_sig = - try - let mark = Hashtbl.find annotated_table_nullable proc_id in - AnnotatedSignature.mark proc_name AnnotatedSignature.Nullable ann_sig mark - with Caml.Not_found -> ann_sig + try + let mark = Hashtbl.find annotated_table_nullable proc_id in + AnnotatedSignature.mark proc_name AnnotatedSignature.Nullable ann_sig mark + with Caml.Not_found -> ann_sig in let lookup_models_present ann_sig = - try - let mark = Hashtbl.find annotated_table_present proc_id in - AnnotatedSignature.mark proc_name AnnotatedSignature.Present ann_sig mark - with Caml.Not_found -> ann_sig + try + let mark = Hashtbl.find annotated_table_present proc_id in + AnnotatedSignature.mark proc_name AnnotatedSignature.Present ann_sig mark + with Caml.Not_found -> ann_sig in annotated_signature |> lookup_models_nullable |> lookup_models_present |> infer_return |> infer_parameters @@ -156,11 +156,11 @@ let get_modelled_annotated_signature proc_attributes = (** Return true when the procedure has been modelled for nullable. *) let is_modelled_nullable proc_name = - let proc_id = Typ.Procname.to_unique_id proc_name in - try - ignore (Hashtbl.find annotated_table_nullable proc_id) ; - true - with Caml.Not_found -> false + let proc_id = Typ.Procname.to_unique_id proc_name in + try + ignore (Hashtbl.find annotated_table_nullable proc_id) ; + true + with Caml.Not_found -> false (** Check if the procedure is one of the known Preconditions.checkNotNull. *) diff --git a/infer/src/eradicate/typeAnnotation.ml b/infer/src/eradicate/typeAnnotation.ml index bc3466ce6..6eca72b98 100644 --- a/infer/src/eradicate/typeAnnotation.ml +++ b/infer/src/eradicate/typeAnnotation.ml @@ -15,7 +15,7 @@ end) type t = {map: bool AnnotationsMap.t; origin: TypeOrigin.t} [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let get_value ann ta = try AnnotationsMap.find ann ta.map with Caml.Not_found -> false diff --git a/infer/src/eradicate/typeCheck.ml b/infer/src/eradicate/typeCheck.ml index f6347e948..e246c58f6 100644 --- a/infer/src/eradicate/typeCheck.ml +++ b/infer/src/eradicate/typeCheck.ml @@ -117,7 +117,7 @@ type checks = {eradicate: bool; check_ret_type: check_return_type list} (** Typecheck an expression. *) let rec typecheck_expr find_canonical_duplicate visited checks tenv node instr_ref - (curr_pdesc: Procdesc.t) typestate e tr_default loc : TypeState.range = + (curr_pdesc : Procdesc.t) typestate e tr_default loc : TypeState.range = match e with | _ when Exp.is_null_literal e -> let typ, ta, locs = tr_default in @@ -147,7 +147,8 @@ let rec typecheck_expr find_canonical_duplicate visited checks tenv node instr_r let _, ta, locs' = typecheck_expr find_canonical_duplicate visited checks tenv node instr_ref curr_pdesc typestate exp - (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, locs) loc + (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, locs) + loc in let exp_origin = TypeAnnotation.get_origin ta in let tr_new = @@ -181,7 +182,7 @@ let rec typecheck_expr find_canonical_duplicate visited checks tenv node instr_r (** Typecheck an instruction. *) -let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pname curr_pdesc +let typecheck_instr tenv calls_this checks (node : Procdesc.Node.t) idenv curr_pname curr_pdesc find_canonical_duplicate annotated_signature instr_ref linereader typestate instr = (* let print_current_state () = *) (* L.stdout "Current Typestate in node %a@\n%a@." *) @@ -234,7 +235,7 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn match TypeState.lookup_pvar pvar typestate with | Some _ when not is_assignment -> typestate - | _ -> + | _ -> ( match EradicateChecks.get_field_annotation tenv fn typ with | Some (t, ia) -> let range = @@ -244,7 +245,7 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn in TypeState.add pvar range typestate | None -> - typestate + typestate ) in (* Convert a function call to a pvar. *) let handle_function_call call_node id = @@ -272,8 +273,7 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn match exp with | Exp.Var id when Errdesc.find_normal_variable_funcall node' id <> None -> handle_function_call node' id - | Exp.Lvar pvar when Pvar.is_frontend_tmp pvar - -> ( + | Exp.Lvar pvar when Pvar.is_frontend_tmp pvar -> ( let frontend_variable_assignment = Errdesc.find_program_variable_assignment node pvar in match frontend_variable_assignment with | Some (call_node, id) -> @@ -323,10 +323,8 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn let typestate' = update_typestate_fld pvar inner_origin fn typ in (Exp.Lvar pvar, typestate') | Exp.Lvar _ | Exp.Lfield _ -> ( - match - (* treat var.field1. ... .fieldn as a constant *) - ComplexExpressions.exp_to_string tenv node' exp - with + (* treat var.field1. ... .fieldn as a constant *) + match ComplexExpressions.exp_to_string tenv node' exp with | Some exp_str -> let pvar = Pvar.mk (Mangled.from_string exp_str) curr_pname in let typestate' = update_typestate_fld pvar inner_origin fn typ in @@ -405,20 +403,21 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn match frontent_variable_assignment with | None -> typestate' - | Some (node', id) -> + | Some (node', id) -> ( (* handle the case where pvar is a frontend-generated program variable *) let exp = Idenv.expand_expr idenv (Exp.Var id) in match convert_complex_exp_to_pvar node' false exp typestate' loc with | Exp.Lvar pvar', _ -> handle_pvar typestate' pvar' | _ -> - typestate' + typestate' ) in (* typecheck_expr with fewer parameters, using a common template for typestate range *) let typecheck_expr_simple typestate1 exp1 typ1 origin1 loc1 = typecheck_expr find_canonical_duplicate calls_this checks tenv node instr_ref curr_pdesc typestate1 exp1 - (typ1, TypeAnnotation.const AnnotatedSignature.Nullable false origin1, [loc1]) loc1 + (typ1, TypeAnnotation.const AnnotatedSignature.Nullable false origin1, [loc1]) + loc1 in (* check if there are errors in exp1 *) let typecheck_expr_for_errors typestate1 exp1 loc1 : unit = @@ -464,7 +463,8 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn in check_field_assign () ; typestate2 | Sil.Call ((id, _), Exp.Const (Const.Cfun pn), [(_, typ)], loc, _) - when Typ.Procname.equal pn BuiltinDecl.__new || Typ.Procname.equal pn BuiltinDecl.__new_array -> + when Typ.Procname.equal pn BuiltinDecl.__new || Typ.Procname.equal pn BuiltinDecl.__new_array + -> TypeState.add_id id (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.New, [loc]) typestate @@ -480,7 +480,8 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn let _, ta, _ = typecheck_expr find_canonical_duplicate calls_this checks tenv node instr_ref curr_pdesc typestate array_exp - (t, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) loc + (t, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) + loc in if checks.eradicate then EradicateChecks.check_array_access tenv find_canonical_duplicate curr_pdesc node instr_ref @@ -490,7 +491,8 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn TypeState.add_id id ( Typ.mk (Tint Typ.IInt) , TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.New - , [loc] ) typestate + , [loc] ) + typestate | Sil.Call (_, Exp.Const (Const.Cfun pn), _, _, _) when BuiltinDecl.is_declared pn -> typestate (* skip othe builtins *) | Sil.Call @@ -559,15 +561,15 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn | Some (t, ta, _) -> let should_report = Config.eradicate_condition_redundant - && not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta) + && (not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta)) && not (TypeAnnotation.origin_is_fun_library ta) in ( if checks.eradicate && should_report then - let cond = Exp.BinOp (Binop.Ne, Exp.Lvar pvar, Exp.null) in - EradicateChecks.report_error tenv find_canonical_duplicate - (TypeErr.Condition_redundant - (true, EradicateChecks.explain_expr tenv node cond, false)) (Some instr_ref) - loc curr_pdesc ) ; + let cond = Exp.BinOp (Binop.Ne, Exp.Lvar pvar, Exp.null) in + EradicateChecks.report_error tenv find_canonical_duplicate + (TypeErr.Condition_redundant + (true, EradicateChecks.explain_expr tenv node cond, false)) + (Some instr_ref) loc curr_pdesc ) ; TypeState.add pvar (t, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) typestate'' @@ -644,8 +646,7 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn () in match call_params with - | ((_, Exp.Lvar pvar), _) :: _ - -> ( + | ((_, Exp.Lvar pvar), _) :: _ -> ( (* temporary variable for the value of the boolean condition *) let curr_node = TypeErr.InstrRef.get_node instr_ref in let branch = false in @@ -680,13 +681,13 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn let pname_get_from_pname_put pname_put = let object_t = Typ.Name.Java.Split.java_lang_object in let parameters = [object_t] in - pname_put |> Typ.Procname.Java.replace_method_name "get" + pname_put + |> Typ.Procname.Java.replace_method_name "get" |> Typ.Procname.Java.replace_return_type object_t |> Typ.Procname.Java.replace_parameters parameters in match call_params with - | ((_, Exp.Lvar pv_map), _) :: ((_, exp_key), _) :: ((_, exp_value), typ_value) :: _ - -> ( + | ((_, Exp.Lvar pv_map), _) :: ((_, exp_key), _) :: ((_, exp_value), typ_value) :: _ -> ( (* Convert the dexp for k to the dexp for m.get(k) *) let convert_dexp_key_to_dexp_get dopt = match (dopt, callee_pname) with @@ -722,7 +723,8 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn let _, ta2, _ = typecheck_expr find_canonical_duplicate calls_this checks tenv node instr_ref curr_pdesc typestate e2 - (t2, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, []) loc + (t2, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, []) + loc in let formal = (s1, ta1, t1) in let actual = (orig_e2, ta2) in @@ -734,7 +736,7 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn in (* Apply a function that operates on annotations *) let apply_annotation_transformer resolved_ret - (resolved_params: EradicateChecks.resolved_param list) = + (resolved_params : EradicateChecks.resolved_param list) = let rec handle_params resolved_ret params = match (params : EradicateChecks.resolved_param list) with | param :: params' when param.propagates_nullable -> @@ -795,9 +797,9 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn let typestate_after_call = if not is_anonymous_inner_class_constructor then ( ( if Config.eradicate_debug then - let unique_id = Typ.Procname.to_unique_id callee_pname in - let classification = EradicateChecks.classify_procedure callee_attributes in - L.result " %s unique id: %s@." classification unique_id ) ; + let unique_id = Typ.Procname.to_unique_id callee_pname in + let classification = EradicateChecks.classify_procedure callee_attributes in + L.result " %s unique id: %s@." classification unique_id ) ; if cflags.CallFlags.cf_virtual && checks.eradicate then EradicateChecks.check_call_receiver tenv find_canonical_duplicate curr_pdesc node typestate1 call_params callee_pname instr_ref loc @@ -864,10 +866,12 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn let map_dexp = function | Some (DExp.Dretcall - (DExp.Dconst (Const.Cfun (Typ.Procname.Java pname_java)), args, loc, call_flags)) -> + (DExp.Dconst (Const.Cfun (Typ.Procname.Java pname_java)), args, loc, call_flags)) + -> let pname_java' = let object_t = Typ.Name.Java.Split.java_lang_object in - pname_java |> Typ.Procname.Java.replace_method_name "get" + pname_java + |> Typ.Procname.Java.replace_method_name "get" |> Typ.Procname.Java.replace_return_type object_t in let fun_dexp = DExp.Dconst (Const.Cfun (Typ.Procname.Java pname_java')) in @@ -909,8 +913,7 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn match[@warning "-57"] c with | Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), e) | Exp.BinOp (Binop.Eq, e, Exp.Const (Const.Cint i)) - when IntLit.iszero i - -> ( + when IntLit.iszero i -> ( typecheck_expr_for_errors typestate e loc ; let typestate1, e1, from_call = match from_is_true_on_null e with @@ -936,25 +939,24 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn typestate2 ) | Exp.BinOp (Binop.Ne, Exp.Const (Const.Cint i), e) | Exp.BinOp (Binop.Ne, e, Exp.Const (Const.Cint i)) - when IntLit.iszero i - -> ( + when IntLit.iszero i -> ( typecheck_expr_for_errors typestate e loc ; let typestate1, e1, from_call = match from_instanceof e with | Some e1 -> (* (e1 instanceof C) implies (e1 != null) *) (typestate, e1, EradicateChecks.From_instanceof) - | None -> + | None -> ( match from_optional_isPresent e with | Some e1 -> (typestate, e1, EradicateChecks.From_optional_isPresent) - | None -> + | None -> ( match from_is_false_on_null e with | Some e1 -> (typestate, e1, EradicateChecks.From_is_false_on_null) | None -> if Option.is_some (from_containsKey e) then handle_containsKey e - else (typestate, e, EradicateChecks.From_condition) + else (typestate, e, EradicateChecks.From_condition) ) ) in let e', typestate2 = convert_complex_exp_to_pvar node' false e1 typestate1 loc in let typ, ta, _ = @@ -993,7 +995,8 @@ let typecheck_instr tenv calls_this checks (node: Procdesc.Node.t) idenv curr_pn let found = ref None in let do_instr i = match i with - | Sil.Store (e, _, e', _) when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv e') -> + | Sil.Store (e, _, e', _) when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv e') + -> found := Some e | _ -> () @@ -1058,7 +1061,8 @@ let typecheck_node tenv calls_this checks idenv curr_pname curr_pdesc find_canon if has_exceptions then typestates_exn := typestate :: !typestates_exn | Sil.Store (Exp.Lvar pv, _, _, _) when Pvar.is_return pv - && Procdesc.Node.equal_nodekind (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 | _ -> diff --git a/infer/src/eradicate/typeCheck.mli b/infer/src/eradicate/typeCheck.mli index 4606f0e70..51c4bd95f 100644 --- a/infer/src/eradicate/typeCheck.mli +++ b/infer/src/eradicate/typeCheck.mli @@ -17,6 +17,15 @@ type find_canonical_duplicate = Procdesc.Node.t -> Procdesc.Node.t type checks = {eradicate: bool; check_ret_type: check_return_type list} val typecheck_node : - Tenv.t -> bool ref -> checks -> Idenv.t -> Typ.Procname.t -> Procdesc.t - -> find_canonical_duplicate -> AnnotatedSignature.t -> TypeState.t -> Procdesc.Node.t - -> Printer.LineReader.t -> TypeState.t list * TypeState.t list + Tenv.t + -> bool ref + -> checks + -> Idenv.t + -> Typ.Procname.t + -> Procdesc.t + -> find_canonical_duplicate + -> AnnotatedSignature.t + -> TypeState.t + -> Procdesc.Node.t + -> Printer.LineReader.t + -> TypeState.t list * TypeState.t list diff --git a/infer/src/eradicate/typeErr.ml b/infer/src/eradicate/typeErr.ml index 7cd77e9f8..054f0427f 100644 --- a/infer/src/eradicate/typeErr.ml +++ b/infer/src/eradicate/typeErr.ml @@ -37,7 +37,7 @@ end module InstrRef : InstrRefT = struct type t = Procdesc.Node.t * int [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] type generator = Procdesc.Node.t * int ref @@ -94,7 +94,7 @@ type err_instance = module H = Hashtbl.Make (struct type t = err_instance * InstrRef.t option [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let err_instance_hash x = let string_hash s = Hashtbl.hash s in @@ -217,7 +217,7 @@ module Severity = struct else None - let this_type_get_severity tenv (signature: AnnotatedSignature.t) = + let this_type_get_severity tenv (signature : AnnotatedSignature.t) = match signature.params with | (p, _, this_type) :: _ when String.equal (Mangled.to_string p) "this" -> Option.bind ~f:get_severity (PatternMatch.type_get_annotation tenv this_type) @@ -245,12 +245,19 @@ end (* Severity *) type st_report_error = - Typ.Procname.t -> Procdesc.t -> IssueType.t -> Location.t -> ?field_name:Typ.Fieldname.t option - -> ?origin_loc:Location.t option -> ?exception_kind:(IssueType.t -> Localise.error_desc -> exn) - -> ?severity:Exceptions.severity -> string -> unit + Typ.Procname.t + -> Procdesc.t + -> IssueType.t + -> Location.t + -> ?field_name:Typ.Fieldname.t option + -> ?origin_loc:Location.t option + -> ?exception_kind:(IssueType.t -> Localise.error_desc -> exn) + -> ?severity:Exceptions.severity + -> string + -> unit (** Report an error right now. *) -let report_error_now tenv (st_report_error: st_report_error) err_instance loc pdesc : unit = +let report_error_now tenv (st_report_error : st_report_error) err_instance loc pdesc : unit = let pname = Procdesc.get_proc_name pdesc in let nullable_annotation = "@Nullable" in let mutable_annotation = "@Mutable" in @@ -334,7 +341,8 @@ let report_error_now tenv (st_report_error: st_report_error) err_instance loc pd origin_description , None , origin_loc ) - | Call_receiver_annotation_inconsistent (ann, s_opt, pn, (origin_description, origin_loc, _)) -> + | Call_receiver_annotation_inconsistent (ann, s_opt, pn, (origin_description, origin_loc, _)) + -> let kind_s, description = match ann with | AnnotatedSignature.Nullable -> @@ -435,7 +443,7 @@ let report_error_now tenv (st_report_error: st_report_error) err_instance loc pd (** Report an error unless is has been reported already, or unless it's a forall error since it requires waiting until the end of the analysis and be printed by flush. *) -let report_error tenv (st_report_error: st_report_error) find_canonical_duplicate err_instance +let report_error tenv (st_report_error : st_report_error) find_canonical_duplicate err_instance instr_ref_opt loc pdesc = let should_report_now = add_err find_canonical_duplicate err_instance instr_ref_opt loc in if should_report_now then report_error_now tenv st_report_error err_instance loc pdesc diff --git a/infer/src/eradicate/typeErr.mli b/infer/src/eradicate/typeErr.mli index 3270f95f9..4117649ac 100644 --- a/infer/src/eradicate/typeErr.mli +++ b/infer/src/eradicate/typeErr.mli @@ -28,7 +28,6 @@ module type InstrRefT = sig end (* InstrRefT *) - module InstrRef : InstrRefT type origin_descr = string * Location.t option * AnnotatedSignature.t option @@ -65,13 +64,26 @@ type err_instance = val node_reset_forall : Procdesc.Node.t -> unit type st_report_error = - Typ.Procname.t -> Procdesc.t -> IssueType.t -> Location.t -> ?field_name:Typ.Fieldname.t option - -> ?origin_loc:Location.t option -> ?exception_kind:(IssueType.t -> Localise.error_desc -> exn) - -> ?severity:Exceptions.severity -> string -> unit + Typ.Procname.t + -> Procdesc.t + -> IssueType.t + -> Location.t + -> ?field_name:Typ.Fieldname.t option + -> ?origin_loc:Location.t option + -> ?exception_kind:(IssueType.t -> Localise.error_desc -> exn) + -> ?severity:Exceptions.severity + -> string + -> unit val report_error : - Tenv.t -> st_report_error -> (Procdesc.Node.t -> Procdesc.Node.t) -> err_instance - -> InstrRef.t option -> Location.t -> Procdesc.t -> unit + Tenv.t + -> st_report_error + -> (Procdesc.Node.t -> Procdesc.Node.t) + -> err_instance + -> InstrRef.t option + -> Location.t + -> Procdesc.t + -> unit val report_forall_checks_and_reset : Tenv.t -> st_report_error -> Procdesc.t -> unit diff --git a/infer/src/eradicate/typeOrigin.ml b/infer/src/eradicate/typeOrigin.ml index 706715dfa..59fa22c32 100644 --- a/infer/src/eradicate/typeOrigin.ml +++ b/infer/src/eradicate/typeOrigin.ml @@ -26,7 +26,7 @@ type t = | Undef [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let rec to_string = function | Const _ -> diff --git a/infer/src/eradicate/typeState.ml b/infer/src/eradicate/typeState.ml index 9d32d0a56..7e490fa97 100644 --- a/infer/src/eradicate/typeState.ml +++ b/infer/src/eradicate/typeState.ml @@ -21,7 +21,7 @@ type range = Typ.t * TypeAnnotation.t * Location.t list [@@deriving compare] type t = range M.t [@@deriving compare] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let empty = M.empty @@ -90,8 +90,8 @@ let map_join m1 m2 = let join t1 t2 = let tjoin = map_join t1 t2 in ( if Config.write_html then - let s = F.asprintf "State 1:@.%a@.State 2:@.%a@.After Join:@.%a@." pp t1 pp t2 pp tjoin in - L.d_strln s ) ; + let s = F.asprintf "State 1:@.%a@.State 2:@.%a@.After Join:@.%a@." pp t1 pp t2 pp tjoin in + L.d_strln s ) ; tjoin diff --git a/infer/src/infer.ml b/infer/src/infer.ml index ae3e0e4f3..037dd34cf 100644 --- a/infer/src/infer.ml +++ b/infer/src/infer.ml @@ -44,7 +44,7 @@ let setup () = then ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir () ; if - CLOpt.is_originator && not Config.continue_capture + CLOpt.is_originator && (not Config.continue_capture) && not Driver.(equal_mode driver_mode Analyze) then SourceFiles.mark_all_stale () | Explore -> @@ -74,7 +74,8 @@ let log_environment_info () = L.environment_info "No .inferconfig file found@\n" ) ; L.environment_info "Project root = %s@\n" Config.project_root ; let infer_args = - Sys.getenv CLOpt.args_env_var |> Option.map ~f:(String.split ~on:CLOpt.env_var_sep) + Sys.getenv CLOpt.args_env_var + |> Option.map ~f:(String.split ~on:CLOpt.env_var_sep) |> Option.value ~default:[""] in L.environment_info "INFER_ARGS = %a" Pp.cli_args infer_args ; @@ -99,11 +100,11 @@ let prepare_events_logging () = let () = ( if Config.linters_validate_syntax_only then - match CTLParserHelper.validate_al_files () with - | Ok () -> - L.exit 0 - | Error e -> - print_endline e ; L.exit 3 ) ; + match CTLParserHelper.validate_al_files () with + | Ok () -> + L.exit 0 + | Error e -> + print_endline e ; L.exit 3 ) ; ( match Config.check_version with | Some check_version -> if not (String.equal check_version Version.versionString) then @@ -119,9 +120,9 @@ let () = if Config.debug_mode && CLOpt.is_originator then L.progress "Logs in %s@." (Config.results_dir ^/ Config.log_file) ; ( if Config.test_determinator then ( - TestDeterminator.test_to_run_java Config.modified_lines Config.profiler_samples - Config.method_decls_info ; - TestDeterminator.emit_tests_to_run () ) + TestDeterminator.test_to_run_java Config.modified_lines Config.profiler_samples + Config.method_decls_info ; + TestDeterminator.emit_tests_to_run () ) else match Config.command with | Analyze -> @@ -165,8 +166,10 @@ let () = let if_true key opt args = if not opt then args else key :: args in let if_false key opt args = if opt then args else key :: args in let args = - if_some "--max-level" Config.max_nesting @@ if_true "--only-show" Config.only_show - @@ if_false "--no-source" Config.source_preview @@ if_true "--html" Config.html + if_some "--max-level" Config.max_nesting + @@ if_true "--only-show" Config.only_show + @@ if_false "--no-source" Config.source_preview + @@ if_true "--html" Config.html @@ if_some "--select" Config.select ["-o"; Config.results_dir] in let prog = Config.lib_dir ^/ "python" ^/ "inferTraceBugs" in diff --git a/infer/src/infertop.ml b/infer/src/infertop.ml index 7f618bcdd..22d73654b 100644 --- a/infer/src/infertop.ml +++ b/infer/src/infertop.ml @@ -4,4 +4,6 @@ * This source code is licensed under the MIT license found in the * LICENSE file in the root directory of this source tree. *) -;; UTop_main.main () + +;; +UTop_main.main () diff --git a/infer/src/integration/Buck.ml b/infer/src/integration/Buck.ml index bd992a0f6..d3961c57e 100644 --- a/infer/src/integration/Buck.ml +++ b/infer/src/integration/Buck.ml @@ -142,7 +142,8 @@ let resolve_pattern_targets ~filter_kind ~dep_depth targets = targets |> List.rev_map ~f:Query.target |> Query.set |> (match dep_depth with None -> Fn.id | Some depth -> Query.deps ?depth) |> (if filter_kind then Query.kind ~pattern:(get_accepted_buck_kinds_pattern ()) else Fn.id) - |> Query.exec |> die_if_empty (fun die -> die "*** buck query returned no targets.") + |> Query.exec + |> die_if_empty (fun die -> die "*** buck query returned no targets.") let resolve_alias_targets aliases = @@ -207,7 +208,8 @@ let add_flavors_to_buck_arguments ~filter_kind ~dep_depth ~extra_flavors origina parsed_args | param :: arg :: args when List.mem ~equal:String.equal parameters_with_argument param -> parse_cmd_args - {parsed_args with rev_not_targets'= arg :: param :: parsed_args.rev_not_targets'} args + {parsed_args with rev_not_targets'= arg :: param :: parsed_args.rev_not_targets'} + args | target :: args -> let parsed_args = match parse_target_string target with diff --git a/infer/src/integration/Buck.mli b/infer/src/integration/Buck.mli index 27613240b..57bd4d3d8 100644 --- a/infer/src/integration/Buck.mli +++ b/infer/src/integration/Buck.mli @@ -10,8 +10,11 @@ open! IStd type flavored_arguments = {command: string; rev_not_targets: string list; targets: string list} val add_flavors_to_buck_arguments : - filter_kind:[< `Yes | `No | `Auto] -> dep_depth:int option option -> extra_flavors:string list - -> string list -> flavored_arguments + filter_kind:[< `Yes | `No | `Auto] + -> dep_depth:int option option + -> extra_flavors:string list + -> string list + -> flavored_arguments (** Add infer flavors to the targets in the given buck arguments, depending on the infer analyzer. For instance, in capture mode, the buck command: build //foo/bar:baz#some,flavor diff --git a/infer/src/integration/CaptureCompilationDatabase.ml b/infer/src/integration/CaptureCompilationDatabase.ml index d9283cd33..82b2cca04 100644 --- a/infer/src/integration/CaptureCompilationDatabase.ml +++ b/infer/src/integration/CaptureCompilationDatabase.ml @@ -9,7 +9,7 @@ open! IStd module F = Format module L = Logging -let create_cmd (source_file, (compilation_data: CompilationDatabase.compilation_data)) = +let create_cmd (source_file, (compilation_data : CompilationDatabase.compilation_data)) = let swap_executable cmd = if String.is_suffix ~suffix:"++" cmd then Config.wrappers_dir ^/ "clang++" else Config.wrappers_dir ^/ "clang" @@ -24,7 +24,7 @@ let create_cmd (source_file, (compilation_data: CompilationDatabase.compilation_ ; escaped_arguments= ["@" ^ arg_file; "-fsyntax-only"] @ List.rev Config.clang_extra_flags } ) -let invoke_cmd (source_file, (cmd: CompilationDatabase.compilation_data)) = +let invoke_cmd (source_file, (cmd : CompilationDatabase.compilation_data)) = let argv = cmd.executable :: cmd.escaped_arguments in ( match Spawn.spawn ~cwd:(Path cmd.directory) ~prog:cmd.executable ~argv () with | pid -> @@ -35,16 +35,15 @@ let invoke_cmd (source_file, (cmd: CompilationDatabase.compilation_data)) = | exception Unix.Unix_error (err, f, arg) -> Error (F.asprintf "%s(%s): %s@." f arg (Unix.Error.message err)) ) |> function - | Ok () -> - () - | Error error -> - let log_or_die fmt = - if Config.linters_ignore_clang_failures || Config.keep_going then - L.debug Capture Quiet fmt - else L.die ExternalError fmt - in - log_or_die "Error running compilation for '%a': %a:@\n%s@." SourceFile.pp source_file - Pp.cli_args argv error + | Ok () -> + () + | Error error -> + let log_or_die fmt = + if Config.linters_ignore_clang_failures || Config.keep_going then L.debug Capture Quiet fmt + else L.die ExternalError fmt + in + log_or_die "Error running compilation for '%a': %a:@\n%s@." SourceFile.pp source_file + Pp.cli_args argv error let run_compilation_database compilation_database should_capture_file = @@ -74,19 +73,18 @@ let get_compilation_database_files_buck ~prog ~args = | {command= "build" as command; rev_not_targets; targets} -> let targets_args = Buck.store_args_in_file targets in let build_args = - command :: List.rev_append rev_not_targets (List.rev Config.buck_build_args_no_inline) - @ "--config" :: "*//cxx.pch_enabled=false" :: targets_args + (command :: List.rev_append rev_not_targets (List.rev Config.buck_build_args_no_inline)) + @ ("--config" :: "*//cxx.pch_enabled=false" :: targets_args) in Logging.(debug Linters Quiet) "Processed buck command is: 'buck %a'@\n" (Pp.seq F.pp_print_string) build_args ; Process.create_process_and_wait ~prog ~args:build_args ; let buck_targets_shell = - prog - :: "targets" + prog :: "targets" :: List.rev_append (Buck.filter_compatible `Targets rev_not_targets) (List.rev Config.buck_build_args_no_inline) - @ "--show-output" :: targets_args + @ ("--show-output" :: targets_args) in let on_target_lines = function | [] -> diff --git a/infer/src/integration/Clang.ml b/infer/src/integration/Clang.ml index bde1de2d4..b3fa2d65d 100644 --- a/infer/src/integration/Clang.ml +++ b/infer/src/integration/Clang.ml @@ -10,7 +10,7 @@ module L = Logging type compiler = Clang | Make [@@deriving compare] -let pp_extended_env fmt (env: Unix.env) = +let pp_extended_env fmt (env : Unix.env) = let pp_pair fmt (var, value) = F.fprintf fmt "%s=%s" var value in match env with | `Replace values -> @@ -39,18 +39,19 @@ let capture compiler ~prog ~args = match compiler with | Clang -> ClangWrapper.exe ~prog ~args - | Make -> + | Make -> ( let path_var = "PATH" in let old_path = Option.value ~default:"" (Sys.getenv path_var) in let new_path = Config.wrappers_dir ^ ":" ^ old_path in let extended_env = `Extend [(path_var, new_path); ("INFER_OLD_PATH", old_path)] in L.environment_info "Running command %s with env:@\n%a@\n@." prog pp_extended_env extended_env ; - Unix.fork_exec ~prog ~argv:(prog :: args) ~env:extended_env () |> Unix.waitpid + Unix.fork_exec ~prog ~argv:(prog :: args) ~env:extended_env () + |> Unix.waitpid |> function - | Ok () -> - () - | Error _ as status -> - L.(die ExternalError) - "*** capture command failed:@\n*** %s@\n*** %s@." - (String.concat ~sep:" " (prog :: args)) - (Unix.Exit_or_signal.to_string_hum status) + | Ok () -> + () + | Error _ as status -> + L.(die ExternalError) + "*** capture command failed:@\n*** %s@\n*** %s@." + (String.concat ~sep:" " (prog :: args)) + (Unix.Exit_or_signal.to_string_hum status) ) diff --git a/infer/src/integration/CompilationDatabase.ml b/infer/src/integration/CompilationDatabase.ml index 79b3f933c..758201248 100644 --- a/infer/src/integration/CompilationDatabase.ml +++ b/infer/src/integration/CompilationDatabase.ml @@ -33,7 +33,7 @@ let parse_command_and_arguments command_and_arguments = to be compiled, the directory to be compiled in, and the compilation command as a list and as a string. We pack this information into the compilationDatabase map, and remove the clang invocation part, because we will use a clang wrapper. *) -let decode_json_file (database: t) json_format = +let decode_json_file (database : t) json_format = let json_path = match json_format with `Raw x | `Escaped x -> x in let unescape_path s = match json_format with @@ -72,8 +72,7 @@ let decode_json_file (database: t) json_format = exit_format_error "the value of the \"command\" field is not a string; found '%s' instead" (Yojson.Basic.to_string json) - | "arguments", `List args - -> ( + | "arguments", `List args -> ( let args = List.map args ~f:(function | `String argument -> diff --git a/infer/src/integration/Driver.ml b/infer/src/integration/Driver.ml index 1923d7332..7d2a151e2 100644 --- a/infer/src/integration/Driver.ml +++ b/infer/src/integration/Driver.ml @@ -27,7 +27,7 @@ type mode = | XcodeXcpretty of string * string list [@@deriving compare] -let equal_mode = [%compare.equal : mode] +let equal_mode = [%compare.equal: mode] let pp_mode fmt = function | Analyze -> @@ -106,7 +106,7 @@ let clean_results_dir () = let suffixes_to_delete = [".txt"; ".csv"; ".json"] in fun name -> (* Keep the JSON report *) - not (String.equal (Filename.basename name) Config.report_json) + (not (String.equal (Filename.basename name) Config.report_json)) && ( List.mem ~equal:String.equal files_to_delete (Filename.basename name) || List.exists ~f:(Filename.check_suffix name) suffixes_to_delete ) in @@ -120,8 +120,7 @@ let clean_results_dir () = ( String.equal entry Filename.current_dir_name || String.equal entry Filename.parent_dir_name ) then delete_temp_results (name ^/ entry) ; - cleandir dir - (* next entry *) + cleandir dir (* next entry *) | None -> Unix.closedir dir in @@ -152,7 +151,7 @@ let command_error_handling ~always_die ~prog ~args = function () | Error _ as status -> let log = - if not always_die && Config.keep_going then + if (not always_die) && Config.keep_going then (* Log error and proceed past the failure when keep going mode is on *) L.external_error else L.die InternalError @@ -160,7 +159,7 @@ let command_error_handling ~always_die ~prog ~args = function log "%a:@\n %s" Pp.cli_args (prog :: args) (Unix.Exit_or_signal.to_string_hum status) -let run_command ~prog ~args ?(cleanup= command_error_handling ~always_die:false ~prog ~args) () = +let run_command ~prog ~args ?(cleanup = command_error_handling ~always_die:false ~prog ~args) () = Unix.waitpid (Unix.fork_exec ~prog ~argv:(prog :: args) ()) |> fun status -> cleanup status ; @@ -246,15 +245,13 @@ let capture ~changed_files = function [] ) @ (if not Config.debug_mode then [] else ["--debug"]) @ (if Config.filtering then [] else ["--no-filtering"]) - @ (if not Config.flavors || not in_buck_mode then [] else ["--use-flavors"]) - @ "-j" - :: string_of_int Config.jobs + @ (if (not Config.flavors) || not in_buck_mode then [] else ["--use-flavors"]) + @ "-j" :: string_of_int Config.jobs :: (match Config.load_average with None -> [] | Some l -> ["-l"; string_of_float l]) @ (if not Config.pmd_xml then [] else ["--pmd-xml"]) @ ["--project-root"; Config.project_root] @ (if not Config.quiet then [] else ["--quiet"]) - @ "--out" - :: Config.results_dir + @ "--out" :: Config.results_dir :: ( match Config.xcode_developer_dir with | None -> @@ -264,37 +261,37 @@ let capture ~changed_files = function @ "--" :: ( if in_buck_mode && Config.flavors then ( - (* let children infer processes know that they are inside Buck *) - let infer_args_with_buck = - String.concat - ~sep:(String.of_char CLOpt.env_var_sep) - (Option.to_list (Sys.getenv CLOpt.args_env_var) @ ["--buck"]) - in - Unix.putenv ~key:CLOpt.args_env_var ~data:infer_args_with_buck ; - let prog, buck_args = (List.hd_exn build_cmd, List.tl_exn build_cmd) in - let {Buck.command; rev_not_targets; targets} = - Buck.add_flavors_to_buck_arguments ~filter_kind:`Auto ~dep_depth:None - ~extra_flavors:[] buck_args - in - let all_args = List.rev_append rev_not_targets targets in - let updated_buck_cmd = - [prog; command] - @ List.rev_append Config.buck_build_args_no_inline - (Buck.store_args_in_file all_args) - in - Logging.(debug Capture Quiet) - "Processed buck command '%a'@\n" (Pp.seq F.pp_print_string) updated_buck_cmd ; - updated_buck_cmd ) + (* let children infer processes know that they are inside Buck *) + let infer_args_with_buck = + String.concat + ~sep:(String.of_char CLOpt.env_var_sep) + (Option.to_list (Sys.getenv CLOpt.args_env_var) @ ["--buck"]) + in + Unix.putenv ~key:CLOpt.args_env_var ~data:infer_args_with_buck ; + let prog, buck_args = (List.hd_exn build_cmd, List.tl_exn build_cmd) in + let {Buck.command; rev_not_targets; targets} = + Buck.add_flavors_to_buck_arguments ~filter_kind:`Auto ~dep_depth:None + ~extra_flavors:[] buck_args + in + let all_args = List.rev_append rev_not_targets targets in + let updated_buck_cmd = + [prog; command] + @ List.rev_append Config.buck_build_args_no_inline + (Buck.store_args_in_file all_args) + in + Logging.(debug Capture Quiet) + "Processed buck command '%a'@\n" (Pp.seq F.pp_print_string) updated_buck_cmd ; + updated_buck_cmd ) else build_cmd ) ) in run_command ~prog:infer_py ~args ~cleanup:(function - | Error (`Exit_non_zero exit_code) - when Int.equal exit_code Config.infer_py_argparse_error_exit_code -> - (* swallow infer.py argument parsing error *) - Config.print_usage_exit () - | status -> - command_error_handling ~always_die:true ~prog:infer_py ~args status) + | Error (`Exit_non_zero exit_code) + when Int.equal exit_code Config.infer_py_argparse_error_exit_code -> + (* swallow infer.py argument parsing error *) + Config.print_usage_exit () + | status -> + command_error_handling ~always_die:true ~prog:infer_py ~args status) () ; PerfStats.get_reporter PerfStats.TotalFrontend () | XcodeXcpretty (prog, args) -> @@ -312,7 +309,7 @@ let execute_analyze ~changed_files = PerfStats.get_reporter PerfStats.TotalBackend () -let report ?(suppress_console= false) () = +let report ?(suppress_console = false) () = let report_json = Config.(results_dir ^/ report_json) in InferPrint.main ~report_json:(Some report_json) ; (* Post-process the report according to the user config. By default, calls report.py to create a @@ -467,7 +464,7 @@ let mode_of_build_command build_cmd = assert_supported_mode `Clang "clang compilation database" ; ClangCompilationDB !Config.clang_compilation_dbs ) else Analyze - | prog :: args -> + | prog :: args -> ( let build_system = match Config.force_integration with | Some build_system when CLOpt.is_originator -> @@ -493,7 +490,7 @@ let mode_of_build_command build_cmd = Python args | BXcode when Config.xcpretty -> XcodeXcpretty (prog, args) - | BBuck when not Config.flavors && Config.reactive_mode -> + | BBuck when (not Config.flavors) && Config.reactive_mode -> L.die UserError "The Buck Java integration does not support --reactive@." | BBuck when Option.is_none Config.buck_compilation_database && Config.flavors && Config.linters -> @@ -502,7 +499,7 @@ let mode_of_build_command build_cmd = set --no-linters to disable them and this warning.@." ; PythonCapture (BBuck, build_cmd) | (BAnt | BBuck | BGradle | BNdk | BXcode) as build_system -> - PythonCapture (build_system, build_cmd) + PythonCapture (build_system, build_cmd) ) let mode_from_command_line = @@ -557,10 +554,10 @@ let read_config_changed_files () = match Config.changed_files_index with | None -> None - | Some index -> + | Some index -> ( match Utils.read_file index with | Ok lines -> Some (SourceFile.changed_sources_from_changed_files lines) | Error error -> L.external_error "Error reading the changed files index '%s': %s@." index error ; - None + None ) diff --git a/infer/src/integration/Maven.ml b/infer/src/integration/Maven.ml index 50842432f..eef28e1c3 100644 --- a/infer/src/integration/Maven.ml +++ b/infer/src/integration/Maven.ml @@ -59,8 +59,7 @@ let add_infer_profile_to_xml dir maven_xml infer_xml = let tag_name = snd (fst tag) in if String.equal tag_name "profiles" then found_profiles_tag := true ; process xml_in xml_out (tag_name :: tag_stack) - | `El_end - -> ( + | `El_end -> ( ( match tag_stack with | "profiles" :: _ when not !found_infer_profile -> (* found the tag but no infer profile found, add one *) @@ -167,12 +166,13 @@ let capture ~prog ~args = "Running maven capture:@\n%s %s@." prog (String.concat ~sep:" " (List.map ~f:(Printf.sprintf "'%s'") capture_args)) ; (* let children infer processes know that they are spawned by Maven *) - Unix.fork_exec ~prog ~argv:(prog :: capture_args) ~env:Config.env_inside_maven () |> Unix.waitpid + Unix.fork_exec ~prog ~argv:(prog :: capture_args) ~env:Config.env_inside_maven () + |> Unix.waitpid |> function - | Ok () -> - () - | Error _ as status -> - L.(die UserError) - "*** Maven command failed:@\n*** %s@\n*** %s@\n" - (String.concat ~sep:" " (prog :: capture_args)) - (Unix.Exit_or_signal.to_string_hum status) + | Ok () -> + () + | Error _ as status -> + L.(die UserError) + "*** Maven command failed:@\n*** %s@\n*** %s@\n" + (String.concat ~sep:" " (prog :: capture_args)) + (Unix.Exit_or_signal.to_string_hum status) diff --git a/infer/src/integration/testDeterminator.ml b/infer/src/integration/testDeterminator.ml index 26bea91f5..ca4215fe5 100644 --- a/infer/src/integration/testDeterminator.ml +++ b/infer/src/integration/testDeterminator.ml @@ -110,8 +110,7 @@ module DiffLines = struct (* Read the file containing info on changed lines and populate the map *) let init_changed_lines_map changed_lines_file' = match changed_lines_file' with - | Some changed_lines_file - -> ( + | Some changed_lines_file -> ( L.(debug TestDeterminator Medium) "Initializing changed lines map from file '%s'..." changed_lines_file ; match Utils.read_file changed_lines_file with @@ -183,8 +182,8 @@ let affected_methods method_range_map file_changed_lines changed_lines = let compute_affected_methods_java changed_lines_map method_range_map = let affected_methods = - String.Map.fold changed_lines_map ~init:JPS.ProfilerSample.empty ~f: - (fun ~key:file_changed_lines ~data acc -> + String.Map.fold changed_lines_map ~init:JPS.ProfilerSample.empty + ~f:(fun ~key:file_changed_lines ~data acc -> let am = affected_methods method_range_map file_changed_lines data in JPS.ProfilerSample.union am acc ) in diff --git a/infer/src/istd/ARList.mli b/infer/src/istd/ARList.mli index 02252ab8a..b1ba45b22 100644 --- a/infer/src/istd/ARList.mli +++ b/infer/src/istd/ARList.mli @@ -11,7 +11,8 @@ open! IStd Lists with O(1) append and rev. *) -include sig +include + sig (* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *) type +'a t diff --git a/infer/src/istd/Escape.ml b/infer/src/istd/Escape.ml index ca64b1602..07b001d5f 100644 --- a/infer/src/istd/Escape.ml +++ b/infer/src/istd/Escape.ml @@ -141,14 +141,14 @@ let escape_shell = let easy_single_quotable = Str.regexp "^[^']+$" in let easy_double_quotable = Str.regexp "^[^$`\\!]+$" in function - | "" -> - "''" - | arg -> - if Str.string_match no_quote_needed arg 0 then arg - else if Str.string_match easy_single_quotable arg 0 then F.sprintf "'%s'" arg - else if Str.string_match easy_double_quotable arg 0 then - escape_double_quotes arg |> F.sprintf "\"%s\"" - else - (* ends on-going single quote, output single quote inside double quotes, then open a new + | "" -> + "''" + | arg -> + if Str.string_match no_quote_needed arg 0 then arg + else if Str.string_match easy_single_quotable arg 0 then F.sprintf "'%s'" arg + else if Str.string_match easy_double_quotable arg 0 then + escape_double_quotes arg |> F.sprintf "\"%s\"" + else + (* ends on-going single quote, output single quote inside double quotes, then open a new single quote *) - escape_map (function '\'' -> Some "'\"'\"'" | _ -> None) arg |> F.sprintf "'%s'" + escape_map (function '\'' -> Some "'\"'\"'" | _ -> None) arg |> F.sprintf "'%s'" diff --git a/infer/src/istd/IContainer.mli b/infer/src/istd/IContainer.mli index 3d0b9594a..0b56de70d 100644 --- a/infer/src/istd/IContainer.mli +++ b/infer/src/istd/IContainer.mli @@ -34,8 +34,11 @@ val iter_consecutive : fold:('t, 'a, 'a option) Container.fold -> 't -> f:('a -> 'a -> unit) -> unit val pp_collection : - fold:('t, 'a, 'a option) Container.fold -> pp_item:(F.formatter -> 'a -> unit) -> F.formatter - -> 't -> unit + fold:('t, 'a, 'a option) Container.fold + -> pp_item:(F.formatter -> 'a -> unit) + -> F.formatter + -> 't + -> unit val filter : fold:('t, 'a, 'accum) Container.fold -> filter:('a -> bool) -> ('t, 'a, 'accum) Container.fold diff --git a/infer/src/istd/IList.ml b/infer/src/istd/IList.ml index 7eb3145ff..48fc0b502 100644 --- a/infer/src/istd/IList.ml +++ b/infer/src/istd/IList.ml @@ -117,7 +117,7 @@ let rec fold_last l ~init ~f ~f_last = fold_last tl ~init:(f init hd) ~f ~f_last -let append_no_duplicates (type a) ~(cmp: a -> a -> int) = +let append_no_duplicates (type a) ~(cmp : a -> a -> int) = (* roughly based on [Core.List.stable_dedup_staged] but also takes care of the append and takes into account the invariant that [list1] and [list2] do not contain duplicates individually *) let module Set = Set.Make (struct @@ -130,7 +130,7 @@ let append_no_duplicates (type a) ~(cmp: a -> a -> int) = let sexp_of_t _ = assert false end) in - Staged.stage (fun (list1: a list) (list2: a list) -> + Staged.stage (fun (list1 : a list) (list2 : a list) -> let set1 = Set.of_list list1 in let res_rev = List.fold_left list2 ~init:(List.rev list1) ~f:(fun res_rev x -> diff --git a/infer/src/istd/ImperativeUnionFind.ml b/infer/src/istd/ImperativeUnionFind.ml index ef6405f53..d9771910c 100644 --- a/infer/src/istd/ImperativeUnionFind.ml +++ b/infer/src/istd/ImperativeUnionFind.ml @@ -43,7 +43,7 @@ module Make (Set : Set) = struct end = struct type t = Set.elt [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let of_elt e = e @@ -55,9 +55,9 @@ module Make (Set : Set) = struct let create () = H.create 1 - let is_a_repr (t: t) e = not (H.mem t e) + let is_a_repr (t : t) e = not (H.mem t e) - let rec find (t: t) e : Repr.t = + let rec find (t : t) e : Repr.t = match H.find_opt t e with | None -> Repr.of_elt e @@ -67,7 +67,7 @@ module Make (Set : Set) = struct r' - let merge (t: t) ~(from: Repr.t) ~(to_: Repr.t) = H.replace t (from :> Set.elt) to_ + let merge (t : t) ~(from : Repr.t) ~(to_ : Repr.t) = H.replace t (from :> Set.elt) to_ end module Sets = struct @@ -77,7 +77,7 @@ module Make (Set : Set) = struct let find t r = H.find_opt t r - let find_create t (r: Repr.t) = + let find_create t (r : Repr.t) = match H.find_opt t r with | Some set -> set @@ -132,7 +132,7 @@ module Make (Set : Set) = struct Some (e2, e1) ) - let is_still_a_repr t ((repr: Repr.t), _) = Reprs.is_a_repr t.reprs (repr :> Set.elt) + let is_still_a_repr t ((repr : Repr.t), _) = Reprs.is_a_repr t.reprs (repr :> Set.elt) let after_fold t = let new_nb_iterators = t.nb_iterators - 1 in diff --git a/infer/src/istd/PartialOrder.ml b/infer/src/istd/PartialOrder.ml index 3b8274c42..c6590c9e5 100644 --- a/infer/src/istd/PartialOrder.ml +++ b/infer/src/istd/PartialOrder.ml @@ -65,5 +65,5 @@ let join_lazy t1 ~xcompare ~lhs ~rhs = match t1 with `NotComparable -> `NotComparable | _ -> join t1 (xcompare ~lhs ~rhs) -let container ~(fold: ('t, 'a * 'a, t) Container.fold) cont ~xcompare_elt = +let container ~(fold : ('t, 'a * 'a, t) Container.fold) cont ~xcompare_elt = fold cont ~init:`Equal ~f:(fun acc (lhs, rhs) -> join_lazy acc ~xcompare:xcompare_elt ~lhs ~rhs) diff --git a/infer/src/istd/PolyVariantEqual.ml b/infer/src/istd/PolyVariantEqual.ml index 493de8eda..eca64c573 100644 --- a/infer/src/istd/PolyVariantEqual.ml +++ b/infer/src/istd/PolyVariantEqual.ml @@ -7,4 +7,4 @@ open! Core -let ( = ) (v1: [> ]) (v2: [> ]) = Polymorphic_compare.( = ) v1 v2 +let ( = ) (v1 : [> ]) (v2 : [> ]) = Polymorphic_compare.( = ) v1 v2 diff --git a/infer/src/istd/Pp.ml b/infer/src/istd/Pp.ml index bf1c198ba..de8365ebc 100644 --- a/infer/src/istd/Pp.ml +++ b/infer/src/istd/Pp.ml @@ -16,12 +16,12 @@ type simple_kind = SIM_DEFAULT | SIM_WITH_TYP (** Kind of printing *) type print_kind = TEXT | HTML [@@deriving compare] -let equal_print_kind = [%compare.equal : print_kind] +let equal_print_kind = [%compare.equal: print_kind] (** Colors supported in printing *) type color = Black | Blue | Green | Orange | Red [@@deriving compare] -let equal_color = [%compare.equal : color] +let equal_color = [%compare.equal: color] (** map subexpressions (as Obj.t element compared by physical equality) to colors *) type colormap = Obj.t -> color @@ -37,13 +37,13 @@ type env = ; obj_sub: (Obj.t -> Obj.t) option (** generic object substitution *) } (** Create a colormap of a given color *) -let colormap_from_color color (_: Obj.t) = color +let colormap_from_color color (_ : Obj.t) = color (** standard colormap: black *) -let colormap_black (_: Obj.t) = Black +let colormap_black (_ : Obj.t) = Black (** red colormap *) -let colormap_red (_: Obj.t) = Red +let colormap_red (_ : Obj.t) = Red (** Default text print environment *) let text = @@ -66,14 +66,14 @@ let html color = (** Extend the normal colormap for the given object with the given color *) -let extend_colormap pe (x: Obj.t) (c: color) = - let colormap (y: Obj.t) = if phys_equal x y then c else pe.cmap_norm y in +let extend_colormap pe (x : Obj.t) (c : color) = + let colormap (y : Obj.t) = if phys_equal x y then c else pe.cmap_norm y in {pe with cmap_norm= colormap} (** Set the object substitution, which is supposed to preserve the type. Currently only used for a map from (identifier) expressions to the program var containing them *) -let set_obj_sub pe (sub: 'a -> 'a) = +let set_obj_sub pe (sub : 'a -> 'a) = let new_obj_sub x = let x' = Obj.repr (sub (Obj.obj x)) in match pe.obj_sub with None -> x' | Some sub' -> sub' x' @@ -98,7 +98,7 @@ let color_string = function "color_red" -let seq ?(print_env= text) ?sep:(sep_text = " ") ?(sep_html= sep_text) pp = +let seq ?(print_env = text) ?sep:(sep_text = " ") ?(sep_html = sep_text) pp = let rec aux f = function | [] -> () diff --git a/infer/src/istd/Pp.mli b/infer/src/istd/Pp.mli index 1a91607dd..76c961078 100644 --- a/infer/src/istd/Pp.mli +++ b/infer/src/istd/Pp.mli @@ -69,8 +69,13 @@ val cli_args : F.formatter -> string list -> unit (** pretty print command line arguments, expanding argument files to print their contents *) val seq : - ?print_env:env -> ?sep:string -> ?sep_html:string -> (F.formatter -> 'a -> unit) -> F.formatter - -> 'a list -> unit + ?print_env:env + -> ?sep:string + -> ?sep_html:string + -> (F.formatter -> 'a -> unit) + -> F.formatter + -> 'a list + -> unit (** Pretty print a sequence with [sep] followed by a space between each element. By default, [print_env] is [text], [sep] is "", and [sep_html] set to [sep]. *) @@ -90,9 +95,15 @@ val elapsed_time : F.formatter -> unit -> unit (** Print the time in seconds elapsed since the beginning of the execution of the current command. *) val pair : - fst:(F.formatter -> 'a -> unit) -> snd:(F.formatter -> 'b -> unit) -> F.formatter -> 'a * 'b + fst:(F.formatter -> 'a -> unit) + -> snd:(F.formatter -> 'b -> unit) + -> F.formatter + -> 'a * 'b -> unit val hashtbl : - key:(F.formatter -> 'a -> unit) -> value:(F.formatter -> 'b -> unit) -> F.formatter - -> ('a, 'b) Caml.Hashtbl.t -> unit + key:(F.formatter -> 'a -> unit) + -> value:(F.formatter -> 'b -> unit) + -> F.formatter + -> ('a, 'b) Caml.Hashtbl.t + -> unit diff --git a/infer/src/istd/dune.in b/infer/src/istd/dune.in index 8780b3a59..5737ab624 100644 --- a/infer/src/istd/dune.in +++ b/infer/src/istd/dune.in @@ -1,7 +1,9 @@ (* -*- tuareg -*- *) (* NOTE: prepend dune.common to this file! *) -;; Format.sprintf - {| + +;; +Format.sprintf + {| (library (name InferStdlib) (public_name InferStdlib) @@ -16,7 +18,7 @@ (mld_files index) ) |} - (String.concat " " common_cflags) - (String.concat " " common_optflags) - (String.concat " " common_libraries) - |> Jbuild_plugin.V1.send + (String.concat " " common_cflags) + (String.concat " " common_optflags) + (String.concat " " common_libraries) +|> Jbuild_plugin.V1.send diff --git a/infer/src/java/JavaProfilerSamples.ml b/infer/src/java/JavaProfilerSamples.ml index e03304164..0ee9b8eb7 100644 --- a/infer/src/java/JavaProfilerSamples.ml +++ b/infer/src/java/JavaProfilerSamples.ml @@ -27,7 +27,7 @@ module JNI = struct | Method of (t list * t) [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let void_method_with_no_arguments = "()V" @@ -105,7 +105,7 @@ module JNI = struct match input with | [] -> List.rev acc - | c :: cs -> + | c :: cs -> ( match c with | '(' -> tokenize_aux cs (NonTerminal SymMethodOpen :: acc) @@ -147,7 +147,7 @@ module JNI = struct in tokenize_aux new_input (Terminal (FullyQualifiedClass fully_qualified_class) :: acc) | c -> - L.(die UserError "Unrecognized char '%c' while reading the input sequence" c) + L.(die UserError "Unrecognized char '%c' while reading the input sequence" c) ) in let input_chars = String.to_list input in tokenize_aux input_chars [] @@ -172,7 +172,7 @@ module JNI = struct if collected_symbols then L.(die UserError "No symbols were reduced during a scan, failed parsing input") else (* no more symbols in input, terminate *) List.rev jnis - | Terminal t :: tl when not collected_symbols && not in_method -> + | Terminal t :: tl when (not collected_symbols) && not in_method -> reduce_aux ~symbols:tl ~unchanged_symbols ~in_method ~jnis_in_method ~jnis:(t :: jnis) | NonTerminal (SymMethod method_jnis) :: Terminal t :: tl -> let transformed_symbols = Terminal (Method (method_jnis, t)) :: tl in @@ -182,7 +182,8 @@ module JNI = struct reduce_aux ~symbols:new_symbols ~unchanged_symbols:[] ~in_method:false ~jnis_in_method:[] ~jnis | (NonTerminal SymMethodOpen as nt) :: tl -> - reduce_aux ~symbols:tl ~unchanged_symbols:(nt :: all_collected_symbols_so_far ()) + reduce_aux ~symbols:tl + ~unchanged_symbols:(nt :: all_collected_symbols_so_far ()) ~in_method:true ~jnis_in_method:[] ~jnis | NonTerminal SymArray :: Terminal t :: tl -> let transformed_symbols = Terminal (Array t) :: tl in @@ -192,7 +193,8 @@ module JNI = struct reduce_aux ~symbols:new_symbols ~unchanged_symbols:[] ~in_method:false ~jnis_in_method:[] ~jnis | (NonTerminal SymArray as nt) :: tl -> - reduce_aux ~symbols:tl ~unchanged_symbols:(nt :: all_collected_symbols_so_far ()) + reduce_aux ~symbols:tl + ~unchanged_symbols:(nt :: all_collected_symbols_so_far ()) ~in_method:false ~jnis_in_method:[] ~jnis | NonTerminal SymMethodClose :: tl -> let new_method_non_terminal = NonTerminal (SymMethod (List.rev jnis_in_method)) in @@ -282,7 +284,7 @@ let create_procname ~classname ~methodname ~signature = type labeled_profiler_sample = string * ProfilerSample.t [@@deriving compare] -let equal_labeled_profiler_sample = [%compare.equal : labeled_profiler_sample] +let equal_labeled_profiler_sample = [%compare.equal: labeled_profiler_sample] let from_java_profiler_samples j ~use_signature = let process_methods methods = diff --git a/infer/src/java/jClasspath.ml b/infer/src/java/jClasspath.ml index 4d1016080..f8ca2bf47 100644 --- a/infer/src/java/jClasspath.ml +++ b/infer/src/java/jClasspath.ml @@ -198,7 +198,8 @@ let search_classes path = else if Filename.check_suffix p "jar" then (add_root_path p paths, collect_classnames classes p) else accu ) - (String.Set.empty, JBasics.ClassSet.empty) path + (String.Set.empty, JBasics.ClassSet.empty) + path let search_sources () = @@ -221,7 +222,8 @@ let load_from_arguments classes_out_path = List.fold ~f:append_path ~init:classpath (List.rev path_list) in let classpath = - combine (split Config.classpath) "" |> combine (String.Set.elements roots) + combine (split Config.classpath) "" + |> combine (String.Set.elements roots) |> combine (split Config.bootclasspath) in (classpath, search_sources (), classes) @@ -266,7 +268,7 @@ let iter_missing_callees program ~f = let cleanup program = Javalib.close_class_path program.classpath.channel let lookup_node cn program = - try Some (JBasics.ClassMap.find cn (get_classmap program)) with Caml.Not_found -> + try Some (JBasics.ClassMap.find cn (get_classmap program)) with Caml.Not_found -> ( try let jclass = javalib_get_class (get_classpath_channel program) cn in add_class cn jclass program ; Some jclass @@ -276,7 +278,7 @@ let lookup_node cn program = None | (JBasics.Class_structure_error _ | Invalid_argument _) as exn -> L.internal_error "ERROR: %s@." (Exn.to_string exn) ; - None + None ) let collect_classes start_classmap jar_filename = diff --git a/infer/src/java/jContext.ml b/infer/src/java/jContext.ml index 14724a0c7..1b844c36a 100644 --- a/infer/src/java/jContext.ml +++ b/infer/src/java/jContext.ml @@ -104,5 +104,5 @@ let exn_node_table = Typ.Procname.Hash.create 100 let reset_exn_node_table () = Typ.Procname.Hash.clear exn_node_table -let add_exn_node procname (exn_node: Procdesc.Node.t) = +let add_exn_node procname (exn_node : Procdesc.Node.t) = Typ.Procname.Hash.add exn_node_table procname exn_node diff --git a/infer/src/java/jFrontend.ml b/infer/src/java/jFrontend.ml index 00943f94b..0f1d8f5cf 100644 --- a/infer/src/java/jFrontend.ml +++ b/infer/src/java/jFrontend.ml @@ -12,7 +12,7 @@ open Javalib_pack open Sawja_pack module L = Logging -let add_edges (context: JContext.t) start_node exn_node exit_nodes method_body_nodes impl +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 @@ -177,12 +177,12 @@ let should_capture classes package_opt source_basename node = match Javalib.get_sourcefile node with | None -> false - | Some found_basename -> + | Some found_basename -> ( match package_opt with | None -> String.equal found_basename source_basename | Some pkg -> - match_package pkg classname && String.equal found_basename source_basename + match_package pkg classname && String.equal found_basename source_basename ) else false diff --git a/infer/src/java/jFrontend.mli b/infer/src/java/jFrontend.mli index 40d808278..0c9f1f9e7 100644 --- a/infer/src/java/jFrontend.mli +++ b/infer/src/java/jFrontend.mli @@ -19,11 +19,21 @@ val is_classname_cached : JBasics.class_name -> bool (** [is_classname_cached cn] *) val compute_source_icfg : - Printer.LineReader.t -> JBasics.ClassSet.t -> JClasspath.program -> Tenv.t -> string - -> string option -> SourceFile.t -> Cfg.t + Printer.LineReader.t + -> JBasics.ClassSet.t + -> JClasspath.program + -> Tenv.t + -> string + -> string option + -> SourceFile.t + -> Cfg.t (** [compute_cfg linereader classes program tenv source_basename source_file] create the control flow graph for the file [source_file] by translating all the classes in [program] originating from [source_file] *) val compute_class_icfg : - SourceFile.t -> Printer.LineReader.t -> JClasspath.program -> Tenv.t - -> JCode.jcode Javalib.interface_or_class -> Cfg.t + SourceFile.t + -> Printer.LineReader.t + -> JClasspath.program + -> Tenv.t + -> JCode.jcode Javalib.interface_or_class + -> Cfg.t (** Compute the CFG for a class *) diff --git a/infer/src/java/jTrans.ml b/infer/src/java/jTrans.ml index 6a1bd35a0..48ba60807 100644 --- a/infer/src/java/jTrans.ml +++ b/infer/src/java/jTrans.ml @@ -33,11 +33,11 @@ let fix_method_definition_line linereader proc_name loc = match Printer.LineReader.from_file_linenum_original linereader loc.Location.file linenum with | None -> raise Caml.Not_found - | Some line -> + | Some line -> ( try ignore (Str.search_forward regex line 0) ; true - with Caml.Not_found -> false + with Caml.Not_found -> false ) in let line = ref loc.Location.line in try @@ -160,7 +160,7 @@ let translate_locals program tenv formals bytecode jbir_code = snd with_jbir_vars -let get_constant (c: JBir.const) = +let get_constant (c : JBir.const) = match c with | `Int i -> Const.Cint (IntLit.of_int32 i) @@ -256,10 +256,10 @@ let get_bytecode cm = let c_code = Array.map ~f:(function - | JCode.OpInvoke (`Dynamic _, ms) -> - JCode.OpInvoke (`Static JBasics.java_lang_object, ms) - | opcode -> - opcode) + | JCode.OpInvoke (`Dynamic _, ms) -> + JCode.OpInvoke (`Static JBasics.java_lang_object, ms) + | opcode -> + opcode) bytecode.JCode.c_code in {bytecode with JCode.c_code} @@ -462,7 +462,7 @@ let create_sil_deref exp typ loc = (** translate an expression used as an r-value *) -let rec expression (context: JContext.t) pc expr = +let rec expression (context : JContext.t) pc expr = let program = context.program in let loc = get_location context.source_file context.impl pc in let tenv = JContext.get_tenv context in @@ -479,16 +479,14 @@ let rec expression (context: JContext.t) pc expr = | JBir.Const c -> ( match c with (* We use the constant internally to mean a variable. *) - | `String s - when String.equal (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 trans_var pvar | _ -> ([], Exp.Const (get_constant c), type_of_expr) ) - | JBir.Unop (unop, ex) - -> ( + | JBir.Unop (unop, ex) -> ( let type_of_ex = JTransType.expr_type context ex in let instrs, sil_ex, _ = expression context pc ex in match unop with @@ -536,8 +534,7 @@ let rec expression (context: JContext.t) pc expr = in let res_ex = Exp.Var ret_id in (instrs @ [call], res_ex, type_of_expr) ) - | JBir.Binop (binop, ex1, ex2) - -> ( + | JBir.Binop (binop, ex1, ex2) -> ( let instrs1, sil_ex1, _ = expression context pc ex1 and instrs2, sil_ex2, _ = expression context pc ex2 in match binop with @@ -547,7 +544,7 @@ let rec expression (context: JContext.t) pc expr = let deref_array_instr = create_sil_deref sil_ex1 array_typ loc in let id = Ident.create_fresh Ident.knormal in let load_instr = Sil.Load (id, Exp.Lindex (sil_ex1, sil_ex2), type_of_expr, loc) in - let instrs = (instrs1 @ deref_array_instr :: instrs2) @ [load_instr] in + let instrs = (instrs1 @ (deref_array_instr :: instrs2)) @ [load_instr] in (instrs, Exp.Var id, type_of_expr) | other_binop -> let sil_binop = get_binop other_binop in @@ -581,28 +578,28 @@ let rec expression (context: JContext.t) pc expr = (instrs @ [lderef_instr], Exp.Var tmp_id, type_of_expr) -let method_invocation (context: JContext.t) loc pc var_opt cn ms sil_obj_opt expr_list invoke_code +let method_invocation (context : JContext.t) loc pc var_opt cn ms sil_obj_opt expr_list invoke_code method_kind = (* This function tries to recursively search for the classname of the class *) (* where the method is defined. It returns the classname given as argument*) (* when this classname cannot be found *) - let resolve_method (context: JContext.t) cn ms = + let resolve_method (context : JContext.t) cn ms = let rec loop fallback_cn cn = match JClasspath.lookup_node cn context.program with | None -> fallback_cn - | Some node -> + | Some node -> ( if Javalib.defines_method node ms then cn else match node with | Javalib.JInterface _ -> fallback_cn - | Javalib.JClass jclass -> + | Javalib.JClass jclass -> ( match jclass.Javalib.c_super_class with | None -> fallback_cn | Some super_cn -> - loop fallback_cn super_cn + loop fallback_cn super_cn ) ) in loop cn cn in @@ -705,8 +702,7 @@ let method_invocation (context: JContext.t) loc pc var_opt cn ms sil_obj_opt exp let instrs = match call_args with (* modeling a class bypasses the treatment of Closeable *) - | _ - when Config.models_mode || JClasspath.is_model callee_procname -> + | _ when Config.models_mode || JClasspath.is_model callee_procname -> call_instrs | ((_, {Typ.desc= Typ.Tptr ({desc= Tstruct typename}, _)}) as exp) :: _ (* add a file attribute when calling the constructor of a subtype of Closeable *) @@ -725,8 +721,7 @@ let method_invocation (context: JContext.t) loc pc var_opt cn ms sil_obj_opt exp (* Exceptions thrown in the constructor should prevent adding the resource attribute *) call_instrs @ [set_file_attr] (* remove file attribute when calling the close method of a subtype of Closeable *) - | [exp] - when is_close callee_procname -> + | [exp] when is_close callee_procname -> let set_mem_attr = let set_builtin = Exp.Const (Const.Cfun BuiltinDecl.__set_mem_attribute) in Sil.Call @@ -819,7 +814,7 @@ let assume_not_null loc sil_expr = , assume_call_flag ) -let instruction (context: JContext.t) pc instr : translation = +let instruction (context : JContext.t) pc instr : translation = let tenv = JContext.get_tenv context in let program = context.program in let proc_name = Procdesc.get_proc_name context.procdesc in @@ -969,7 +964,7 @@ let instruction (context: JContext.t) pc instr : translation = in let pvar = JContext.set_pvar context var class_type in let set_instr = Sil.Store (Exp.Lvar pvar, class_type, Exp.Var ret_id, loc) in - let instrs = new_instr :: call_instrs @ [set_instr] in + let instrs = (new_instr :: call_instrs) @ [set_instr] in let node_kind = create_node_kind constr_procname in let node = create_node node_kind instrs in Instr node @@ -1006,8 +1001,7 @@ let instruction (context: JContext.t) pc instr : translation = let node_kind = create_node_kind callee_procname in let call_node = create_node node_kind (instrs @ call_instrs) in Instr call_node - | JBir.InvokeVirtual (var_opt, obj, call_kind, ms, args) - -> ( + | JBir.InvokeVirtual (var_opt, obj, call_kind, ms, args) -> ( let instrs, sil_obj_expr, sil_obj_type = expression context pc obj in let create_call_node cn invoke_kind = let callee_procname, call_instrs = @@ -1045,8 +1039,9 @@ let instruction (context: JContext.t) pc instr : translation = | JBir.InvokeNonVirtual (var_opt, obj, cn, ms, args) -> let instrs, sil_obj_expr, sil_obj_type = expression context pc obj in let callee_procname, call_instrs = - method_invocation context loc pc var_opt cn ms (Some (sil_obj_expr, sil_obj_type)) args - I_Special Typ.Procname.Java.Non_Static + method_invocation context loc pc var_opt cn ms + (Some (sil_obj_expr, sil_obj_type)) + args I_Special Typ.Procname.Java.Non_Static in let node_kind = create_node_kind callee_procname in let call_node = create_node node_kind (instrs @ call_instrs) in @@ -1091,7 +1086,7 @@ let instruction (context: JContext.t) pc instr : translation = in let sil_exn = Exp.Exn (Exp.Var ret_id) in let set_instr = Sil.Store (Exp.Lvar ret_var, ret_type, sil_exn, loc) in - let npe_instrs = instrs @ [sil_prune_null] @ new_instr :: call_instrs @ [set_instr] in + let npe_instrs = instrs @ [sil_prune_null] @ (new_instr :: call_instrs) @ [set_instr] in create_node npe_kind npe_instrs in Prune (not_null_node, throw_npe_node) @@ -1144,12 +1139,13 @@ let instruction (context: JContext.t) pc instr : translation = let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in let _, call_instrs = method_invocation context loc pc None out_of_bound_cn constr_ms - (Some (Exp.Var ret_id, class_type)) [] I_Special Typ.Procname.Java.Static + (Some (Exp.Var ret_id, class_type)) + [] I_Special Typ.Procname.Java.Static in let sil_exn = Exp.Exn (Exp.Var ret_id) in let set_instr = Sil.Store (Exp.Lvar ret_var, ret_type, sil_exn, loc) in let out_of_bound_instrs = - instrs @ [sil_assume_out_of_bound] @ new_instr :: call_instrs @ [set_instr] + instrs @ [sil_assume_out_of_bound] @ (new_instr :: call_instrs) @ [set_instr] in create_node out_of_bound_node_kind out_of_bound_instrs in @@ -1189,12 +1185,13 @@ let instruction (context: JContext.t) pc instr : translation = let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in let _, call_instrs = method_invocation context loc pc None cce_cn constr_ms - (Some (Exp.Var ret_id, class_type)) [] I_Special Typ.Procname.Java.Static + (Some (Exp.Var ret_id, class_type)) + [] I_Special Typ.Procname.Java.Static in let sil_exn = Exp.Exn (Exp.Var ret_id) in let set_instr = Sil.Store (Exp.Lvar ret_var, ret_type, sil_exn, loc) in let cce_instrs = - instrs @ [call; asssume_not_instance_of] @ new_instr :: call_instrs @ [set_instr] + instrs @ [call; asssume_not_instance_of] @ (new_instr :: call_instrs) @ [set_instr] in create_node throw_cast_exception_kind cce_instrs in diff --git a/infer/src/java/jTrans.mli b/infer/src/java/jTrans.mli index 4ec8478ce..26d9d938e 100644 --- a/infer/src/java/jTrans.mli +++ b/infer/src/java/jTrans.mli @@ -20,26 +20,47 @@ type translation = val is_java_native : JCode.jcode Javalib.concrete_method -> bool val create_callee_attributes : - Tenv.t -> JClasspath.program -> JBasics.class_name -> JBasics.method_signature -> Typ.Procname.t + Tenv.t + -> JClasspath.program + -> JBasics.class_name + -> JBasics.method_signature + -> Typ.Procname.t -> ProcAttributes.t option val create_am_procdesc : - SourceFile.t -> JClasspath.program -> JContext.icfg -> Javalib.abstract_method -> Typ.Procname.t + SourceFile.t + -> JClasspath.program + -> JContext.icfg + -> Javalib.abstract_method + -> Typ.Procname.t -> Procdesc.t (** Create the procedure description for an abstract method *) val create_native_procdesc : - SourceFile.t -> JClasspath.program -> JContext.icfg -> JCode.jcode Javalib.concrete_method - -> Typ.Procname.t -> Procdesc.t + SourceFile.t + -> JClasspath.program + -> JContext.icfg + -> JCode.jcode Javalib.concrete_method + -> Typ.Procname.t + -> Procdesc.t (** Create the procedure description for a concrete method *) val create_empty_procdesc : - SourceFile.t -> JClasspath.program -> Printer.LineReader.t -> JContext.icfg - -> JCode.jcode Javalib.concrete_method -> Typ.Procname.t -> Procdesc.t + SourceFile.t + -> JClasspath.program + -> Printer.LineReader.t + -> JContext.icfg + -> JCode.jcode Javalib.concrete_method + -> Typ.Procname.t + -> Procdesc.t val create_cm_procdesc : - SourceFile.t -> JClasspath.program -> Printer.LineReader.t -> JContext.icfg - -> JCode.jcode Javalib.concrete_method -> Typ.Procname.t + SourceFile.t + -> JClasspath.program + -> Printer.LineReader.t + -> JContext.icfg + -> JCode.jcode Javalib.concrete_method + -> Typ.Procname.t -> (Procdesc.t * Procdesc.Node.t * Procdesc.Node.t * Procdesc.Node.t * JBir.t) option (** [create_procdesc source_file program linereader icfg cm proc_name] creates a procedure description for the concrete method cm and adds it to cfg *) diff --git a/infer/src/java/jTransExn.ml b/infer/src/java/jTransExn.ml index ed64bd702..f4cf01643 100644 --- a/infer/src/java/jTransExn.ml +++ b/infer/src/java/jTransExn.ml @@ -22,7 +22,7 @@ let create_handler_table impl = handler_tb -let translate_exceptions (context: JContext.t) exit_nodes get_body_nodes handler_table = +let translate_exceptions (context : JContext.t) exit_nodes get_body_nodes handler_table = let catch_block_table = Hashtbl.create 1 in let exn_message = "exception handler" in let procdesc = context.procdesc in @@ -149,7 +149,7 @@ let create_exception_handlers context exit_nodes get_body_nodes impl = match JBir.exc_tbl impl with | [] -> fun _ -> exit_nodes - | _ -> + | _ -> ( let handler_table = create_handler_table impl in let catch_block_table = translate_exceptions context exit_nodes get_body_nodes handler_table @@ -158,4 +158,4 @@ let create_exception_handlers context exit_nodes get_body_nodes impl = try let handler_list = Hashtbl.find handler_table pc in Hashtbl.find catch_block_table handler_list - with Caml.Not_found -> exit_nodes + with Caml.Not_found -> exit_nodes ) diff --git a/infer/src/java/jTransExn.mli b/infer/src/java/jTransExn.mli index ac08b2b97..7d68c8f89 100644 --- a/infer/src/java/jTransExn.mli +++ b/infer/src/java/jTransExn.mli @@ -10,5 +10,9 @@ open! IStd open Sawja_pack val create_exception_handlers : - JContext.t -> Procdesc.Node.t list -> (int -> Procdesc.Node.t list) -> JBir.t -> int + JContext.t + -> Procdesc.Node.t list + -> (int -> Procdesc.Node.t list) + -> JBir.t + -> int -> Procdesc.Node.t list diff --git a/infer/src/java/jTransType.ml b/infer/src/java/jTransType.ml index 3fafaa74a..7156b85be 100644 --- a/infer/src/java/jTransType.ml +++ b/infer/src/java/jTransType.ml @@ -75,13 +75,13 @@ let rec get_named_type vt : Typ.t = match vt with | JBasics.TBasic bt -> basic_type bt - | JBasics.TObject ot -> + | JBasics.TObject ot -> ( match ot with | JBasics.TArray vt -> let content_type = get_named_type vt in Typ.mk (Tptr (Typ.mk_array content_type, Typ.Pk_pointer)) | JBasics.TClass cn -> - Typ.mk (Tptr (Typ.mk (Tstruct (typename_of_classname cn)), Typ.Pk_pointer)) + Typ.mk (Tptr (Typ.mk (Tstruct (typename_of_classname cn)), Typ.Pk_pointer)) ) let rec create_array_type typ dim = @@ -170,12 +170,12 @@ let rec string_of_type vt = match vt with | JBasics.TBasic bt -> string_of_basic_type bt - | JBasics.TObject ot -> + | JBasics.TObject ot -> ( match ot with | JBasics.TArray vt -> string_of_type vt ^ "[]" | JBasics.TClass cn -> - JBasics.cn_name cn + JBasics.cn_name cn ) let package_to_string = function [] -> None | p -> Some (String.concat ~sep:"." p) @@ -190,12 +190,12 @@ let vt_to_java_type vt = match vt with | JBasics.TBasic bt -> Typ.Name.Java.Split.make (string_of_basic_type bt) - | JBasics.TObject ot -> + | JBasics.TObject ot -> ( match ot with | JBasics.TArray vt -> Typ.Name.Java.Split.make (string_of_type vt ^ "[]") | JBasics.TClass cn -> - cn_to_java_type cn + cn_to_java_type cn ) let method_signature_names ms = @@ -356,7 +356,7 @@ and get_class_struct_typ = struct_typ | None when JBasics.ClassSet.mem cn !seen -> Tenv.mk_struct tenv name - | None -> + | None -> ( seen := JBasics.ClassSet.add cn !seen ; match JClasspath.lookup_node cn program with | None -> @@ -400,7 +400,7 @@ and get_class_struct_typ = (fun m procnames -> translate_method_name program tenv m :: procnames) node [] in - Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots name + Tenv.mk_struct tenv ~fields ~statics ~methods ~supers ~annots name ) let get_class_type_no_pointer program tenv cn = @@ -451,7 +451,7 @@ let param_type program tenv cn name vt = else value_type program tenv vt -let get_var_type_from_sig (context: JContext.t) var = +let get_var_type_from_sig (context : JContext.t) var = let program = context.program in let tenv = JContext.get_tenv context in List.find_map @@ -472,7 +472,7 @@ let extract_array_type typ = (** translate the type of an expression, looking in the method signature for formal parameters this is because variables in expressions do not have accurate types *) -let rec expr_type (context: JContext.t) expr = +let rec expr_type (context : JContext.t) expr = let program = context.program in let tenv = JContext.get_tenv context in match expr with diff --git a/infer/src/java/jTransType.mli b/infer/src/java/jTransType.mli index bb5686525..2bee21cd6 100644 --- a/infer/src/java/jTransType.mli +++ b/infer/src/java/jTransType.mli @@ -13,8 +13,12 @@ open Sawja_pack val get_method_kind : JCode.jcode Javalib.jmethod -> Typ.Procname.Java.kind val get_method_procname : - JClasspath.program -> Tenv.t -> JBasics.class_name -> JBasics.method_signature - -> Typ.Procname.Java.kind -> Typ.Procname.t + JClasspath.program + -> Tenv.t + -> JBasics.class_name + -> JBasics.method_signature + -> Typ.Procname.Java.kind + -> Typ.Procname.t (** returns a procedure name based on the class name and the method's signature. *) val translate_method_name : diff --git a/infer/src/labs/ResourceLeaks.ml b/infer/src/labs/ResourceLeaks.ml index 004c0b178..01d2806cf 100644 --- a/infer/src/labs/ResourceLeaks.ml +++ b/infer/src/labs/ResourceLeaks.ml @@ -14,11 +14,11 @@ module Domain = ResourceLeakDomain module Payload = SummaryPayload.Make (struct type t = Domain.astate - let update_payloads resources_payload (payloads: Payloads.t) = + let update_payloads resources_payload (payloads : Payloads.t) = {payloads with resources= Some resources_payload} - let of_payloads (payloads: Payloads.t) = payloads.resources + let of_payloads (payloads : Payloads.t) = payloads.resources end) type extras = FormalMap.t @@ -30,7 +30,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct type nonrec extras = extras (* Take an abstract state and instruction, produce a new abstract state *) - let exec_instr (astate: Domain.astate) {ProcData.pdesc; tenv} _ (instr: HilInstr.t) = + let exec_instr (astate : Domain.astate) {ProcData.pdesc; tenv} _ (instr : HilInstr.t) = let is_closeable procname tenv = match procname with | Typ.Procname.Java java_procname -> @@ -59,8 +59,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct false in match instr with - | Call (_return_opt, Direct callee_procname, _actuals, _, _loc) - -> ( + | Call (_return_opt, Direct callee_procname, _actuals, _, _loc) -> ( (* function call [return_opt] := invoke [callee_procname]([actuals]) *) (* 1(e) *) let astate' = @@ -103,7 +102,7 @@ module Analyzer = (* Callback for invoking the checker from the outside--registered in RegisterCheckers *) let checker {Callbacks.summary; proc_desc; tenv} : Summary.t = (* Report an error when we have acquired more resources than we have released *) - let report leak_count (proc_data: extras ProcData.t) = + let report leak_count (proc_data : extras ProcData.t) = if leak_count > 0 (* 2(a) *) then let last_loc = Procdesc.Node.get_loc (Procdesc.get_exit_node proc_data.pdesc) in let message = F.asprintf "Leaked %d resource(s)" leak_count in @@ -111,7 +110,7 @@ let checker {Callbacks.summary; proc_desc; tenv} : Summary.t = Reporting.log_error summary ~loc:last_loc exn in (* Convert the abstract state to a summary. for now, just the identity function *) - let convert_to_summary (post: Domain.astate) : Domain.summary = + let convert_to_summary (post : Domain.astate) : Domain.summary = (* 4(a) *) post in diff --git a/infer/src/llvm/llvm_sil.ml b/infer/src/llvm/llvm_sil.ml index 5be0fdc53..6bd653191 100644 --- a/infer/src/llvm/llvm_sil.ml +++ b/infer/src/llvm/llvm_sil.ml @@ -34,4 +34,5 @@ let main ~input ~output = Caml.Printexc.raise_with_backtrace exn bt -;; main ~input:Caml.Sys.argv.(1) ~output:(Some "-") +;; +main ~input:Caml.Sys.argv.(1) ~output:(Some "-") diff --git a/infer/src/quandary/ClangTrace.ml b/infer/src/quandary/ClangTrace.ml index 960a01817..1dd8f9293 100644 --- a/infer/src/quandary/ClangTrace.ml +++ b/infer/src/quandary/ClangTrace.ml @@ -71,8 +71,7 @@ module SourceKind = struct let get pname actuals tenv = let return = None in match pname with - | Typ.Procname.ObjC_Cpp cpp_name - -> ( + | Typ.Procname.ObjC_Cpp cpp_name -> ( let qualified_pname = Typ.Procname.get_qualifiers pname in match ( QualifiedCppName.to_list @@ -84,8 +83,7 @@ module SourceKind = struct Some (ReadFile, Some 1) | _ -> get_external_source qualified_pname ) - | Typ.Procname.C _ when Typ.Procname.equal pname BuiltinDecl.__global_access - -> ( + | Typ.Procname.C _ when Typ.Procname.equal pname BuiltinDecl.__global_access -> ( (* is this var a command line flag created by the popular C++ gflags library for creating command-line flags (https://github.com/gflags/gflags)? *) let is_gflag access_path = @@ -134,15 +132,15 @@ module SourceKind = struct let overrides_service_method pname tenv = PatternMatch.override_exists (function - | Typ.Procname.ObjC_Cpp cpp_pname -> - let class_name = Typ.Procname.ObjC_Cpp.get_class_name cpp_pname in - let res = - String.is_suffix ~suffix:"SvIf" class_name - || String.is_suffix ~suffix:"SvAsyncIf" class_name - in - res - | _ -> - false) + | Typ.Procname.ObjC_Cpp cpp_pname -> + let class_name = Typ.Procname.ObjC_Cpp.get_class_name cpp_pname in + let res = + String.is_suffix ~suffix:"SvIf" class_name + || String.is_suffix ~suffix:"SvAsyncIf" class_name + in + res + | _ -> + false) tenv pname in (* taint all formals except for [this] *) @@ -315,8 +313,7 @@ module SinkKind = struct match Typ.Procname.to_string pname with | "creat" | "fopen" | "freopen" | "open" -> taint_nth 0 CreateFile actuals - | "curl_easy_setopt" - -> ( + | "curl_easy_setopt" -> ( (* magic constant for setting request URL *) let controls_request = function | 10002 (* CURLOPT_URL *) | 10015 (* CURLOPT_POSTFIELDS *) -> @@ -398,7 +395,7 @@ module CppSanitizer = struct | All (** sanitizes all forms of taint *) [@@deriving compare] - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] let of_string = function | "EscapeShell" -> @@ -447,7 +444,7 @@ include Trace.Make (struct [escape_sanitizer] *) let is_injection_possible ?typ escape_sanitizer sanitizers = let is_escaped = List.mem sanitizers escape_sanitizer ~equal:Sanitizer.equal in - not is_escaped + (not is_escaped) && match typ with | Some (Typ.Tint _ | Tfloat _ | Tvoid) -> @@ -483,7 +480,8 @@ include Trace.Make (struct | (Endpoint _ | UserControlledEndpoint _), (SQLRead | SQLWrite) -> (* no injection risk, but still user-controlled *) Some IssueType.user_controlled_sql_risk - | (CommandLineFlag (_, typ) | Endpoint (_, typ) | UserControlledEndpoint (_, typ)), ShellExec -> + | (CommandLineFlag (_, typ) | Endpoint (_, typ) | UserControlledEndpoint (_, typ)), ShellExec + -> (* code injection if the caller of the endpoint doesn't sanitize on its end *) Option.some_if (is_injection_possible ~typ Sanitizer.EscapeShell sanitizers) diff --git a/infer/src/quandary/JavaTaintAnalysis.ml b/infer/src/quandary/JavaTaintAnalysis.ml index c02aa0efd..7e27b7d6e 100644 --- a/infer/src/quandary/JavaTaintAnalysis.ml +++ b/infer/src/quandary/JavaTaintAnalysis.ml @@ -38,8 +38,7 @@ include TaintAnalysis.Make (struct false in match pname with - | Typ.Procname.Java java_pname - -> ( + | Typ.Procname.Java java_pname -> ( let is_static = Typ.Procname.Java.is_static java_pname in match ( Typ.Procname.Java.get_class_name java_pname @@ -59,7 +58,8 @@ include TaintAnalysis.Make (struct | classname, _, {Typ.desc= Tptr _ | Tstruct _} -> ( match actuals with | receiver_exp :: _ - when not is_static && types_match (get_receiver_typ tenv receiver_exp) classname tenv -> + when (not is_static) && types_match (get_receiver_typ tenv receiver_exp) classname tenv + -> (* if the receiver and return type are the same, propagate to both. we're assuming the call is one of the common "builder-style" methods that both updates and returns the receiver *) diff --git a/infer/src/quandary/JavaTrace.ml b/infer/src/quandary/JavaTrace.ml index bf20a9d4a..c6facdabc 100644 --- a/infer/src/quandary/JavaTrace.ml +++ b/infer/src/quandary/JavaTrace.ml @@ -117,8 +117,8 @@ module SourceKind = struct PatternMatch.supertype_find_map_opt tenv taint_matching_supertype (Typ.Name.Java.from_string (Typ.Procname.Java.get_class_name pname)) | Typ.Procname.C _ when Typ.Procname.equal pname BuiltinDecl.__global_access -> ( - match (* accessed global will be passed to us as the only parameter *) - actuals with + (* accessed global will be passed to us as the only parameter *) + match actuals with | [HilExp.AccessExpression access_expr] -> ( match AccessExpression.to_access_path access_expr with | (Var.ProgramVar pvar, _), _ -> @@ -169,8 +169,7 @@ module SourceKind = struct in let formals = Procdesc.get_formals pdesc in match Procdesc.get_proc_name pdesc with - | Typ.Procname.Java java_pname as pname - -> ( + | Typ.Procname.Java java_pname as pname -> ( let method_name = Typ.Procname.Java.get_method java_pname in let taint_matching_supertype typename = match (Typ.Name.name typename, method_name) with @@ -197,20 +196,22 @@ module SourceKind = struct | "refresh" | "update" ) ) -> Some - (taint_formals_with_types ["android.net.Uri"; "java.lang.String"] UserControlledURI - formals) + (taint_formals_with_types + ["android.net.Uri"; "java.lang.String"] + UserControlledURI formals) | ( "android.webkit.WebChromeClient" , ("onJsAlert" | "onJsBeforeUnload" | "onJsConfirm" | "onJsPrompt") ) -> Some (taint_formals_with_types ["java.lang.String"] UserControlledURI formals) | ( "android.webkit.WebViewClient" , ("onLoadResource" | "shouldInterceptRequest" | "shouldOverrideUrlLoading") ) -> Some - (taint_formals_with_types ["android.webkit.WebResourceRequest"; "java.lang.String"] + (taint_formals_with_types + ["android.webkit.WebResourceRequest"; "java.lang.String"] UserControlledURI formals) | "codetoanalyze.java.quandary.TaintedFormals", "taintedContextBad" -> Some (taint_formals_with_types ["java.lang.Integer"; "java.lang.String"] Other formals) - | _ -> + | _ -> ( match Tenv.lookup tenv typename with | Some typ -> if @@ -225,7 +226,7 @@ module SourceKind = struct Some (taint_all_but_this ~make_source:(fun name desc -> Endpoint (name, desc))) else None | _ -> - None + None ) in match PatternMatch.supertype_find_map_opt tenv taint_matching_supertype @@ -321,7 +322,7 @@ module SinkKind = struct | Typ.Procname.Java java_pname -> (* taint all the inputs of [pname]. for non-static procedures, taints the "this" parameter only if [taint_this] is true. *) - let taint_all ?(taint_this= false) kind = + let taint_all ?(taint_this = false) kind = let actuals_to_taint, offset = if Typ.Procname.Java.is_static java_pname || taint_this then (actuals, 0) else (List.tl_exn actuals, 1) @@ -530,7 +531,8 @@ include Trace.Make (struct | (Endpoint _ | Intent | IntentFromURI | UserControlledString | UserControlledURI), HTML -> (* untrusted data flows into HTML; XSS risk *) Some IssueType.cross_site_scripting - | (Endpoint _ | Intent | IntentFromURI | UserControlledString | UserControlledURI), JavaScript -> + | (Endpoint _ | Intent | IntentFromURI | UserControlledString | UserControlledURI), JavaScript + -> (* untrusted data flows into JS *) Some IssueType.javascript_injection | ( (Endpoint _ | Intent | IntentFromURI | UserControlledString | UserControlledURI) diff --git a/infer/src/quandary/TaintAnalysis.ml b/infer/src/quandary/TaintAnalysis.ml index 6952834ff..4002f8350 100644 --- a/infer/src/quandary/TaintAnalysis.ml +++ b/infer/src/quandary/TaintAnalysis.ml @@ -17,11 +17,11 @@ module Make (TaintSpecification : TaintSpec.S) = struct module Payload = SummaryPayload.Make (struct type t = QuandarySummary.t - let update_payloads quandary_payload (payloads: Payloads.t) = + let update_payloads quandary_payload (payloads : Payloads.t) = {payloads with quandary= Some quandary_payload} - let of_payloads (payloads: Payloads.t) = payloads.quandary + let of_payloads (payloads : Payloads.t) = payloads.quandary end) module Domain = TaintDomain @@ -35,11 +35,11 @@ module Make (TaintSpecification : TaintSpec.S) = struct type nonrec extras = extras (* get the node associated with [access_path] in [access_tree] *) - let access_path_get_node access_path access_tree (proc_data: extras ProcData.t) = + let access_path_get_node access_path access_tree (proc_data : extras ProcData.t) = match TaintDomain.get_node access_path access_tree with | Some _ as node_opt -> node_opt - | None -> + | None -> ( let make_footprint_trace footprint_ap = let trace = TraceDomain.of_footprint footprint_ap in Some (TaintDomain.make_normal_leaf trace) @@ -49,7 +49,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct | Some formal_index -> make_footprint_trace (AccessPath.Abs.to_footprint formal_index access_path) | None -> - if Var.is_global (fst root) then make_footprint_trace access_path else None + if Var.is_global (fst root) then make_footprint_trace access_path else None ) (* get the trace associated with [access_path] in [access_tree]. *) @@ -70,7 +70,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct (* get the node associated with [exp] in [access_tree] *) - let rec hil_exp_get_node ?(abstracted= false) (exp: HilExp.t) access_tree proc_data = + let rec hil_exp_get_node ?(abstracted = false) (exp : HilExp.t) access_tree proc_data = match exp with | AccessExpression access_expr -> exp_get_node_ ~abstracted @@ -129,7 +129,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct (** log any new reportable source-sink flows in [trace] *) - let report_trace ?(sink_indexes= IntSet.empty) trace cur_site (proc_data: extras ProcData.t) = + let report_trace ?(sink_indexes = IntSet.empty) trace cur_site (proc_data : extras ProcData.t) + = let get_summary pname = if Typ.Procname.equal pname (Procdesc.get_proc_name proc_data.pdesc) then (* read_summary will trigger ondemand analysis of the current proc. we don't want that. *) @@ -196,7 +197,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct match List.find ~f:(fun source -> - [%compare.equal : Source.Kind.t] kind (Source.kind source) + [%compare.equal: Source.Kind.t] kind (Source.kind source) && not (is_recursive source) ) (Sources.Known.elements (sources trace).Sources.known) with @@ -224,7 +225,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct match List.find ~f:(fun sink -> - [%compare.equal : Sink.Kind.t] kind (Sink.kind sink) + [%compare.equal: Sink.Kind.t] kind (Sink.kind sink) && not (is_recursive sink) ) (Sinks.elements (sinks trace)) with @@ -238,13 +239,13 @@ module Make (TaintSpecification : TaintSpec.S) = struct (get_summary (CallSite.pname call_site)) [] in + (* try to find a sink whose indexes match the current sink *) try - (* try to find a sink whose indexes match the current sink *) let matching_sink, _ = List.find_exn ~f:snd matching_sinks in expand_sink matching_sink (Sink.indexes matching_sink) (matching_sink :: report_acc, seen_acc') with - | Not_found_s _ | Caml.Not_found -> + | Not_found_s _ | Caml.Not_found -> ( (* didn't find a sink whose indexes match; this can happen when taint flows in via a global. pick any sink whose kind matches *) match matching_sinks with @@ -252,7 +253,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct expand_sink matching_sink (Sink.indexes matching_sink) (matching_sink :: report_acc, seen_acc') | [] -> - acc + acc ) in let expanded_sources, _ = expand_source path_source ([(None, path_source)], CallSite.Set.empty) @@ -268,8 +269,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct let base, _ = AccessPath.Abs.extract access_path in F.fprintf fmt " with tainted data %a" AccessPath.Abs.pp ( if Var.is_footprint (fst base) then - (* TODO: resolve footprint identifier to formal name *) - access_path + (* TODO: resolve footprint identifier to formal name *) + access_path else access_path ) in List.map @@ -326,8 +327,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct match List.nth actuals sink_index with | Some exp -> ( match hil_exp_get_node ~abstracted:true exp access_tree_acc proc_data with - | Some (actual_trace, _) - -> ( + | Some (actual_trace, _) -> ( let sink' = let indexes = IntSet.singleton sink_index in TraceDomain.Sink.make ~indexes (TraceDomain.Sink.kind sink) callee_site @@ -357,8 +357,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct IntSet.fold add_sink_to_actual (TraceDomain.Sink.indexes sink) access_tree - let apply_summary ret_opt (actuals: HilExp.t list) summary caller_access_tree - (proc_data: extras ProcData.t) callee_site = + let apply_summary ret_opt (actuals : HilExp.t list) summary caller_access_tree + (proc_data : extras ProcData.t) callee_site = let get_caller_ap_node_opt formal_ap access_tree = let apply_return ret_ap = match ret_opt with @@ -444,7 +444,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct TaintDomain.trace_fold add_to_caller_tree summary caller_access_tree - let exec_instr (astate: Domain.astate) (proc_data: extras ProcData.t) _ (instr: HilInstr.t) = + let exec_instr (astate : Domain.astate) (proc_data : extras ProcData.t) _ (instr : HilInstr.t) + = (* not all sinks are function calls; we might want to treat an array or field access as a sink too. do this by pretending an access is a call to a dummy function and using the existing machinery for adding function call sinks *) @@ -482,7 +483,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct if Var.is_global var then let dummy_call_site = CallSite.make BuiltinDecl.__global_access loc in match - TraceDomain.Source.get dummy_call_site [HilExp.AccessExpression access_expr] + TraceDomain.Source.get dummy_call_site + [HilExp.AccessExpression access_expr] proc_data.tenv with | Some {TraceDomain.Source.source} -> @@ -493,7 +495,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct Option.value ~default:TaintDomain.empty_node (TaintDomain.get_node access_path astate) in - TaintDomain.add_node access_path (TraceDomain.add_source source trace, subtree) + TaintDomain.add_node access_path + (TraceDomain.add_source source trace, subtree) astate | None -> astate @@ -530,7 +533,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct astate | Assign (lhs_access_expr, rhs_exp, loc) -> add_sources_sinks_for_exp rhs_exp loc astate - |> add_sinks_for_access_path lhs_access_expr loc |> exec_write lhs_access_expr rhs_exp + |> add_sinks_for_access_path lhs_access_expr loc + |> exec_write lhs_access_expr rhs_exp | Assume (assume_exp, _, _, loc) -> add_sources_sinks_for_exp assume_exp loc astate | Call (ret_ap, Direct called_pname, actuals, call_flags, callee_loc) -> @@ -590,8 +594,9 @@ module Make (TaintSpecification : TaintSpec.S) = struct | _, [] -> astate_acc | TaintSpec.Propagate_to_return, actuals -> - propagate_to_access_path (AccessPath.Abs.Abstracted (ret_ap, [])) actuals - astate_acc + propagate_to_access_path + (AccessPath.Abs.Abstracted (ret_ap, [])) + actuals astate_acc | ( TaintSpec.Propagate_to_receiver , AccessExpression receiver_ae :: (_ :: _ as other_actuals) ) -> propagate_to_access_path @@ -613,15 +618,15 @@ module Make (TaintSpecification : TaintSpec.S) = struct let handle_unknown_call callee_pname access_tree = match Typ.Procname.get_method callee_pname with | "operator=" when not (Typ.Procname.is_java callee_pname) -> ( - match (* treat unknown calls to C++ operator= as assignment *) - actuals with + (* treat unknown calls to C++ operator= as assignment *) + match actuals with | [AccessExpression lhs_access_expr; rhs_exp] -> exec_write lhs_access_expr rhs_exp access_tree - | [AccessExpression lhs_access_expr; rhs_exp; HilExp.AccessExpression access_expr] - -> ( + | [AccessExpression lhs_access_expr; rhs_exp; HilExp.AccessExpression access_expr] -> ( let dummy_ret_access_expr = access_expr in match dummy_ret_access_expr with - | AccessExpression.Base (Var.ProgramVar pvar, _) when Pvar.is_frontend_tmp pvar -> + | AccessExpression.Base (Var.ProgramVar pvar, _) when Pvar.is_frontend_tmp pvar + -> (* the frontend translates operator=(x, y) as operator=(x, y, dummy_ret) when operator= returns a value type *) exec_write lhs_access_expr rhs_exp access_tree @@ -646,12 +651,10 @@ module Make (TaintSpecification : TaintSpec.S) = struct let dummy_ret_opt = match ret_ap with | _, {Typ.desc= Tvoid} when not (Typ.Procname.is_java called_pname) -> ( - match - (* the C++ frontend handles returns of non-pointers by adding a dummy + (* the C++ frontend handles returns of non-pointers by adding a dummy pass-by-reference variable as the last actual, then returning the value by assigning to it. understand this pattern by pretending it's the return value *) - List.last actuals - with + match List.last actuals with | Some (HilExp.AccessExpression access_expr) -> ( match AccessExpression.to_access_path access_expr with | ((Var.ProgramVar pvar, _) as ret_base), [] when Pvar.is_frontend_tmp pvar -> @@ -696,7 +699,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct match Payload.read proc_data.pdesc callee_pname with | None -> handle_unknown_call callee_pname astate_with_source - | Some summary -> + | Some summary -> ( let ret_typ = snd ret_ap in let access_tree = TaintSpecification.of_summary_access_tree summary in match @@ -707,13 +710,13 @@ module Make (TaintSpecification : TaintSpec.S) = struct handle_model callee_pname astate_with_source model | None -> apply_summary dummy_ret_opt actuals access_tree astate_with_source - proc_data call_site + proc_data call_site ) in let astate_with_sanitizer = match dummy_ret_opt with | None -> astate_with_summary - | Some ret_base -> + | Some ret_base -> ( match TraceDomain.Sanitizer.get callee_pname with | Some sanitizer -> let ret_ap = AccessPath.Abs.Exact (ret_base, []) in @@ -721,7 +724,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct let ret_trace' = TraceDomain.add_sanitizer sanitizer ret_trace in TaintDomain.add_trace ret_ap ret_trace' astate_with_summary | None -> - astate_with_summary + astate_with_summary ) in Domain.join astate_acc astate_with_sanitizer in @@ -732,7 +735,7 @@ module Make (TaintSpecification : TaintSpec.S) = struct let pp_session_name = let name = F.sprintf "quandary(%s)" TaintSpecification.name in - fun (_node: CFG.Node.t) fmt -> F.pp_print_string fmt name + fun (_node : CFG.Node.t) fmt -> F.pp_print_string fmt name end module HilConfig : LowerHil.HilConfig = struct @@ -772,7 +775,9 @@ module Make (TaintSpecification : TaintSpec.S) = struct lazily create it if/when someone actually tries to read the access path instead *) (* TODO: tmp to focus on invariant 1 *) if - false && AccessPath.Abs.is_exact access_path && Sinks.is_empty sinks + false + && AccessPath.Abs.is_exact access_path + && Sinks.is_empty sinks && Sources.Footprint.mem access_path footprint_sources && Sources.Footprint.exists (fun footprint_access_path (is_mem, _) -> diff --git a/infer/src/scripts/checkCopyright.ml b/infer/src/scripts/checkCopyright.ml index 79f22668f..88a27c475 100644 --- a/infer/src/scripts/checkCopyright.ml +++ b/infer/src/scripts/checkCopyright.ml @@ -21,7 +21,7 @@ type comment_style = | Block of string * string * string * bool (** block comments, eg ("(*", "*", "*)") for ocaml *) [@@deriving compare] -let equal_comment_style = [%compare.equal : comment_style] +let equal_comment_style = [%compare.equal: comment_style] let comment_style_al = Line ("//", false) @@ -149,7 +149,9 @@ let looks_like_copyright_message cstart cend lines = let max_len = 100 in let check_len () = let ok = ref true in - for i = cstart to cend do if String.length lines.(i) > max_len then ok := false done ; + for i = cstart to cend do + if String.length lines.(i) > max_len then ok := false + done ; !ok in cstart >= 0 && cend - cstart <= 10 && check_len () @@ -157,7 +159,9 @@ let looks_like_copyright_message cstart cend lines = let contains_string ~substring cstart cend lines = let found = ref false in - for i = cstart to cend do if String.is_substring ~substring lines.(i) then found := true done ; + for i = cstart to cend do + if String.is_substring ~substring lines.(i) then found := true + done ; !found @@ -218,7 +222,9 @@ let copyright_has_changed fname lines ~notice_range:(cstart, cend) ~monoidics ~r ~copyright_year com_style = let old_copyright = let r = ref "" in - for i = cstart to cend do r := !r ^ lines.(i) ^ "\n" done ; + for i = cstart to cend do + r := !r ^ lines.(i) ^ "\n" + done ; !r in let new_copyright = @@ -263,7 +269,7 @@ let comment_style_of_filename fname = List.Assoc.find com_style_of_lang ~equal:Filename.check_suffix fname -let output_diff ~fname lines ?notice_range ?(monoidics= false) ?(ropas= false) ~copyright_year +let output_diff ~fname lines ?notice_range ?(monoidics = false) ?(ropas = false) ~copyright_year com_style = let lang = lang_of_comment_style com_style in let pp_range_opt fmt = function @@ -283,12 +289,16 @@ let output_diff ~fname lines ?notice_range ?(monoidics= false) ?(ropas= false) ~ let insert_notice_at = default_start_line_of_com_style com_style in (insert_notice_at - 1, insert_notice_at) in - for i = 0 to copy_lines_before do F.fprintf fmt "%s\n" lines.(i) done ; + for i = 0 to copy_lines_before do + F.fprintf fmt "%s\n" lines.(i) + done ; if starts_with_newline com_style && copy_lines_before > 0 && lines.(copy_lines_before - 1) <> "" then F.fprintf fmt "@\n" ; pp_copyright ~monoidics ~ropas ~copyright_year com_style fmt ; - for i = copy_lines_after to Array.length lines - 1 do F.fprintf fmt "%s\n" lines.(i) done ; + for i = copy_lines_after to Array.length lines - 1 do + F.fprintf fmt "%s\n" lines.(i) + done ; F.fprintf fmt "%!" in if !update_files then @@ -308,7 +318,7 @@ let check_copyright fname = let copyright_year = 1900 + (Unix.localtime (Unix.time ())).Unix.tm_year in output_diff ~fname lines ~copyright_year com_style ; raise (CopyrightEvent CopyrightModified) - | Some n, fname_com_style -> + | Some n, fname_com_style -> ( let cstart, contents_com_style = find_comment_start_and_style lines n |> Option.value ~default:(0, Line ("#", false)) in @@ -362,7 +372,7 @@ let check_copyright fname = then ( output_diff ~fname lines ~notice_range:(cstart, cend) ~monoidics ~ropas ~copyright_year com_style ; - raise (CopyrightEvent CopyrightModified) ) + raise (CopyrightEvent CopyrightModified) ) ) let speclist = diff --git a/infer/src/scripts/dune.in b/infer/src/scripts/dune.in index 135ff063c..60b4ad47a 100644 --- a/infer/src/scripts/dune.in +++ b/infer/src/scripts/dune.in @@ -1,6 +1,8 @@ (* NOTE: prepend dune.common to this file! *) -;; Format.sprintf - {| + +;; +Format.sprintf + {| (executable (name checkCopyright) (flags (%s)) @@ -8,5 +10,5 @@ (preprocess (pps ppx_compare)) ) |} - (String.concat " " common_cflags) - |> Jbuild_plugin.V1.send + (String.concat " " common_cflags) +|> Jbuild_plugin.V1.send diff --git a/infer/src/unit/DifferentialFiltersTests.ml b/infer/src/unit/DifferentialFiltersTests.ml index 4ed85a3f4..f44010d97 100644 --- a/infer/src/unit/DifferentialFiltersTests.ml +++ b/infer/src/unit/DifferentialFiltersTests.ml @@ -65,7 +65,7 @@ let test_file_renamings_find_previous = ; {DifferentialFilters.FileRenamings.current= "ccc.java"; previous= "DDD.java"} ; {DifferentialFilters.FileRenamings.current= "eee.java"; previous= "FFF.java"} ] in - let cmp s1 s2 = [%compare.equal : string option] s1 s2 in + let cmp s1 s2 = [%compare.equal: string option] s1 s2 in let find_previous = DifferentialFilters.FileRenamings.find_previous in let pp_diff fmt (expected, actual) = let pp_str_opt fmt str_opt = diff --git a/infer/src/unit/DifferentialTestsUtils.ml b/infer/src/unit/DifferentialTestsUtils.ml index 4cf7eec2a..bd3c5dd9b 100644 --- a/infer/src/unit/DifferentialTestsUtils.ml +++ b/infer/src/unit/DifferentialTestsUtils.ml @@ -7,12 +7,12 @@ open! IStd -let create_fake_jsonbug ?(kind= "kind") ?(bug_type= "bug_type") ?(qualifier= "qualifier") - ?(severity= "severity") ?(visibility= "visibility") ?(line= 1) ?(column= 1) - ?(procedure= "procedure") ?(procedure_start_line= 1) ?(file= "file/at/a/certain/path.java") - ?(bug_trace= []) ?(node_key= "File|method|TYPE") ?(key= "1234") ?(hash= "1") ?(dotty= None) - ?(infer_source_loc= None) ?(linters_def_file= Some "file/at/certain/path.al") ?doc_url () - : Jsonbug_t.jsonbug = +let create_fake_jsonbug ?(kind = "kind") ?(bug_type = "bug_type") ?(qualifier = "qualifier") + ?(severity = "severity") ?(visibility = "visibility") ?(line = 1) ?(column = 1) + ?(procedure = "procedure") ?(procedure_start_line = 1) ?(file = "file/at/a/certain/path.java") + ?(bug_trace = []) ?(node_key = "File|method|TYPE") ?(key = "1234") ?(hash = "1") + ?(dotty = None) ?(infer_source_loc = None) ?(linters_def_file = Some "file/at/certain/path.al") + ?doc_url () : Jsonbug_t.jsonbug = { kind ; bug_type ; qualifier diff --git a/infer/src/unit/FileDiffTests.ml b/infer/src/unit/FileDiffTests.ml index a67a29389..1984196dd 100644 --- a/infer/src/unit/FileDiffTests.ml +++ b/infer/src/unit/FileDiffTests.ml @@ -21,7 +21,7 @@ let test_unixdiff_process_raw_directives_with_valid_input = in [ ( "test_unixdiff_process_raw_directives_1" , "UOOU" - , UnixDiffTest.([Unchanged; Old; Old; Unchanged]) ) + , UnixDiffTest.[Unchanged; Old; Old; Unchanged] ) ; ("test_unixdiff_process_raw_directives_2", "", []) ] |> List.map ~f:(fun (name, test_input, expected_output) -> name >:: create_test test_input expected_output ) @@ -56,7 +56,7 @@ let test_unixdiff_pp = in assert_equal ~cmp:String.equal ~pp_diff expected found in - [ ("test_unixdiff_pp_1", UnixDiffTest.([Unchanged; Old; Old; Unchanged]), "UOOU") + [ ("test_unixdiff_pp_1", UnixDiffTest.[Unchanged; Old; Old; Unchanged], "UOOU") ; ("test_unixdiff_pp_2", [], "") ] |> List.map ~f:(fun (name, test_input, expected_output) -> name >:: create_test test_input expected_output ) diff --git a/infer/src/unit/JavaProfilerSamplesTest.ml b/infer/src/unit/JavaProfilerSamplesTest.ml index 03f214783..ecfe17abc 100644 --- a/infer/src/unit/JavaProfilerSamplesTest.ml +++ b/infer/src/unit/JavaProfilerSamplesTest.ml @@ -278,7 +278,7 @@ let test_from_json_string_with_invalid_input = let tests = "java_profiler_samples" - >::: test_jni_to_java_type_with_invalid_input :: test_jni_parse_str_with_valid_input + >::: (test_jni_to_java_type_with_invalid_input :: test_jni_parse_str_with_valid_input) @ test_jni_parse_str_with_invalid_input @ test_jni_parse_method_str_with_invalid_input @ test_jni_pp @ test_jni_to_java_type_with_valid_input @ test_from_json_string_with_valid_input @ test_from_json_string_with_invalid_input diff --git a/infer/src/unit/TraceTests.ml b/infer/src/unit/TraceTests.ml index c91d34a28..1e434a3cf 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 = [%compare.equal : t] + let equal = [%compare.equal: t] end module MockSink = struct @@ -68,7 +68,7 @@ module MockSink = struct let indexes _ = IntSet.empty - let equal = [%compare.equal : t] + let equal = [%compare.equal: t] end module MockTrace = Trace.Make (struct @@ -77,7 +77,7 @@ module MockTrace = Trace.Make (struct module Sanitizer = Sanitizer.Dummy let get_report source sink _ = - if [%compare.equal : MockTraceElem.t] (Source.kind source) (Sink.kind sink) then + if [%compare.equal: MockTraceElem.t] (Source.kind source) (Sink.kind sink) then Some IssueType.quandary_taint_error else None end) diff --git a/infer/src/unit/accessPathTestUtils.ml b/infer/src/unit/accessPathTestUtils.ml index b7197148a..62ac61485 100644 --- a/infer/src/unit/accessPathTestUtils.ml +++ b/infer/src/unit/accessPathTestUtils.ml @@ -9,7 +9,7 @@ open! IStd let make_var var_str = Pvar.mk (Mangled.from_string var_str) Typ.Procname.empty_block -let make_base ?(typ= Typ.mk Tvoid) base_str = AccessPath.base_of_pvar (make_var base_str) typ +let make_base ?(typ = Typ.mk Tvoid) base_str = AccessPath.base_of_pvar (make_var base_str) typ let make_fieldname = Typ.Fieldname.Java.from_string diff --git a/infer/src/unit/accessTreeTests.ml b/infer/src/unit/accessTreeTests.ml index 2fd6a710a..b40939ec9 100644 --- a/infer/src/unit/accessTreeTests.ml +++ b/infer/src/unit/accessTreeTests.ml @@ -100,7 +100,8 @@ let tests = let y_subtree = Domain.AccessMap.singleton f yF_subtree |> Domain.make_node y_trace in let z_subtree = Domain.make_starred_leaf z_trace in let tree = - Domain.BaseMap.singleton x_base x_subtree |> Domain.BaseMap.add y_base y_subtree + Domain.BaseMap.singleton x_base x_subtree + |> Domain.BaseMap.add y_base y_subtree |> Domain.BaseMap.add z_base z_subtree in let x_base_tree = Domain.BaseMap.singleton x_base Domain.empty_node in @@ -187,13 +188,15 @@ let tests = |> Domain.BaseMap.add y_base Domain.empty_node in let mk_xFG_node leaf_trace = - Domain.make_access_node MockTraceDomain.empty g leaf_trace |> Domain.AccessMap.singleton f + Domain.make_access_node MockTraceDomain.empty g leaf_trace + |> Domain.AccessMap.singleton f |> Domain.make_node MockTraceDomain.empty in let mk_xFG_tree leaf_trace = mk_xFG_node leaf_trace |> Domain.BaseMap.singleton x_base in let mk_xArrF_tree leaf_trace = Domain.make_access_node MockTraceDomain.empty f leaf_trace - |> Domain.AccessMap.singleton array |> Domain.make_node MockTraceDomain.empty + |> Domain.AccessMap.singleton array + |> Domain.make_node MockTraceDomain.empty |> Domain.BaseMap.singleton x_base in (* normal tests *) @@ -220,8 +223,10 @@ let tests = xFG_tree_added_trace ; (* add starred path when base absent *) let xF_star_tree_added_trace = - Domain.make_starred_leaf added_trace |> Domain.AccessMap.singleton f - |> Domain.make_node MockTraceDomain.empty |> Domain.BaseMap.singleton x_base + Domain.make_starred_leaf added_trace + |> Domain.AccessMap.singleton f + |> Domain.make_node MockTraceDomain.empty + |> Domain.BaseMap.singleton x_base in Domain.assert_trees_equal (Domain.add_trace xF_star added_trace Domain.empty) @@ -241,8 +246,9 @@ let tests = (* starred tests *) (* we should do a strong update when updating x.f* with x.f *) let yF_tree_added_trace = - Domain.make_normal_leaf added_trace |> Domain.AccessMap.singleton f - |> Domain.make_node y_trace |> Domain.BaseMap.singleton y_base + Domain.make_normal_leaf added_trace + |> Domain.AccessMap.singleton f |> Domain.make_node y_trace + |> Domain.BaseMap.singleton y_base in Domain.assert_trees_equal (Domain.add_trace yF added_trace yF_star_tree) yF_tree_added_trace ; (* but not when updating x* with x.f *) @@ -259,8 +265,9 @@ let tests = let joined_trace = MockTraceDomain.join added_trace xFG_trace |> MockTraceDomain.join xF_trace in - Domain.make_starred_leaf joined_trace |> Domain.AccessMap.singleton f - |> Domain.make_node x_trace |> Domain.BaseMap.singleton x_base + Domain.make_starred_leaf joined_trace + |> Domain.AccessMap.singleton f |> Domain.make_node x_trace + |> Domain.BaseMap.singleton x_base in Domain.assert_trees_equal (Domain.add_trace xF_star added_trace xFG_tree) @@ -278,7 +285,8 @@ let tests = |> Domain.AccessMap.add g (Domain.make_normal_leaf xFG_trace) in Domain.AccessMap.singleton array (Domain.make_node xF_trace arr_subtree) - |> Domain.make_node MockTraceDomain.empty |> Domain.BaseMap.singleton x_base + |> Domain.make_node MockTraceDomain.empty + |> Domain.BaseMap.singleton x_base in Domain.assert_trees_equal (Domain.add_node xArr g_subtree aArrF_tree) arr_tree in @@ -374,7 +382,8 @@ let tests = *) let xF_star_tree = Domain.AccessMap.singleton f (Domain.make_starred_leaf MockTraceDomain.top) - |> Domain.make_node MockTraceDomain.top |> Domain.BaseMap.singleton x_base + |> Domain.make_node MockTraceDomain.top + |> Domain.BaseMap.singleton x_base in Domain.assert_trees_equal (widen x_tree_y_trace xFG_tree) xF_star_tree ; (* widening is not commutative, and is it not join: @@ -453,7 +462,8 @@ let tests = |> Max2.make_node MockTraceDomain.empty in let fG_node = - Max2.make_access_node MockTraceDomain.empty g x_trace |> Max2.AccessMap.singleton f + Max2.make_access_node MockTraceDomain.empty g x_trace + |> Max2.AccessMap.singleton f |> Max2.make_node MockTraceDomain.empty in let f_star_node = diff --git a/infer/src/unit/analyzerTester.ml b/infer/src/unit/analyzerTester.ml index b2897219d..261f4e2d9 100644 --- a/infer/src/unit/analyzerTester.ml +++ b/infer/src/unit/analyzerTester.ml @@ -72,7 +72,7 @@ module StructuredSil = struct let make_set ~rhs_typ ~lhs_exp ~rhs_exp = Cmd (Sil.Store (lhs_exp, rhs_typ, rhs_exp, dummy_loc)) - let make_call ?(procname= dummy_procname) ?return:return_opt args = + let make_call ?(procname = dummy_procname) ?return:return_opt args = let ret_id_typ = match return_opt with | Some ret_id_typ -> @@ -96,22 +96,22 @@ module StructuredSil = struct make_load ~rhs_typ (ident_of_str lhs_str) rhs_exp - let id_assign_exp ?(rhs_typ= dummy_typ) lhs rhs_exp = + let id_assign_exp ?(rhs_typ = dummy_typ) lhs rhs_exp = let lhs_id = ident_of_str lhs in make_load ~rhs_typ lhs_id rhs_exp - let id_assign_id ?(rhs_typ= dummy_typ) lhs rhs = + let id_assign_id ?(rhs_typ = dummy_typ) lhs rhs = id_assign_exp ~rhs_typ lhs (Exp.Var (ident_of_str rhs)) - let id_assign_var ?(rhs_typ= dummy_typ) lhs rhs = + let id_assign_var ?(rhs_typ = dummy_typ) lhs rhs = let lhs_id = ident_of_str lhs in let rhs_exp = var_of_str rhs in make_load ~rhs_typ lhs_id rhs_exp - let id_set_id ?(rhs_typ= dummy_typ) lhs_id rhs_id = + let id_set_id ?(rhs_typ = dummy_typ) lhs_id rhs_id = let lhs_exp = Exp.Var (ident_of_str lhs_id) in let rhs_exp = Exp.Var (ident_of_str rhs_id) in make_set ~rhs_typ ~lhs_exp ~rhs_exp @@ -128,14 +128,14 @@ module StructuredSil = struct var_assign_exp ~rhs_typ lhs rhs_exp - let var_assign_id ?(rhs_typ= dummy_typ) lhs rhs = + let var_assign_id ?(rhs_typ = dummy_typ) lhs rhs = let lhs_exp = var_of_str lhs in let rhs_exp = Exp.Var (ident_of_str rhs) in make_set ~rhs_typ ~lhs_exp ~rhs_exp (* x = &y *) - let var_assign_addrof_var ?(rhs_typ= dummy_typ) lhs rhs = + let var_assign_addrof_var ?(rhs_typ = dummy_typ) lhs rhs = let lhs_exp = var_of_str lhs in let rhs_exp = var_of_str rhs in make_set ~rhs_typ ~lhs_exp ~rhs_exp @@ -276,7 +276,7 @@ struct OUnit2.assert_failure assert_fail_message - let create_tests ?(test_pname= Typ.Procname.empty_block) ~initial ?pp_opt extras tests = + let create_tests ?(test_pname = Typ.Procname.empty_block) ~initial ?pp_opt extras tests = let open OUnit2 in List.map ~f:(fun (name, test_program) -> diff --git a/infer/src/unit/clang/CFrontend_errorsTests.ml b/infer/src/unit/clang/CFrontend_errorsTests.ml index d1d2cd09b..8f86040a8 100644 --- a/infer/src/unit/clang/CFrontend_errorsTests.ml +++ b/infer/src/unit/clang/CFrontend_errorsTests.ml @@ -12,7 +12,7 @@ let test_correct_removing_new_lines = let pp_diff_of_desc fmt (expected, actual) = Format.fprintf fmt "Expected: [%s] Found: [%s]" expected actual in - let create_test (desc: string) (expected_desc: string) _ = + let create_test (desc : string) (expected_desc : string) _ = let output = CFrontend_errors.remove_new_lines_and_whitespace desc in let cmp s1 s2 = String.equal s1 s2 in assert_equal ~pp_diff:pp_diff_of_desc ~cmp expected_desc output diff --git a/infer/src/unit/clang/CiOSVersionNumbersTests.ml b/infer/src/unit/clang/CiOSVersionNumbersTests.ml index 3005cf6b3..4f9505ed8 100644 --- a/infer/src/unit/clang/CiOSVersionNumbersTests.ml +++ b/infer/src/unit/clang/CiOSVersionNumbersTests.ml @@ -9,7 +9,7 @@ open! IStd open OUnit2 let test_correct_ios_version = - let create_test (version: string) (expected_version: string option) _ = + let create_test (version : string) (expected_version : string option) _ = let output = CiOSVersionNumbers.version_of version in let cmp s1 s2 = Option.equal String.equal s1 s2 in assert_equal ~pp_diff:CiOSVersionNumbers.pp_diff_of_version_opt ~cmp expected_version output diff --git a/infer/src/unit/schedulerTests.ml b/infer/src/unit/schedulerTests.ml index 9db07c119..cff5aae78 100644 --- a/infer/src/unit/schedulerTests.ml +++ b/infer/src/unit/schedulerTests.ml @@ -56,7 +56,8 @@ module MockProcCfg = struct let fold_succs t n ~init ~f = let node_id = Node.id n in List.find ~f:(fun (node, _) -> equal_id (Node.id node) node_id) t - |> Option.value_map ~f:snd ~default:[] |> List.fold ~init ~f + |> Option.value_map ~f:snd ~default:[] + |> List.fold ~init ~f let fold_preds t n ~init ~f = diff --git a/sledge/.ocamlformat b/sledge/.ocamlformat index aef6ee634..13ba6940f 100644 --- a/sledge/.ocamlformat +++ b/sledge/.ocamlformat @@ -1,4 +1,4 @@ -break-string-literals wrap -margin 77 -sparse false -wrap-comments true +break-cases = fit +break-string-literals = wrap +margin = 77 +wrap-comments = true diff --git a/sledge/src/config.ml b/sledge/src/config.ml index 64e5fcb44..888737e05 100644 --- a/sledge/src/config.ml +++ b/sledge/src/config.ml @@ -25,7 +25,7 @@ end = struct (** existential package of a Term and a setter for a ref to receive the parsed value *) - type arg = Arg: 'a Term.t * ('a -> unit) -> arg + type arg = Arg : 'a Term.t * ('a -> unit) -> arg (** convert a list of arg packages to a term for the tuple of all the arg terms, and apply it to a function that sets all the receiver refs *) @@ -36,7 +36,7 @@ end = struct Arg (trm_xy, set_xy) in let init = Arg (Term.const (), fun () -> ()) in - let Arg (trm, set) = List.fold_right ~f:pair args ~init in + let (Arg (trm, set)) = List.fold_right ~f:pair args ~init in Term.app (Term.const set) trm let args : arg list ref = ref [] @@ -72,7 +72,8 @@ let info = Term.info "sledge" ~version:Version.version let validate () = `Ok () -;; parse info validate +;; +parse info validate let run main = Trace.init ~trace_all:!trace_all ; diff --git a/sledge/src/import/vector.ml b/sledge/src/import/vector.ml index 272b8cb89..317d403e9 100644 --- a/sledge/src/import/vector.ml +++ b/sledge/src/import/vector.ml @@ -12,9 +12,9 @@ open Base (** = 'a array but covariant since imperative operations hidden *) type +'a t -let v (a: 'a array) : 'a t = Caml.Obj.magic a +let v (a : 'a array) : 'a t = Caml.Obj.magic a -let a (v: 'a t) : 'a array = Caml.Obj.magic v +let a (v : 'a t) : 'a array = Caml.Obj.magic v let compare cmp x y = Array.compare cmp (a x) (a y) diff --git a/sledge/src/llair/exp.ml b/sledge/src/llair/exp.ml index a4a832c79..cb929c0f4 100644 --- a/sledge/src/llair/exp.ml +++ b/sledge/src/llair/exp.ml @@ -59,7 +59,7 @@ type t = | URem [@@deriving compare, sexp] -let equal = [%compare.equal : t] +let equal = [%compare.equal: t] let uncurry exp = let rec uncurry_ args op = @@ -189,7 +189,7 @@ module Var = struct let fmt = fmt - let mk ?(loc= Loc.none) name typ = Var {name; typ; loc} + let mk ?(loc = Loc.none) name typ = Var {name; typ; loc} let name = function[@warning "p"] Var {name} -> name @@ -214,15 +214,15 @@ module Global = struct include Comparator.Make (T) let fmt_defn ff g = - let[@warning "p"] Global {init; typ} = g in - let[@warning "p"] Typ.Pointer {elt= typ} = typ in + let[@warning "p"] (Global {init; typ}) = g in + let[@warning "p"] (Typ.Pointer {elt= typ}) = typ in Format.fprintf ff "@[<2>%a %a%a@]" Typ.fmt typ fmt g (option_fmt " =@ @[%a@]" fmt) init let fmt = fmt - let mk ?init ?(loc= Loc.none) name typ = + let mk ?init ?(loc = Loc.none) name typ = assert ( Option.for_all init ~f:(fun exp -> Typ.equal typ (Typ.mkPointer ~elt:(typ_of exp)) ) ) ; @@ -261,13 +261,13 @@ let mkVar = Fn.id let mkGlobal = Fn.id -let mkNondet (typ: Typ.t) msg = +let mkNondet (typ : Typ.t) msg = assert (match typ with Function _ -> false | _ -> true) ; Nondet {typ; loc= Loc.none; msg} let mkLabel ~parent ~name = Label {parent; name; loc= Loc.none} -let mkNull (typ: Typ.t) = +let mkNull (typ : Typ.t) = assert (match typ with Opaque _ | Function _ -> false | _ -> true) ; Null {typ} @@ -314,7 +314,7 @@ let mkUpdIdx ~arr ~elt ~idx = | _ -> false ) ; mkApp3 UpdIdx arr elt idx -let mkInteger data (typ: Typ.t) = +let mkInteger data (typ : Typ.t) = assert ( let in_range num bits = let lb = Z.(-(if bits = 1 then ~$1 else ~$1 lsl Int.(bits - 1))) @@ -326,11 +326,11 @@ let mkInteger data (typ: Typ.t) = let mkBool b = mkInteger (Z.of_int (Bool.to_int b)) Typ.i1 -let mkFloat data (typ: Typ.t) = +let mkFloat data (typ : Typ.t) = assert (match typ with Float _ -> true | _ -> false) ; Float {data; typ} -let mkArray elts (typ: Typ.t) = +let mkArray elts (typ : Typ.t) = assert ( match typ with | Array {elt= elt_typ; len} -> @@ -339,7 +339,7 @@ let mkArray elts (typ: Typ.t) = | _ -> false ) ; mkAppN (Array {typ}) elts -let mkStruct elts (typ: Typ.t) = +let mkStruct elts (typ : Typ.t) = assert ( match typ with | Tuple {elts= elt_typs} | Struct {elts= elt_typs} -> @@ -377,7 +377,7 @@ let mkCast exp typ = assert (Typ.compatible (typ_of exp) typ) ; mkApp1 (Cast {typ}) exp -let mkConv exp ?(signed= false) typ = +let mkConv exp ?(signed = false) typ = assert (Typ.compatible (typ_of exp) typ) ; mkApp1 (Conv {signed; typ}) exp diff --git a/sledge/src/llair/exp.mli b/sledge/src/llair/exp.mli index 6409a24f3..7520d7793 100644 --- a/sledge/src/llair/exp.mli +++ b/sledge/src/llair/exp.mli @@ -181,7 +181,7 @@ val mkArray : t vector -> Typ.t -> t val mkStruct : t vector -> Typ.t -> t val mkStruct_rec : - (module Hashtbl.Key_plain with type t = 'id) + (module Hashtbl.Key_plain with type t = 'id) -> (id:'id -> t lazy_t vector -> Typ.t -> t) Staged.t (** [mkStruct_rec Id id element_thunks typ] constructs a possibly-cyclic [Struct] value. Cycles are detected using [Id]. The caller of diff --git a/sledge/src/llair/frontend.ml b/sledge/src/llair/frontend.ml index 5b990058e..ac5864785 100644 --- a/sledge/src/llair/frontend.ml +++ b/sledge/src/llair/frontend.ml @@ -15,7 +15,8 @@ let fmt_llblock ff t = Format.pp_print_string ff (Llvm.string_of_llvalue (Llvm.value_of_block t)) (* gather debug locations *) -let (scan_locs: Llvm.llmodule -> unit), (find_loc: Llvm.llvalue -> Loc.t) = +let (scan_locs : Llvm.llmodule -> unit), (find_loc : Llvm.llvalue -> Loc.t) + = let loc_of_global g = Loc.mk ?dir:(Llvm.get_global_debug_loc_directory g) @@ -80,7 +81,8 @@ let (scan_locs: Llvm.llmodule -> unit), (find_loc: Llvm.llvalue -> Loc.t) = in (scan_locs, find_loc) -let (scan_names: Llvm.llmodule -> unit), (find_name: Llvm.llvalue -> string) = +let ( (scan_names : Llvm.llmodule -> unit) + , (find_name : Llvm.llvalue -> string) ) = let name_tbl = Hashtbl.Poly.create () in let scan_name = let scope_tbl = Hashtbl.Poly.create () in @@ -120,19 +122,19 @@ let (scan_names: Llvm.llmodule -> unit), (find_name: Llvm.llvalue -> string) = | Some count -> Hashtbl.set void_tbl ~key:fname ~data:(count + 1) ; Format.sprintf "%s.void.%i" fname count ) - | _ -> + | _ -> ( match Llvm.value_name llv with | "" -> (* anonymous values take the next SSA name *) let name = !next in next := name + 1 ; Int.to_string name - | name -> + | name -> ( match Int.of_string name with | _ -> (* escape to avoid clash with names of anonymous values *) Format.sprintf "\"%s\"" name - | exception _ -> name + | exception _ -> name ) ) in Hashtbl.add_exn name_tbl ~key:llv ~data:name in @@ -385,7 +387,8 @@ and xlate_opcode : Llvm.llvalue -> Llvm.Opcode.t -> Exp.t = in ( match opcode with | BitCast | AddrSpaceCast -> cast () - | Trunc | ZExt | FPToUI | UIToFP | FPTrunc | FPExt | PtrToInt | IntToPtr -> + | Trunc | ZExt | FPToUI | UIToFP | FPTrunc | FPExt | PtrToInt | IntToPtr + -> conv false | SExt | FPToSI | SIToFP -> conv true | ICmp -> ( @@ -547,8 +550,8 @@ let xlate_global : Llvm.llvalue -> Global.t = type pop_thunk = Loc.t -> Llair.inst list -let pop_stack_frame_of_function - : Llvm.llvalue -> Llvm.llbasicblock -> pop_thunk = +let pop_stack_frame_of_function : + Llvm.llvalue -> Llvm.llbasicblock -> pop_thunk = fun func entry_blk -> let append_stack_vars blk vars = Llvm.fold_right_instrs @@ -587,13 +590,14 @@ let landingpad_typs : Llvm.llvalue -> Typ.t * Typ.t * Typ.t = | Tuple {elts} | Struct {elts} -> ( match Vector.to_array elts with | [|i8p'; i32'|] -> - not (Typ.equal Typ.i8p i8p') || not (Typ.equal i32 i32') + (not (Typ.equal Typ.i8p i8p')) || not (Typ.equal i32 i32') | _ -> true ) | _ -> true then todo "landingpad of type other than {i8*, i32}: %a" fmt_llvalue instr () ; let llcontext = - Llvm.(module_context (global_parent (block_parent (instr_parent instr)))) + Llvm.( + module_context (global_parent (block_parent (instr_parent instr)))) in let lli8p = Llvm.(pointer_type (integer_type llcontext 8)) in let ti = Llvm.(named_struct_type llcontext "class.std::type_info") in @@ -616,9 +620,10 @@ let landingpad_arg : Llvm.llvalue -> Var.t = the result of applying [f] to each of the other [PHI] instructions. [pos] is the instruction iterator position before the first non-[PHI] instruction of [blk]. *) -let rev_map_phis - : f:(Llvm.llvalue -> 'a) -> Llvm.llbasicblock - -> 'a option * 'a list * _ Llvm.llpos = +let rev_map_phis : + f:(Llvm.llvalue -> 'a) + -> Llvm.llbasicblock + -> 'a option * 'a list * _ Llvm.llpos = fun ~f blk -> let rec block_args_ found_invoke_pred retn_arg rev_args pos = match (pos : _ Llvm.llpos) with @@ -630,8 +635,8 @@ let rev_map_phis for each predecessor terminated by an invoke instr, this PHI instr takes the value of the invoke's return value. *) let has_invoke_pred, is_retn_arg = - List.fold (Llvm.incoming instr) ~init:(false, true) ~f: - (fun (has_invoke_pred, is_retn_arg) (arg, pred) -> + List.fold (Llvm.incoming instr) ~init:(false, true) + ~f:(fun (has_invoke_pred, is_retn_arg) (arg, pred) -> match Llvm.block_terminator pred with | Some instr -> ( match Llvm.instr_opcode instr with @@ -698,7 +703,8 @@ let return_formal_is_used : Llvm.llvalue -> bool = let need_return_trampoline : Llvm.llvalue -> Llvm.llbasicblock -> bool = fun instr blk -> Option.is_none (fst3 (rev_map_phis blk ~f:Fn.id)) - && Option.is_none (unique_pred blk) && return_formal_is_used instr + && Option.is_none (unique_pred blk) + && return_formal_is_used instr (** [unique_used_invoke_pred blk] is the unique predecessor of [blk], if it is an [Invoke] instruction, whose return value is used. *) @@ -782,9 +788,11 @@ let rec xlate_func_name llv = | InlineAsm -> todo "inline asm: %a" fmt_llvalue llv () | _ -> fail "unknown function: %a" fmt_llvalue llv () -let xlate_instr - : pop_thunk -> Llvm.llvalue - -> ((Llair.inst list * Llair.term -> code) -> code) -> code = +let xlate_instr : + pop_thunk + -> Llvm.llvalue + -> ((Llair.inst list * Llair.term -> code) -> code) + -> code = fun pop instr continue -> [%Trace.call fun pf -> pf "%a" fmt_llvalue instr] ; @@ -1202,7 +1210,7 @@ let xlate_function : Llvm.llvalue -> Llair.func = ( match Llvm.block_begin llf with | Before entry_blk -> let pop = pop_stack_frame_of_function llf entry_blk in - let[@warning "p"] entry_block :: entry_blocks = + let[@warning "p"] (entry_block :: entry_blocks) = xlate_block pop entry_blk in let entry = diff --git a/sledge/src/llair/llair.ml b/sledge/src/llair/llair.ml index ca017efc1..60950df1c 100644 --- a/sledge/src/llair/llair.ml +++ b/sledge/src/llair/llair.ml @@ -139,7 +139,7 @@ module Inst = struct | Memset {dst; byt; len} -> pf "memset %a %a %a;" Exp.fmt dst Exp.fmt byt Exp.fmt len | Alloc {reg; num} -> - let[@warning "p"] Typ.Pointer {elt} = Var.typ reg in + let[@warning "p"] (Typ.Pointer {elt}) = Var.typ reg in pf "alloc %a [%a x %a];" Var.fmt reg Exp.fmt num Typ.fmt elt | Free {ptr} -> pf "free %a;" Exp.fmt ptr | Nondet {reg; msg} -> @@ -337,9 +337,10 @@ module Func = struct let cfg = Vector.empty in mk ~name ~entry ~cfg - let fmt ff ({name; entry= {params; cmnd; term; sort_index}; cfg} as func) = + let fmt ff ({name; entry= {params; cmnd; term; sort_index}; cfg} as func) + = let fmt_if cnd str ff = if cnd then Format.fprintf ff str in - let[@warning "p"] Typ.Pointer {elt= Function {return}} = + let[@warning "p"] (Typ.Pointer {elt= Function {return}}) = Global.typ name in Format.fprintf ff "@[@[%a@[<2>%a%a@]%t@]" @@ -359,8 +360,8 @@ module Block_id = struct (* block labels within a function are unique *) let compare x y = - [%compare : string * Global.t] - (x.lbl, x.parent.name) (y.lbl, y.parent.name) + [%compare: string * Global.t] (x.lbl, x.parent.name) + (y.lbl, y.parent.name) let hash b = Hashtbl.hash (b.lbl, b.parent.name) end @@ -443,16 +444,16 @@ let set_derived_metadata functions = let mk ~typ_defns ~globals ~functions = assert ( - not - (List.contains_dup typ_defns ~compare:(fun (s: Typ.t) (t: Typ.t) -> - match (s, t) with - | ( (Struct {name= n1} | Opaque {name= n1}) - , (Struct {name= n2} | Opaque {name= n2}) ) -> - String.compare n1 n2 - | _ -> Typ.compare s t )) - && not - (List.contains_dup globals ~compare:(fun g1 g2 -> - String.compare (Global.name g1) (Global.name g2) )) + (not + (List.contains_dup typ_defns ~compare:(fun (s : Typ.t) (t : Typ.t) -> + match (s, t) with + | ( (Struct {name= n1} | Opaque {name= n1}) + , (Struct {name= n2} | Opaque {name= n2}) ) -> + String.compare n1 n2 + | _ -> Typ.compare s t ))) + && (not + (List.contains_dup globals ~compare:(fun g1 g2 -> + String.compare (Global.name g1) (Global.name g2) ))) && not (List.contains_dup functions ~compare:(fun f1 f2 -> String.compare (Global.name f1.name) (Global.name f2.name) )) diff --git a/sledge/src/llair/llair.mli b/sledge/src/llair/llair.mli index a61ec10f5..2d72ae432 100644 --- a/sledge/src/llair/llair.mli +++ b/sledge/src/llair/llair.mli @@ -156,8 +156,13 @@ module Term : sig val mkISwitch : ptr:Exp.t -> tbl:jump vector -> loc:Loc.t -> term val mkCall : - func:Exp.t -> args:Exp.t vector -> return:jump -> throw:jump option - -> ignore_result:bool -> loc:Loc.t -> term + func:Exp.t + -> args:Exp.t vector + -> return:jump + -> throw:jump option + -> ignore_result:bool + -> loc:Loc.t + -> term val mkReturn : exp:Exp.t option -> loc:Loc.t -> term diff --git a/sledge/src/llair/loc.ml b/sledge/src/llair/loc.ml index f2cffaf8d..0dcae9b19 100644 --- a/sledge/src/llair/loc.ml +++ b/sledge/src/llair/loc.ml @@ -12,7 +12,7 @@ type t = {dir: string; file: string; line: int; col: int} let none = {dir= ""; file= ""; line= 0; col= 0} -let mk ?(dir= none.dir) ?(file= none.file) ?(col= none.col) ~line = +let mk ?(dir = none.dir) ?(file = none.file) ?(col = none.col) ~line = {dir; file; line; col} let fmt ff {dir; file; line; col} = diff --git a/sledge/src/ppx_trace/ppx_trace.ml b/sledge/src/ppx_trace/ppx_trace.ml index 570df15a8..3872fb85d 100644 --- a/sledge/src/ppx_trace/ppx_trace.ml +++ b/sledge/src/ppx_trace/ppx_trace.ml @@ -38,8 +38,9 @@ module Ast_mapper = Selected_ast.Ast.Ast_mapper let debug = ref false -;; Ppx_driver.add_arg "--debug" (Caml.Arg.Set debug) - ~doc:"Enable debug tracing output" +;; +Ppx_driver.add_arg "--debug" (Caml.Arg.Set debug) + ~doc:"Enable debug tracing output" let rec get_fun_name pat = match pat.ppat_desc with @@ -65,11 +66,11 @@ let vb_stack_with, vb_stack_top = (with_, top) let mapper = - let value_binding (m: Ast_mapper.mapper) vb = + let value_binding (m : Ast_mapper.mapper) vb = vb_stack_with vb.pvb_pat ~f:(fun () -> Ast_mapper.default_mapper.value_binding m vb ) in - let expr (m: Ast_mapper.mapper) exp = + let expr (m : Ast_mapper.mapper) exp = let append_here_args args = let mod_name = evar ~loc:Location.none "Caml.__MODULE__" in let fun_name = @@ -114,4 +115,5 @@ let mapper = let impl = Selected_ast.Ast.map_structure mapper -;; Ppx_driver.register_transformation "trace" ~impl +;; +Ppx_driver.register_transformation "trace" ~impl diff --git a/sledge/src/ppx_trace/ppx_trace.mli b/sledge/src/ppx_trace/ppx_trace.mli index 8c3da9120..271ac3b25 100644 --- a/sledge/src/ppx_trace/ppx_trace.mli +++ b/sledge/src/ppx_trace/ppx_trace.mli @@ -4,4 +4,3 @@ * This source code is licensed under the MIT license found in the * LICENSE file in the root directory of this source tree. *) - diff --git a/sledge/src/sledge.ml b/sledge/src/sledge.ml index 7ff7d7934..3f6630350 100644 --- a/sledge/src/sledge.ml +++ b/sledge/src/sledge.ml @@ -32,4 +32,5 @@ let main ~input ~output = (Caml.Printexc.to_string exn) ) ; Caml.Printexc.raise_with_backtrace exn bt -;; Config.run main +;; +Config.run main diff --git a/sledge/src/sledge.mli b/sledge/src/sledge.mli index 8c3da9120..271ac3b25 100644 --- a/sledge/src/sledge.mli +++ b/sledge/src/sledge.mli @@ -4,4 +4,3 @@ * This source code is licensed under the MIT license found in the * LICENSE file in the root directory of this source tree. *) -