diff --git a/.ocamlformat b/.ocamlformat index a915abd6b..bf589efda 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,3 +1,3 @@ margin 100 sparse true -version 0.4 +version 0.5 diff --git a/Makefile b/Makefile index beec4d0f0..63de7d9df 100644 --- a/Makefile +++ b/Makefile @@ -149,13 +149,13 @@ OCAMLFORMAT_EXE?=ocamlformat fmt: parallel $(OCAMLFORMAT_EXE) -i ::: $$(git diff --name-only $$(git merge-base origin/master HEAD) | grep "\.mli\?$$") -JBUILD_ML:=$(shell find * -name 'jbuild*.in' | grep -v workspace) +JBUILD_ML:=$(shell find * -name 'jbuild*.in' | grep -v workspace | grep -v sledge) .PHONY: fmt_jbuild fmt_jbuild: parallel $(OCAMLFORMAT_EXE) -i ::: $(JBUILD_ML) -SRC_ML:=$(shell find * \( -name _build -or -name facebook-clang-plugins -or -path facebook/dependencies \) -not -prune -or -type f -and -name '*'.ml -or -name '*'.mli 2>/dev/null) +SRC_ML:=$(shell find * \( -name _build -or -name facebook-clang-plugins -or -path facebook/dependencies -or -path sledge/llvm \) -not -prune -or -type f -and -name '*'.ml -or -name '*'.mli 2>/dev/null) .PHONY: fmt_all fmt_all: diff --git a/infer/src/IR/AccessExpression.ml b/infer/src/IR/AccessExpression.ml index c67aacfab..0652c464e 100644 --- a/infer/src/IR/AccessExpression.ml +++ b/infer/src/IR/AccessExpression.ml @@ -16,7 +16,7 @@ type t = | ArrayOffset of t * Typ.t * t list | AddressOf of t | Dereference of t - [@@deriving compare] +[@@deriving compare] (** convert to an AccessPath.t, ignoring AddressOf and Dereference for now *) let rec to_access_path t = @@ -108,7 +108,7 @@ let rec normalize t = match t with | Base _ -> t - | Dereference AddressOf t1 -> + | Dereference (AddressOf t1) -> normalize t1 | FieldOffset (t1, fieldname) -> let t1' = normalize t1 in diff --git a/infer/src/IR/AccessExpression.mli b/infer/src/IR/AccessExpression.mli index 7be8d5b35..37e16957d 100644 --- a/infer/src/IR/AccessExpression.mli +++ b/infer/src/IR/AccessExpression.mli @@ -19,7 +19,7 @@ type t = (* address of operator & *) | Dereference of t (* dereference operator * *) - [@@deriving compare] +[@@deriving compare] val to_access_path : t -> AccessPath.t diff --git a/infer/src/IR/AccessPath.ml b/infer/src/IR/AccessPath.ml index d33f9d988..115fb6dd7 100644 --- a/infer/src/IR/AccessPath.ml +++ b/infer/src/IR/AccessPath.ml @@ -274,7 +274,7 @@ let inner_class_normalize p = | Some ( ( (Var.ProgramVar pvar as root) , ({desc= Tptr (({desc= Tstruct name} as cls), pkind)} as ptr) ) - , (FieldAccess first) :: accesses ) + , FieldAccess first :: accesses ) when Pvar.is_this pvar && Fieldname.Java.is_outer_instance first -> Name.Java.get_outer_class name |> Option.map ~f:(fun outer_name -> @@ -285,7 +285,7 @@ let inner_class_normalize p = (* happens in ctrs only *) | Some ( (Var.ProgramVar pvar, ({desc= Tptr (({desc= Tstruct name} as cls), pkind)} as ptr)) - , (FieldAccess first) :: accesses ) + , FieldAccess first :: accesses ) when is_synthetic_this pvar && Fieldname.Java.is_outer_instance first -> Name.Java.get_outer_class name |> Option.bind ~f:(fun outer_name -> diff --git a/infer/src/IR/AccessPath.mli b/infer/src/IR/AccessPath.mli index 78d541062..0764251a7 100644 --- a/infer/src/IR/AccessPath.mli +++ b/infer/src/IR/AccessPath.mli @@ -16,7 +16,7 @@ type base = Var.t * Typ.t [@@deriving compare] type access = | ArrayAccess of Typ.t * t list (** array element type with list of access paths in index *) | FieldAccess of Typ.Fieldname.t (** field name *) - [@@deriving compare] +[@@deriving compare] (** root var, and a list of accesses. closest to the root var is first that is, x.f.g is representedas (x, [f; g]) *) @@ -92,7 +92,7 @@ module Abs : sig type t = | Abstracted of raw (** abstraction of heap reachable from an access path, e.g. x.f* *) | Exact of raw (** precise representation of an access path, e.g. x.f.g *) - [@@deriving compare] + [@@deriving compare] val equal : t -> t -> bool diff --git a/infer/src/IR/Annot.ml b/infer/src/IR/Annot.ml index 03a2273a6..83bb00e38 100644 --- a/infer/src/IR/Annot.ml +++ b/infer/src/IR/Annot.ml @@ -19,7 +19,7 @@ type parameters = string list [@@deriving compare] type t = { class_name: string (** name of the annotation *) ; parameters: parameters (** currently only one string parameter *) } - [@@deriving compare] +[@@deriving compare] let volatile = {class_name= "volatile"; parameters= []} diff --git a/infer/src/IR/Annot.mli b/infer/src/IR/Annot.mli index 5f3933667..b17c1fa72 100644 --- a/infer/src/IR/Annot.mli +++ b/infer/src/IR/Annot.mli @@ -18,7 +18,7 @@ type parameters = string list type t = { class_name: string (** name of the annotation *) ; parameters: parameters (** currently only one string parameter *) } - [@@deriving compare] +[@@deriving compare] val volatile : t (** annotation for fields marked with the "volatile" keyword *) diff --git a/infer/src/IR/Binop.ml b/infer/src/IR/Binop.ml index 0ff56c60a..ff1f795b9 100644 --- a/infer/src/IR/Binop.ml +++ b/infer/src/IR/Binop.ml @@ -36,7 +36,7 @@ type t = | BOr (** inclusive-or *) | LAnd (** logical and. Does not always evaluate both operands. *) | LOr (** logical or. Does not always evaluate both operands. *) - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] diff --git a/infer/src/IR/Binop.mli b/infer/src/IR/Binop.mli index 96fabad16..dfe324a9a 100644 --- a/infer/src/IR/Binop.mli +++ b/infer/src/IR/Binop.mli @@ -36,7 +36,7 @@ type t = | BOr (** inclusive-or *) | LAnd (** logical and. Does not always evaluate both operands. *) | LOr (** logical or. Does not always evaluate both operands. *) - [@@deriving compare] +[@@deriving compare] val equal : t -> t -> bool diff --git a/infer/src/IR/CallFlags.ml b/infer/src/IR/CallFlags.ml index c9a789907..edeee42a9 100644 --- a/infer/src/IR/CallFlags.ml +++ b/infer/src/IR/CallFlags.ml @@ -22,7 +22,7 @@ type t = ; cf_is_objc_block: bool ; cf_targets: Typ.Procname.t list ; cf_with_block_parameters: bool } - [@@deriving compare] +[@@deriving compare] let pp f cf = if cf.cf_virtual then F.fprintf f " virtual" ; diff --git a/infer/src/IR/CallFlags.mli b/infer/src/IR/CallFlags.mli index b55c23eaa..2db9155ec 100644 --- a/infer/src/IR/CallFlags.mli +++ b/infer/src/IR/CallFlags.mli @@ -22,7 +22,7 @@ type t = ; cf_is_objc_block: bool ; cf_targets: Typ.Procname.t list ; cf_with_block_parameters: bool } - [@@deriving compare] +[@@deriving compare] val pp : F.formatter -> t -> unit diff --git a/infer/src/IR/Cfg.ml b/infer/src/IR/Cfg.ml index 5220fbb1b..79c1b5090 100644 --- a/infer/src/IR/Cfg.ml +++ b/infer/src/IR/Cfg.ml @@ -49,7 +49,7 @@ let iter_all_nodes ?(sorted= false) f cfg = ~f:(fun desc_nodes node -> (pdesc, node) :: desc_nodes) ~init:desc_nodes (Procdesc.get_nodes pdesc) ) cfg [] - |> List.sort ~cmp:[%compare : Procdesc.t * Procdesc.Node.t] + |> List.sort ~compare:[%compare : Procdesc.t * Procdesc.Node.t] |> List.iter ~f:(fun (d, n) -> f d n) @@ -135,12 +135,12 @@ let inline_synthetic_method ret_id etl pdesc loc_call : Sil.instr option = (* setter for static fields *) let instr' = Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, e1, loc_call) in found instr instr' - | Sil.Call (ret_id', Exp.Const Const.Cfun pn, etl', _, cf), _, _ + | Sil.Call (ret_id', Exp.Const (Const.Cfun pn), etl', _, cf), _, _ when Bool.equal (is_none ret_id) (is_none ret_id') && Int.equal (List.length etl') (List.length etl) -> let instr' = Sil.Call (ret_id, Exp.Const (Const.Cfun pn), etl, loc_call, cf) in found instr instr' - | Sil.Call (ret_id', Exp.Const Const.Cfun pn, etl', _, cf), _, _ + | Sil.Call (ret_id', Exp.Const (Const.Cfun pn), etl', _, cf), _, _ when Bool.equal (is_none ret_id) (is_none ret_id') && Int.equal (List.length etl' + 1) (List.length etl) -> let etl1 = @@ -163,7 +163,7 @@ let inline_synthetic_method ret_id etl pdesc loc_call : Sil.instr option = (** Find synthetic (access or bridge) Java methods in the procedure and inline them in the cfg. *) let proc_inline_synthetic_methods cfg pdesc : unit = let instr_inline_synthetic_method = function - | Sil.Call (ret_id, Exp.Const Const.Cfun (Typ.Procname.Java java_pn as pn), etl, loc, _) -> ( + | Sil.Call (ret_id, 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 @@ -172,7 +172,7 @@ let proc_inline_synthetic_methods cfg pdesc : unit = let is_bridge = attributes.is_bridge_method in if is_access || is_bridge || is_synthetic then inline_synthetic_method ret_id etl pd loc else None - | exception Not_found -> + | exception Caml.Not_found -> None ) | _ -> None @@ -201,5 +201,5 @@ let inline_java_synthetic_methods cfg = let pp_proc_signatures fmt cfg = F.fprintf fmt "METHOD SIGNATURES@\n@." ; - let sorted_procs = List.sort ~cmp:Procdesc.compare (get_all_proc_descs cfg) in + let sorted_procs = List.sort ~compare:Procdesc.compare (get_all_proc_descs cfg) in List.iter ~f:(fun pdesc -> F.fprintf fmt "%a@." Procdesc.pp_signature pdesc) sorted_procs diff --git a/infer/src/IR/Const.ml b/infer/src/IR/Const.ml index 9b8f162a6..6e4282d4e 100644 --- a/infer/src/IR/Const.ml +++ b/infer/src/IR/Const.ml @@ -20,7 +20,7 @@ type t = | Cstr of string (** string constants *) | Cfloat of float (** float constants *) | Cclass of Ident.name (** class constant *) - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] diff --git a/infer/src/IR/Const.mli b/infer/src/IR/Const.mli index 34c88b449..3305a12b4 100644 --- a/infer/src/IR/Const.mli +++ b/infer/src/IR/Const.mli @@ -21,7 +21,7 @@ type t = | Cstr of string (** string constants *) | Cfloat of float (** float constants *) | Cclass of Ident.name (** class constant *) - [@@deriving compare] +[@@deriving compare] val equal : t -> t -> bool diff --git a/infer/src/IR/DecompiledExp.ml b/infer/src/IR/DecompiledExp.ml index 583a99ef2..3e36e9552 100644 --- a/infer/src/IR/DecompiledExp.ml +++ b/infer/src/IR/DecompiledExp.ml @@ -50,7 +50,7 @@ let rec to_string = function to_string de1 ^ "[" ^ to_string de2 ^ "]" | Dbinop (op, de1, de2) -> "(" ^ to_string de1 ^ Binop.str Pp.text op ^ to_string de2 ^ ")" - | Dconst Cfun pn + | Dconst (Cfun pn) -> ( let procname_str = Typ.Procname.to_simplified_string pn in match builtin_functions_to_string pn with @@ -78,7 +78,7 @@ let rec to_string = function else Pp.comma_seq pp_arg fmt des in let pp_fun fmt = function - | Dconst Cfun pname -> + | Dconst (Cfun pname) -> let s = match pname with | Typ.Procname.Java pname_java -> @@ -92,7 +92,7 @@ let rec to_string = function in let receiver, args' = match args with - | (Dpvar pv) :: args' when isvirtual && Pvar.is_this pv -> + | Dpvar pv :: args' when isvirtual && Pvar.is_this pv -> (None, args') | a :: args' when isvirtual -> (Some a, args') diff --git a/infer/src/IR/Errlog.ml b/infer/src/IR/Errlog.ml index 3143dff9d..ff39b68e7 100644 --- a/infer/src/IR/Errlog.ml +++ b/infer/src/IR/Errlog.ml @@ -59,9 +59,7 @@ let compute_local_exception_line loc_trace = | _ -> Continue (last_known_step_at_level_zero_opt', line_opt) in - match List.fold_until ~init:(None, None) ~f:compute_local_exception_line loc_trace with - | Finished (_, line_opt) | Stopped_early line_opt -> - line_opt + List.fold_until ~init:(None, None) ~f:compute_local_exception_line ~finish:snd loc_trace type node_id_key = {node_id: int; node_key: Caml.Digest.t} @@ -72,7 +70,7 @@ type err_key = ; err_name: IssueType.t ; err_desc: Localise.error_desc ; severity: string } - [@@deriving compare] +[@@deriving compare] (** Data associated to a specific error *) type err_data = @@ -223,7 +221,7 @@ let add_issue tbl err_key (err_datas: ErrDataSet.t) : bool = else ( ErrLogHash.replace tbl err_key (ErrDataSet.union err_datas current_eds) ; true ) - with Not_found -> + with Caml.Not_found -> ErrLogHash.add tbl err_key err_datas ; true @@ -258,7 +256,7 @@ let log_issue procname ?clang_method_kind err_kind err_log loc (node_id, node_ke in let should_report = Exceptions.equal_visibility error.visibility Exceptions.Exn_user - || Config.developer_mode && exn_developer + || (Config.developer_mode && exn_developer) in ( if exn_developer then let issue = diff --git a/infer/src/IR/Errlog.mli b/infer/src/IR/Errlog.mli index ca7011e31..5c38e3d43 100644 --- a/infer/src/IR/Errlog.mli +++ b/infer/src/IR/Errlog.mli @@ -44,7 +44,7 @@ type err_key = private ; err_name: IssueType.t ; err_desc: Localise.error_desc ; severity: string } - [@@deriving compare] +[@@deriving compare] (** Data associated to a specific error *) type err_data = private diff --git a/infer/src/IR/Exceptions.ml b/infer/src/IR/Exceptions.ml index d1919897a..5c09690e2 100644 --- a/infer/src/IR/Exceptions.ml +++ b/infer/src/IR/Exceptions.ml @@ -17,7 +17,7 @@ type visibility = | Exn_user (** always add to error log *) | Exn_developer (** only add to error log in developer mode *) | Exn_system (** never add to error log *) - [@@deriving compare] +[@@deriving compare] let equal_visibility = [%compare.equal : visibility] @@ -69,8 +69,8 @@ exception Custom_error of string * Localise.error_desc exception Dummy_exception of Localise.error_desc -exception Dangling_pointer_dereference of - PredSymb.dangling_kind option * Localise.error_desc * L.ocaml_pos +exception + Dangling_pointer_dereference of PredSymb.dangling_kind option * Localise.error_desc * L.ocaml_pos exception Deallocate_stack_variable of Localise.error_desc @@ -98,8 +98,9 @@ exception Internal_error of Localise.error_desc exception Java_runtime_exception of Typ.Name.t * string * Localise.error_desc -exception Leak of - bool * Sil.hpred * (visibility * Localise.error_desc) * bool * PredSymb.resource * L.ocaml_pos +exception + Leak of + bool * Sil.hpred * (visibility * Localise.error_desc) * bool * PredSymb.resource * L.ocaml_pos exception Missing_fld of Typ.Fieldname.t * L.ocaml_pos diff --git a/infer/src/IR/Exceptions.mli b/infer/src/IR/Exceptions.mli index c8a3213d2..2c4f0021f 100644 --- a/infer/src/IR/Exceptions.mli +++ b/infer/src/IR/Exceptions.mli @@ -17,7 +17,7 @@ type visibility = | Exn_user (** always add to error log *) | Exn_developer (** only add to error log in developer mode *) | Exn_system (** never add to error log *) - [@@deriving compare] +[@@deriving compare] val equal_visibility : visibility -> visibility -> bool @@ -67,8 +67,9 @@ exception Custom_error of string * Localise.error_desc exception Dummy_exception of Localise.error_desc -exception Dangling_pointer_dereference of - PredSymb.dangling_kind option * Localise.error_desc * Logging.ocaml_pos +exception + Dangling_pointer_dereference of + PredSymb.dangling_kind option * Localise.error_desc * Logging.ocaml_pos exception Deallocate_stack_variable of Localise.error_desc @@ -96,13 +97,14 @@ exception Internal_error of Localise.error_desc exception Java_runtime_exception of Typ.Name.t * string * Localise.error_desc -exception Leak of - bool - * Sil.hpred - * (visibility * Localise.error_desc) - * bool - * PredSymb.resource - * Logging.ocaml_pos +exception + Leak of + bool + * Sil.hpred + * (visibility * Localise.error_desc) + * bool + * PredSymb.resource + * Logging.ocaml_pos exception Missing_fld of Typ.Fieldname.t * Logging.ocaml_pos diff --git a/infer/src/IR/Exp.ml b/infer/src/IR/Exp.ml index 39d7c9ed1..4eeb50168 100644 --- a/infer/src/IR/Exp.ml +++ b/infer/src/IR/Exp.ml @@ -48,7 +48,7 @@ and t = (** A field offset, the type is the surrounding struct type *) | Lindex of t * t (** An array index offset: [exp1\[exp2\]] *) | Sizeof of sizeof_data - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] @@ -74,11 +74,11 @@ module Hash = Hashtbl.Make (struct let hash = hash end) -let is_null_literal = function Const Cint n -> IntLit.isnull n | _ -> false +let is_null_literal = function Const (Cint n) -> IntLit.isnull n | _ -> false let is_this = function Lvar pvar -> Pvar.is_this pvar | _ -> false -let is_zero = function Const Cint n -> IntLit.iszero n | _ -> false +let is_zero = function Const (Cint n) -> IntLit.iszero n | _ -> false (** {2 Utility Functions for Expressions} *) diff --git a/infer/src/IR/Exp.mli b/infer/src/IR/Exp.mli index aefe78b80..803e1c60b 100644 --- a/infer/src/IR/Exp.mli +++ b/infer/src/IR/Exp.mli @@ -42,7 +42,7 @@ and t = (** A field offset, the type is the surrounding struct type *) | Lindex of t * t (** An array index offset: [exp1\[exp2\]] *) | Sizeof of sizeof_data - [@@deriving compare] +[@@deriving compare] val equal : t -> t -> bool (** Equality for expressions. *) diff --git a/infer/src/IR/HilExp.ml b/infer/src/IR/HilExp.ml index 39004e416..58328edbc 100644 --- a/infer/src/IR/HilExp.ml +++ b/infer/src/IR/HilExp.ml @@ -20,7 +20,7 @@ type t = | Constant of Const.t | Cast of Typ.t * t | Sizeof of Typ.t * t option - [@@deriving compare] +[@@deriving compare] let rec pp fmt = function | AccessExpression access_expr -> @@ -34,7 +34,7 @@ let rec pp fmt = function | Closure (pname, captured) -> let pp_item fmt (base, exp) = match exp with - | AccessExpression Base b when AccessPath.equal_base b base -> + | AccessExpression (Base b) when AccessPath.equal_base b base -> F.fprintf fmt "%a captured" AccessPath.pp_base b | _ -> F.fprintf fmt "%a captured as %a" AccessPath.pp_base base pp exp @@ -70,19 +70,19 @@ let rec get_typ tenv = function None ) | Exception t -> get_typ tenv t - | Closure _ | Constant Cfun _ -> + | Closure _ | Constant (Cfun _) -> (* We don't have a way to represent function types *) None - | Constant Cint _ -> + | Constant (Cint _) -> (* TODO: handle signedness *) Some (Typ.mk (Typ.Tint Typ.IInt)) - | Constant Cfloat _ -> + | Constant (Cfloat _) -> Some (Typ.mk (Typ.Tfloat Typ.FFloat)) - | Constant Cclass _ -> + | Constant (Cclass _) -> (* TODO: this only happens in Java. We probably need to change it to `Cclass of Typ.Name.t` to give a useful result here *) None - | Constant Cstr _ -> + | Constant (Cstr _) -> (* TODO: this will need to behave differently depending on whether we're in C++ or Java *) None | Cast (typ, _) -> @@ -171,7 +171,7 @@ let of_sil ~include_array_indexes ~f_resolve_id ~add_deref exp typ = ( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0) , fld , root_exp_typ )) typ ) - | Lindex (Const Cstr s, index_exp) -> + | 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 analysis, you should probably be using SIL. this is unsound if the code modifies the @@ -201,11 +201,11 @@ let of_sil ~include_array_indexes ~f_resolve_id ~add_deref exp typ = of_sil_ exp typ -let is_null_literal = function Constant Cint n -> IntLit.isnull n | _ -> false +let is_null_literal = function Constant (Cint n) -> IntLit.isnull n | _ -> false let rec eval_arithmetic_binop op e1 e2 = match (eval e1, eval e2) with - | Some Const.Cint i1, Some Const.Cint i2 -> + | Some (Const.Cint i1), Some (Const.Cint i2) -> Some (Const.Cint (op i1 i2)) | _ -> None diff --git a/infer/src/IR/HilExp.mli b/infer/src/IR/HilExp.mli index d431e5851..ca494101d 100644 --- a/infer/src/IR/HilExp.mli +++ b/infer/src/IR/HilExp.mli @@ -22,7 +22,7 @@ type t = | Sizeof of Typ.t * t option (** C-style sizeof(), and also used to treate a type as an expression. Refer to [Exp] module for canonical documentation *) - [@@deriving compare] +[@@deriving compare] val pp : F.formatter -> t -> unit diff --git a/infer/src/IR/HilInstr.ml b/infer/src/IR/HilInstr.ml index 4f6c973f7..260c8d05f 100644 --- a/infer/src/IR/HilInstr.ml +++ b/infer/src/IR/HilInstr.ml @@ -24,7 +24,7 @@ type t = | Assign of AccessExpression.t * HilExp.t * Location.t | Assume of HilExp.t * [`Then | `Else] * Sil.if_kind * Location.t | Call of AccessPath.base option * call * HilExp.t list * CallFlags.t * Location.t - [@@deriving compare] +[@@deriving compare] let pp fmt = function | Assign (access_expr, exp, loc) -> @@ -67,7 +67,7 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) = analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc | Call ( Some (ret_id, _) - , Const Cfun callee_pname + , Const (Cfun callee_pname) , (target_exp, _) :: (Sizeof {typ= cast_typ}, _) :: _ , loc , _ ) @@ -96,7 +96,7 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) = L.(die InternalError) "Invalid pointer arithmetic expression %a used as LHS at %a" Exp.pp lhs_exp Location.pp_file_pos loc ) - | Constant Const.Cint i -> + | 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 *) let dummy_base_var = @@ -112,7 +112,7 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) = let hil_ret = Option.map ~f:(fun (ret_id, ret_typ) -> (Var.of_id ret_id, ret_typ)) ret_opt in let hil_call = match exp_of_sil call_exp (Typ.mk Tvoid) with - | Constant Cfun procname | Closure (procname, _) -> + | Constant (Cfun procname) | Closure (procname, _) -> Direct procname | AccessExpression access_expr -> Indirect access_expr diff --git a/infer/src/IR/HilInstr.mli b/infer/src/IR/HilInstr.mli index 91f39fc23..37d38e625 100644 --- a/infer/src/IR/HilInstr.mli +++ b/infer/src/IR/HilInstr.mli @@ -20,7 +20,7 @@ type t = (** Assumed expression, true_branch boolean, source of the assume (conditional, ternary, etc.) *) | Call of AccessPath.base option * call * HilExp.t list * CallFlags.t * Location.t (** Var to hold the return if it exists, call expression, formals *) - [@@deriving compare] +[@@deriving compare] val pp : F.formatter -> t -> unit diff --git a/infer/src/IR/Ident.ml b/infer/src/IR/Ident.ml index f43ba6203..d76d97349 100644 --- a/infer/src/IR/Ident.ml +++ b/infer/src/IR/Ident.ml @@ -54,7 +54,7 @@ type kind = | KFootprint | KNormal | KPrimed - [@@deriving compare] +[@@deriving compare] let kfootprint = KFootprint @@ -142,7 +142,7 @@ module NameGenerator = struct let stamp = NameHash.find !name_map name in NameHash.replace !name_map name (stamp + 1) ; stamp + 1 - with Not_found -> + with Caml.Not_found -> NameHash.add !name_map name 0 ; 0 in @@ -155,7 +155,7 @@ module NameGenerator = struct let curr_stamp = NameHash.find !name_map name in let new_stamp = max curr_stamp stamp in NameHash.replace !name_map name new_stamp - with Not_found -> NameHash.add !name_map name stamp + with Caml.Not_found -> NameHash.add !name_map name stamp end (** Name used for the return variable *) diff --git a/infer/src/IR/Io_infer.ml b/infer/src/IR/Io_infer.ml index 9bcfa1555..2824614c0 100644 --- a/infer/src/IR/Io_infer.ml +++ b/infer/src/IR/Io_infer.ml @@ -101,10 +101,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e let open_out source path = let full_fname = get_full_fname source path in let fd = - Unix.openfile - (DB.filename_to_string full_fname) - ~mode:Unix.([O_WRONLY; O_APPEND]) - ~perm:0o777 + Unix.openfile (DB.filename_to_string full_fname) ~mode:Unix.[O_WRONLY; O_APPEND] ~perm:0o777 in let outc = Unix.out_channel_of_descr fd in let fmt = F.formatter_of_out_channel outc in @@ -156,8 +153,9 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e in F.asprintf "%s_%dnode%d preds:%a succs:%a exn:%a \ - %s%s" style_class descr id id (Pp.seq F.pp_print_int) preds - (Pp.seq F.pp_print_int) succs (Pp.seq F.pp_print_int) exn description + %s%s" + style_class descr id id (Pp.seq F.pp_print_int) preds (Pp.seq F.pp_print_int) succs + (Pp.seq F.pp_print_int) exn description (if not isvisited then "\nNOT VISITED" else "") in pp_link ~path:(path_to_root @ ["nodes"; node_fname]) fmt node_text diff --git a/infer/src/IR/LintIssues.ml b/infer/src/IR/LintIssues.ml index 8d91e56ad..4aee42ce4 100644 --- a/infer/src/IR/LintIssues.ml +++ b/infer/src/IR/LintIssues.ml @@ -16,7 +16,7 @@ let errLogMap = ref Typ.Procname.Map.empty let exists_issues () = not (Typ.Procname.Map.is_empty !errLogMap) let get_err_log procname = - try Typ.Procname.Map.find procname !errLogMap with Not_found -> + try Typ.Procname.Map.find procname !errLogMap with Caml.Not_found -> let errlog = Errlog.empty () in errLogMap := Typ.Procname.Map.add procname errlog !errLogMap ; errlog @@ -42,19 +42,19 @@ let load_issues_to_errlog_map dir = let file = DB.filename_from_string (Filename.concat issues_dir issues_file) in match load_issues file with | Some map -> - errLogMap - := Typ.Procname.Map.merge - (fun _ issues1 issues2 -> - match (issues1, issues2) with - | Some issues1, Some issues2 -> - Errlog.update issues1 issues2 ; Some issues1 - | Some issues1, None -> - Some issues1 - | None, Some issues2 -> - Some issues2 - | None, None -> - None ) - !errLogMap map + errLogMap := + Typ.Procname.Map.merge + (fun _ issues1 issues2 -> + match (issues1, issues2) with + | Some issues1, Some issues2 -> + Errlog.update issues1 issues2 ; Some issues1 + | Some issues1, None -> + Some issues1 + | None, Some issues2 -> + Some issues2 + | None, None -> + None ) + !errLogMap map | None -> () in diff --git a/infer/src/IR/Localise.ml b/infer/src/IR/Localise.ml index 4fa878074..8043d4928 100644 --- a/infer/src/IR/Localise.ml +++ b/infer/src/IR/Localise.ml @@ -59,9 +59,8 @@ module Tags = struct let get tags tag = List.Assoc.find ~equal:String.equal tags tag end -type error_desc = - {descriptions: string list; tags: Tags.t; dotty: string option} - [@@deriving compare] +type error_desc = {descriptions: string list; tags: Tags.t; dotty: string option} +[@@deriving compare] (** empty error description *) let no_desc : error_desc = {descriptions= []; tags= []; dotty= None} @@ -115,7 +114,7 @@ let error_desc_set_bucket err_desc bucket = let error_desc_is_reportable_bucket err_desc = let issue_bucket = error_desc_get_bucket err_desc in - let high_buckets = BucketLevel.([b1; b2]) in + let high_buckets = BucketLevel.[b1; b2] in Option.value_map issue_bucket ~default:false ~f:(fun b -> List.mem ~equal:String.equal high_buckets b ) @@ -126,7 +125,9 @@ let get_value_line_tag tags = let value = snd (List.find_exn ~f:(fun (tag, _) -> String.equal tag Tags.value) tags) in let line = snd (List.find_exn ~f:(fun (tag, _) -> String.equal tag Tags.line) tags) in Some [value; line] - with Not_found -> None + with + | Not_found_s _ | Caml.Not_found -> + None (** extract from desc a value on which to apply polymorphic hash and equality *) @@ -260,7 +261,8 @@ let deref_str_nil_argument_in_variadic_method pn total_args arg_number = let problem_str = Printf.sprintf "could be %s which results in a call to %s with %d arguments instead of %d (%s indicates \ - that the last argument of this variadic %s has been reached)" nil_null + that the last argument of this variadic %s has been reached)" + nil_null (Typ.Procname.to_simplified_string pn) arg_number (total_args - 1) nil_null function_method in @@ -390,8 +392,9 @@ let desc_unsafe_guarded_by_access accessed_fld guarded_by_str loc = "The field %a is annotated with %a, but the lock %a is not held during the access to the \ field %s. Since the current method is non-private, it can be called from outside the \ current class without synchronization. Consider wrapping the access in a %s block or \ - making the method private." MF.pp_monospaced accessed_fld_str MF.pp_monospaced annot_str - MF.pp_monospaced guarded_by_str line_info syncronized_str + making the method private." + MF.pp_monospaced accessed_fld_str MF.pp_monospaced annot_str MF.pp_monospaced guarded_by_str + line_info syncronized_str in {no_desc with descriptions= [msg]} @@ -440,13 +443,13 @@ let access_desc access_opt = match access_opt with | None -> [] - | Some Last_accessed (n, _) -> + | Some (Last_accessed (n, _)) -> let line_str = string_of_int n in ["last accessed on line " ^ line_str] - | Some Last_assigned (n, _) -> + | Some (Last_assigned (n, _)) -> let line_str = string_of_int n in ["last assigned on line " ^ line_str] - | Some Returned_from_call _ -> + | Some (Returned_from_call _) -> [] | Some Initialized_automatically -> ["initialized automatically"] @@ -455,7 +458,7 @@ let access_desc access_opt = let dereference_string proc_name deref_str value_str access_opt loc = let tags = deref_str.tags in Tags.update tags Tags.value value_str ; - let is_call_access = match access_opt with Some Returned_from_call _ -> true | _ -> false in + let is_call_access = match access_opt with Some (Returned_from_call _) -> true | _ -> false in let value_desc = String.concat ~sep:"" [ (match deref_str.value_pre with Some s -> s ^ " " | _ -> "") @@ -662,14 +665,14 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc in let typ_str = match hpred_type_opt with - | Some Exp.Sizeof {typ= {desc= Tstruct name}} when Typ.Name.is_class name -> + | Some (Exp.Sizeof {typ= {desc= Tstruct name}}) when Typ.Name.is_class name -> " of type " ^ MF.monospaced_to_string (Typ.Name.name name) ^ " " | _ -> " " in let desc_str = match resource_opt with - | Some PredSymb.Rmemory _ -> + | Some (PredSymb.Rmemory _) -> mem_dyn_allocated ^ to_ ^ value_str | Some PredSymb.Rfile -> "resource" ^ typ_str ^ "acquired" ^ to_ ^ value_str @@ -686,7 +689,7 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc let is_not_rxxx_after = let rxxx = match resource_opt with - | Some PredSymb.Rmemory _ -> + | Some (PredSymb.Rmemory _) -> reachable | Some PredSymb.Rfile | Some PredSymb.Rlock -> released diff --git a/infer/src/IR/Localise.mli b/infer/src/IR/Localise.mli index 7afc37f28..f991cfd2d 100644 --- a/infer/src/IR/Localise.mli +++ b/infer/src/IR/Localise.mli @@ -17,9 +17,8 @@ module Tags : sig end (** description field of error messages *) -type error_desc = - {descriptions: string list; tags: Tags.t; dotty: string option} - [@@deriving compare] +type error_desc = {descriptions: string list; tags: Tags.t; dotty: string option} +[@@deriving compare] val no_desc : error_desc (** empty error description *) diff --git a/infer/src/IR/PredSymb.ml b/infer/src/IR/PredSymb.ml index fbae0af67..a2fa5ea3f 100644 --- a/infer/src/IR/PredSymb.ml +++ b/infer/src/IR/PredSymb.ml @@ -14,9 +14,8 @@ open! IStd module L = Logging module F = Format -type func_attribute = - | FA_sentinel of int * int (** __attribute__((sentinel(int, int))) *) - [@@deriving compare] +type func_attribute = FA_sentinel of int * int (** __attribute__((sentinel(int, int))) *) +[@@deriving compare] let pp_func_attribute fmt = function FA_sentinel (i, j) -> F.fprintf fmt "sentinel(%d,%d)" i j @@ -39,7 +38,7 @@ let string_of_access = function (** Return the value of the FA_sentinel attribute in [attr_list] if it is found *) let get_sentinel_func_attribute_value attr_list = match attr_list with - | (FA_sentinel (sentinel, null_pos)) :: _ -> + | FA_sentinel (sentinel, null_pos) :: _ -> Some (sentinel, null_pos) | [] -> None @@ -50,7 +49,7 @@ type mem_kind = | Mnew (** memory allocated with new *) | Mnew_array (** memory allocated with new[] *) | Mobjc (** memory allocated with objective-c alloc *) - [@@deriving compare] +[@@deriving compare] (** resource that can be allocated *) type resource = Rmemory of mem_kind | Rfile | Rignore | Rlock [@@deriving compare] @@ -67,7 +66,7 @@ type dangling_kind = (** pointer is dangling because it is the address of a stack variable which went out of scope *) | DAminusone (** pointer is -1 *) - [@@deriving compare] +[@@deriving compare] (** position in a path: proc name, node id *) type path_pos = Typ.Procname.t * int [@@deriving compare] @@ -124,7 +123,7 @@ type t = | Aunsubscribed_observer (** denotes an object unsubscribed from observers of a notification center *) | Awont_leak (** value do not participate in memory leak analysis *) - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] @@ -163,7 +162,7 @@ type category = | ACretval | ACobserver | ACwontleak - [@@deriving compare] +[@@deriving compare] let equal_category = [%compare.equal : category] diff --git a/infer/src/IR/PredSymb.mli b/infer/src/IR/PredSymb.mli index fe1b565f5..afb78275f 100644 --- a/infer/src/IR/PredSymb.mli +++ b/infer/src/IR/PredSymb.mli @@ -35,7 +35,7 @@ type mem_kind = | Mnew (** memory allocated with new *) | Mnew_array (** memory allocated with new[] *) | Mobjc (** memory allocated with objective-c alloc *) - [@@deriving compare] +[@@deriving compare] (** resource that can be allocated *) type resource = Rmemory of mem_kind | Rfile | Rignore | Rlock [@@deriving compare] @@ -89,7 +89,7 @@ type t = | Aunsubscribed_observer (** denotes an object unsubscribed from observers of a notification center *) | Awont_leak (** value do not participate in memory leak analysis *) - [@@deriving compare] +[@@deriving compare] val equal : t -> t -> bool @@ -110,7 +110,7 @@ type category = | ACretval | ACobserver | ACwontleak - [@@deriving compare] +[@@deriving compare] val equal_category : category -> category -> bool diff --git a/infer/src/IR/ProcAttributes.ml b/infer/src/IR/ProcAttributes.ml index f564b2f73..a7f37b722 100644 --- a/infer/src/IR/ProcAttributes.ml +++ b/infer/src/IR/ProcAttributes.ml @@ -31,7 +31,7 @@ type clang_method_kind = | OBJC_CLASS | BLOCK | C_FUNCTION - [@@deriving compare] +[@@deriving compare] let equal_clang_method_kind = [%compare.equal : clang_method_kind] @@ -51,10 +51,8 @@ let string_of_clang_method_kind = function (** Type for ObjC accessors *) -type objc_accessor_type = - | Objc_getter of Typ.Struct.field - | Objc_setter of Typ.Struct.field - [@@deriving compare] +type objc_accessor_type = Objc_getter of Typ.Struct.field | Objc_setter of Typ.Struct.field +[@@deriving compare] let kind_of_objc_accessor_type accessor = match accessor with Objc_getter _ -> "getter" | Objc_setter _ -> "setter" @@ -114,7 +112,7 @@ type t = ; proc_name: Typ.Procname.t (** name of the procedure *) ; ret_type: Typ.t (** return type *) ; source_file_captured: SourceFile.t (** source file where the procedure was captured *) } - [@@deriving compare] +[@@deriving compare] let default proc_name = { access= PredSymb.Default diff --git a/infer/src/IR/ProcAttributes.mli b/infer/src/IR/ProcAttributes.mli index 5f2211f2a..18a2d44c8 100644 --- a/infer/src/IR/ProcAttributes.mli +++ b/infer/src/IR/ProcAttributes.mli @@ -21,23 +21,21 @@ type clang_method_kind = | OBJC_CLASS | BLOCK | C_FUNCTION - [@@deriving compare] +[@@deriving compare] val equal_clang_method_kind : clang_method_kind -> clang_method_kind -> bool val string_of_clang_method_kind : clang_method_kind -> string -type objc_accessor_type = - | Objc_getter of Typ.Struct.field - | Objc_setter of Typ.Struct.field - [@@deriving compare] +type objc_accessor_type = Objc_getter of Typ.Struct.field | Objc_setter of Typ.Struct.field +[@@deriving compare] val kind_of_objc_accessor_type : objc_accessor_type -> string type var_attribute = | Modify_in_block (* __block attribute of Objective-C variables, means that it will be modified inside a block *) - [@@deriving compare] +[@@deriving compare] val var_attribute_equal : var_attribute -> var_attribute -> bool (** Equality for var_attribute *) @@ -72,7 +70,7 @@ type t = ; proc_name: Typ.Procname.t (** name of the procedure *) ; ret_type: Typ.t (** return type *) ; source_file_captured: SourceFile.t (** source file where the procedure was captured *) } - [@@deriving compare] +[@@deriving compare] val default : Typ.Procname.t -> t (** Create a proc_attributes with default values. *) diff --git a/infer/src/IR/Procdesc.ml b/infer/src/IR/Procdesc.ml index 28d7e36ce..b3410acfa 100644 --- a/infer/src/IR/Procdesc.ml +++ b/infer/src/IR/Procdesc.ml @@ -26,7 +26,7 @@ module Node = struct | Join_node | Prune_node of bool * Sil.if_kind * string (** (true/false branch, if_kind, comment) *) | Skip_node of string - [@@deriving compare] + [@@deriving compare] let equal_nodekind = [%compare.equal : nodekind] @@ -221,7 +221,7 @@ type t = ; mutable start_node: Node.t (** start node of this procedure *) ; mutable exit_node: Node.t (** exit node of this procedure *) ; mutable loop_heads: NodeSet.t option (** loop head nodes of this procedure *) } - [@@deriving compare] +[@@deriving compare] let from_proc_attributes attributes = let pname_opt = Some attributes.ProcAttributes.proc_name in @@ -428,9 +428,9 @@ let pp_variable_list fmt etl = let pp_objc_accessor fmt accessor = match accessor with - | Some ProcAttributes.Objc_getter field -> + | Some (ProcAttributes.Objc_getter field) -> Format.fprintf fmt "Getter of %a, " (Typ.Struct.pp_field Pp.text) field - | Some ProcAttributes.Objc_setter field -> + | Some (ProcAttributes.Objc_setter field) -> Format.fprintf fmt "Setter of %a, " (Typ.Struct.pp_field Pp.text) field | None -> () @@ -520,7 +520,7 @@ let convert_cfg ~callee_pdesc ~resolved_pdesc ~f_instr_list = [] | node :: other_node -> let converted_node = - try NodeMap.find node !node_map with Not_found -> + try NodeMap.find node !node_map with Caml.Not_found -> let new_node = convert_node node and successors = Node.get_succs node and exn_nodes = Node.get_exn node in @@ -553,7 +553,7 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = in let subst_map = ref Ident.Map.empty in let redirect_typename origin_id = - try Some (Ident.Map.find origin_id !subst_map) with Not_found -> None + try Some (Ident.Map.find origin_id !subst_map) with Caml.Not_found -> None in let convert_instr instrs = function | Sil.Load @@ -562,7 +562,7 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = , {Typ.desc= Tptr ({desc= Tstruct origin_typename}, Pk_pointer)} , loc ) -> let specialized_typname = - try Mangled.Map.find (Pvar.get_name origin_pvar) substitutions with Not_found -> + try Mangled.Map.find (Pvar.get_name origin_pvar) substitutions with Caml.Not_found -> origin_typename in subst_map := Ident.Map.add id specialized_typname !subst_map ; @@ -570,7 +570,7 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = | 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 Not_found -> origin_typ + with Caml.Not_found -> origin_typ in Sil.Load (id, convert_exp origin_exp, updated_typ, loc) :: instrs | Sil.Load (id, origin_exp, origin_typ, loc) -> @@ -582,7 +582,7 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = set_instr :: instrs | Sil.Call ( return_ids - , Exp.Const Const.Cfun Typ.Procname.Java callee_pname_java + , Exp.Const (Const.Cfun (Typ.Procname.Java callee_pname_java)) , (Exp.Var id, _) :: origin_args , loc , call_flags ) @@ -715,7 +715,8 @@ let specialize_with_block_args_instrs resolved_pdesc substitutions = in let instrs = remove_temps_instrs :: call_instr :: load_instrs @ instrs in (instrs, id_map) - with Not_found -> convert_generic_call return_ids (Exp.Var id) origin_args loc call_flags ) + with Caml.Not_found -> + convert_generic_call return_ids (Exp.Var id) origin_args loc call_flags ) | Sil.Call (return_ids, origin_call_exp, origin_args, loc, call_flags) -> convert_generic_call return_ids origin_call_exp origin_args loc call_flags | Sil.Prune (origin_exp, loc, is_true_branch, if_kind) -> @@ -775,8 +776,8 @@ let specialize_with_block_args callee_pdesc pname_with_block_args block_args = let _, captured = Mangled.Map.find param_name substitutions in append_no_duplicates_formals_and_annot acc (List.map captured ~f:(fun captured_var -> (captured_var, Annot.Item.empty))) - with Not_found -> append_no_duplicates_formals_and_annot acc [((param_name, typ), annot)] - ) + with Caml.Not_found -> + append_no_duplicates_formals_and_annot acc [((param_name, typ), annot)] ) in List.unzip new_formals_blocks_captured_vars_with_annots in @@ -788,7 +789,8 @@ let specialize_with_block_args callee_pdesc pname_with_block_args block_args = | None -> Logging.die InternalError "specialize_with_block_args ahould only be called with defined procedures, but we \ - cannot find the captured file of procname %a" Typ.Procname.pp pname + cannot find the captured file of procname %a" + Typ.Procname.pp pname in let resolved_attributes = { callee_attributes with diff --git a/infer/src/IR/Procdesc.mli b/infer/src/IR/Procdesc.mli index 6352bb510..7734af750 100644 --- a/infer/src/IR/Procdesc.mli +++ b/infer/src/IR/Procdesc.mli @@ -28,7 +28,7 @@ module Node : sig | Join_node | Prune_node of bool * Sil.if_kind * string (** (true/false branch, if_kind, comment) *) | Skip_node of string - [@@deriving compare] + [@@deriving compare] val equal_nodekind : nodekind -> nodekind -> bool diff --git a/infer/src/IR/ProcnameDispatcher.ml b/infer/src/IR/ProcnameDispatcher.ml index a352d0278..11bc9953d 100644 --- a/infer/src/IR/ProcnameDispatcher.ml +++ b/infer/src/IR/ProcnameDispatcher.ml @@ -11,11 +11,13 @@ open! IStd (** To be used in 'list_constraint *) type accept_more - and end_of_list + +and end_of_list (** To be used in 'emptyness *) type empty - and non_empty + +and non_empty (* Type shorthands *) @@ -344,11 +346,7 @@ module Common = struct 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 + match template_args with Typ.TType _ :: rest -> Some (f, captured_types, rest) | _ -> None in {eat_template_arg; add_marker= add_no_marker} @@ -367,7 +365,7 @@ module Common = struct fun marker -> let eat_template_arg (f, captured_types, template_args) = match template_args with - | (Typ.TType ty) :: rest -> + | Typ.TType ty :: rest -> let captured_types () = (ty, captured_types ()) in Some (f ty, captured_types, rest) | _ -> @@ -388,11 +386,7 @@ module Common = struct , 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 + match template_args with Typ.TInt i :: rest -> Some (f i, captured_types, rest) | _ -> None in {eat_template_arg; add_marker= add_no_marker} diff --git a/infer/src/IR/Pvar.ml b/infer/src/IR/Pvar.ml index a90c5c8cd..c3596e1e4 100644 --- a/infer/src/IR/Pvar.ml +++ b/infer/src/IR/Pvar.ml @@ -28,7 +28,7 @@ type pvar_kind = (** global variable: translation unit + is it compile constant? + is it POD? + is it a static local? + is it a static global *) | Seed_var (** variable used to store the initial value of formal parameters *) - [@@deriving compare] +[@@deriving compare] (** Names for program variables. *) type t = {pv_hash: int; pv_name: Mangled.t; pv_kind: pvar_kind} [@@deriving compare] @@ -153,7 +153,7 @@ let is_frontend_tmp pvar = (* Check whether the program variable is a temporary one generated by Sawja, javac, or some other bytecode/name generation pass. valid java identifiers cannot contain `$` *) let is_bytecode_tmp name = - String.contains name '$' && not (String.contains name '_') + (String.contains name '$' && not (String.contains name '_')) || String.is_prefix ~prefix:"CatchVar" name in (* Check whether the program variable is generated by [mk_tmp] *) diff --git a/infer/src/IR/Sil.ml b/infer/src/IR/Sil.ml index 9f32541f2..871531bdd 100644 --- a/infer/src/IR/Sil.ml +++ b/infer/src/IR/Sil.ml @@ -26,7 +26,7 @@ type if_kind = | Ik_land_lor (** obtained from translation of && or || *) | Ik_while | Ik_switch - [@@deriving compare] +[@@deriving compare] (** An instruction. *) type instr = @@ -53,7 +53,7 @@ type instr = | Abstract of Location.t (** apply abstraction *) | Remove_temps of Ident.t list * Location.t (** remove temporaries *) | Declare_locals of (Pvar.t * Typ.t) list * Location.t (** declare local variables *) - [@@deriving compare] +[@@deriving compare] let equal_instr = [%compare.equal : instr] @@ -78,7 +78,7 @@ type atom = | Aneq of Exp.t * Exp.t (** disequality *) | Apred of PredSymb.t * Exp.t list (** predicate symbol applied to exps *) | Anpred of PredSymb.t * Exp.t list (** negated predicate symbol applied to exps *) - [@@deriving compare] +[@@deriving compare] let equal_atom = [%compare.equal : atom] @@ -94,7 +94,7 @@ let atom_has_local_addr a = type lseg_kind = | Lseg_NE (** nonempty (possibly circular) listseg *) | Lseg_PE (** possibly empty (possibly circular) listseg *) - [@@deriving compare] +[@@deriving compare] let equal_lseg_kind = [%compare.equal : lseg_kind] @@ -118,7 +118,7 @@ type inst = | Itaint | Iupdate of zero_flag * null_case_flag * int * PredSymb.path_pos | Ireturn_from_call of int - [@@deriving compare] +[@@deriving compare] let equal_inst = [%compare.equal : inst] @@ -134,7 +134,7 @@ type 'inst strexp0 = For instance, x |->[10 | e1: v1] implies that e1 <= 9. Second, if two indices appear in an array, they should be different. For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) - [@@deriving compare] +[@@deriving compare] type strexp = inst strexp0 @@ -162,11 +162,11 @@ type 'inst hpred0 = primed identifiers, and include all the free primed identifiers in body. body should not contain any non - primed identifiers or program variables (i.e. pvars). *) - [@@deriving compare] +[@@deriving compare] and 'inst hpara0 = {root: Ident.t; next: Ident.t; svars: Ident.t list; evars: Ident.t list; body: 'inst hpred0 list} - [@@deriving compare] +[@@deriving compare] (** parameter for the higher-order doubly-linked list predicates. Assume that all the free identifiers in body_dll should belong to @@ -178,7 +178,7 @@ and 'inst hpara_dll0 = ; svars_dll: Ident.t list ; evars_dll: Ident.t list ; body_dll: 'inst hpred0 list } - [@@deriving compare] +[@@deriving compare] type hpred = inst hpred0 @@ -434,10 +434,11 @@ let pp_instr pe0 f instr = let add_with_block_parameters_flag instr = match instr with - | Call (ret_id, Exp.Const Const.Cfun pname, arg_ts, loc, cf) -> - if List.exists ~f:(fun (exp, _) -> Exp.is_objc_block_closure exp) arg_ts - && Typ.Procname.is_clang pname - (* to be extended to other methods *) + | Call (ret_id, Exp.Const (Const.Cfun pname), arg_ts, loc, cf) -> + if + List.exists ~f:(fun (exp, _) -> Exp.is_objc_block_closure exp) arg_ts + && Typ.Procname.is_clang pname + (* to be extended to other methods *) then let cf' = {cf with cf_with_block_parameters= true} in Call (ret_id, Exp.Const (Const.Cfun pname), arg_ts, loc, cf') @@ -459,7 +460,7 @@ let pp_instr_list pe fmt instrs = let pp_atom pe0 f a = let pe, changed = color_pre_wrapper pe0 f a in ( match a with - | Aeq (BinOp (op, e1, e2), Const Cint i) when IntLit.isone i -> + | Aeq (BinOp (op, e1, e2), Const (Cint i)) when IntLit.isone i -> F.fprintf f "%a" (pp_exp_printenv pe) (Exp.BinOp (op, e1, e2)) | Aeq (e1, e2) -> F.fprintf f "%a = %a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 @@ -1085,8 +1086,9 @@ let hpred_free_vars h = Sequence.Generator.run (hpred_gen_free_vars h) the prop. The function faults in the re - execution mode, as an internal check of the tool. *) let array_clean_new_index footprint_part new_idx = assert (not (footprint_part && not !Config.footprint)) ; - if footprint_part - && Exp.free_vars new_idx |> Sequence.exists ~f:(fun id -> not (Ident.is_footprint id)) + if + footprint_part + && Exp.free_vars new_idx |> Sequence.exists ~f:(fun id -> not (Ident.is_footprint id)) then ( L.d_warning ( "Array index " ^ Exp.to_string new_idx @@ -1248,7 +1250,7 @@ let mem_sub id sub = List.exists ~f:(fun (id1, _) -> Ident.equal id id1) sub (** Extend substitution and return [None] if not possible. *) let extend_sub sub id exp : exp_subst option = let compare (id1, _) (id2, _) = Ident.compare id1 id2 in - if mem_sub id sub then None else Some (List.merge ~cmp:compare sub [(id, exp)]) + if mem_sub id sub then None else Some (List.merge ~compare sub [(id, exp)]) (** Free auxilary variables in the domain and range of the substitution. *) @@ -1506,7 +1508,9 @@ type sharing_env = {exph: Exp.t Exp.Hash.t; hpredh: hpred HpredInstHash.t} let create_sharing_env () = {exph= Exp.Hash.create 3; hpredh= HpredInstHash.create 3} (** Return a canonical representation of the exp *) -let exp_compact sh e = try Exp.Hash.find sh.exph e with Not_found -> Exp.Hash.add sh.exph e e ; e +let exp_compact sh e = + try Exp.Hash.find sh.exph e with Caml.Not_found -> Exp.Hash.add sh.exph e e ; e + let rec sexp_compact sh se = match se with @@ -1533,7 +1537,7 @@ let hpred_compact_ sh hpred = let hpred_compact sh hpred = - try HpredInstHash.find sh.hpredh hpred with Not_found -> + try HpredInstHash.find sh.hpredh hpred with Caml.Not_found -> let hpred' = hpred_compact_ sh hpred in HpredInstHash.add sh.hpredh hpred' hpred' ; hpred' @@ -1570,9 +1574,9 @@ let exp_add_offsets exp offsets = let rec f acc = function | [] -> acc - | (Off_fld (fld, typ)) :: offs' -> + | Off_fld (fld, typ) :: offs' -> f (Exp.Lfield (acc, fld, typ)) offs' - | (Off_index e) :: offs' -> + | Off_index e :: offs' -> f (Exp.Lindex (acc, e)) offs' in f exp offsets diff --git a/infer/src/IR/Sil.mli b/infer/src/IR/Sil.mli index cd3c21690..3df12e492 100644 --- a/infer/src/IR/Sil.mli +++ b/infer/src/IR/Sil.mli @@ -26,7 +26,7 @@ type if_kind = | Ik_land_lor (** obtained from translation of && or || *) | Ik_while | Ik_switch - [@@deriving compare] +[@@deriving compare] (** An instruction. *) type instr = @@ -53,7 +53,7 @@ type instr = | Abstract of Location.t (** apply abstraction *) | Remove_temps of Ident.t list * Location.t (** remove temporaries *) | Declare_locals of (Pvar.t * Typ.t) list * Location.t (** declare local variables *) - [@@deriving compare] +[@@deriving compare] val equal_instr : instr -> instr -> bool @@ -73,7 +73,7 @@ type atom = | Aneq of Exp.t * Exp.t (** disequality *) | Apred of PredSymb.t * Exp.t list (** predicate symbol applied to exps *) | Anpred of PredSymb.t * Exp.t list (** negated predicate symbol applied to exps *) - [@@deriving compare] +[@@deriving compare] val equal_atom : atom -> atom -> bool @@ -83,7 +83,7 @@ val atom_has_local_addr : atom -> bool type lseg_kind = | Lseg_NE (** nonempty (possibly circular) listseg *) | Lseg_PE (** possibly empty (possibly circular) listseg *) - [@@deriving compare] +[@@deriving compare] val equal_lseg_kind : lseg_kind -> lseg_kind -> bool @@ -107,7 +107,7 @@ type inst = | Itaint | Iupdate of zero_flag * null_case_flag * int * PredSymb.path_pos | Ireturn_from_call of int - [@@deriving compare] +[@@deriving compare] val equal_inst : inst -> inst -> bool @@ -159,7 +159,7 @@ type 'inst strexp0 = For instance, x |->[10 | e1: v1] implies that e1 <= 9. Second, if two indices appear in an array, they should be different. For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *) - [@@deriving compare] +[@@deriving compare] type strexp = inst strexp0 @@ -191,11 +191,11 @@ type 'inst hpred0 = primed identifiers, and include all the free primed identifiers in body. body should not contain any non - primed identifiers or program variables (i.e. pvars). *) - [@@deriving compare] +[@@deriving compare] and 'inst hpara0 = {root: Ident.t; next: Ident.t; svars: Ident.t list; evars: Ident.t list; body: 'inst hpred0 list} - [@@deriving compare] +[@@deriving compare] (** parameter for the higher-order doubly-linked list predicates. Assume that all the free identifiers in body_dll should belong to @@ -207,7 +207,7 @@ and 'inst hpara_dll0 = ; svars_dll: Ident.t list ; evars_dll: Ident.t list ; body_dll: 'inst hpred0 list } - [@@deriving compare] +[@@deriving compare] type hpred = inst hpred0 diff --git a/infer/src/IR/Subtype.ml b/infer/src/IR/Subtype.ml index 601c44e94..9fe9cb81d 100644 --- a/infer/src/IR/Subtype.ml +++ b/infer/src/IR/Subtype.ml @@ -19,10 +19,8 @@ let list_to_string list = else "- {" ^ String.concat ~sep:", " (List.map ~f:Typ.Name.name list) ^ "}" -type t' = - | Exact (** denotes the current type only *) - | Subtypes of Typ.Name.t list - [@@deriving compare] +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 @@ -99,7 +97,7 @@ end) let check_subtype = let subtMap = ref SubtypesMap.empty in fun tenv c1 c2 -> - ( try SubtypesMap.find (c1, c2) !subtMap with Not_found -> + ( try SubtypesMap.find (c1, c2) !subtMap with Caml.Not_found -> let is_subt = check_subclass_tenv tenv c1 c2 in subtMap := SubtypesMap.add (c1, c2) is_subt !subtMap ; is_subt @@ -182,7 +180,7 @@ let normalize_subtypes t_opt c1 c2 flag1 flag2 = | Exact -> Some (t, new_flag) | Subtypes l -> - Some (Subtypes (List.sort ~cmp:Typ.Name.compare l), new_flag) ) + Some (Subtypes (List.sort ~compare:Typ.Name.compare l), new_flag) ) | None -> None @@ -253,8 +251,8 @@ let get_subtypes tenv (c1, ((st1, flag1): t)) (c2, ((st2, flag2): t)) = let l2' = updates_head tenv c1 l2 in (Some (Subtypes (add_not_subtype tenv c1 l1 l2')), None) else (None, Some st1) - else if (is_interface tenv c1 || is_known_subtype tenv c2 c1) - && no_subtype_in_list tenv c2 l1 + else if + (is_interface tenv c1 || is_known_subtype tenv c2 c1) && no_subtype_in_list tenv c2 l1 then let l1' = updates_head tenv c2 l1 in ( Some (Subtypes (add_not_subtype tenv c2 l1' l2)) diff --git a/infer/src/IR/Tenv.ml b/infer/src/IR/Tenv.ml index 91b91ccdf..0c7da1589 100644 --- a/infer/src/IR/Tenv.ml +++ b/infer/src/IR/Tenv.ml @@ -45,13 +45,13 @@ 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 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 -> ( - try Some (TypenameHash.find tenv (CppClass (m, NoTemplate))) with Not_found -> None ) + try Some (TypenameHash.find tenv (CppClass (m, NoTemplate))) with Caml.Not_found -> None ) | CppClass (m, NoTemplate) -> ( - try Some (TypenameHash.find tenv (CStruct m)) with Not_found -> None ) + try Some (TypenameHash.find tenv (CStruct m)) with Caml.Not_found -> None ) | _ -> None @@ -65,7 +65,7 @@ let add_field tenv class_tn_name field = match lookup tenv class_tn_name with | Some ({fields} as struct_typ) -> if not (List.mem ~equal:equal_fields fields field) then - let new_fields = List.merge [field] fields ~cmp:compare_fields in + let new_fields = List.merge [field] fields ~compare:compare_fields in ignore (mk_struct tenv ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name) | _ -> () @@ -154,7 +154,7 @@ let language_is tenv lang = match TypenameHash.iter (fun n -> raise (Found n)) tenv with | () -> false - | exception Found JavaClass _ -> + | exception Found (JavaClass _) -> Language.equal lang Java | exception Found _ -> Language.equal lang Clang diff --git a/infer/src/IR/Typ.ml b/infer/src/IR/Typ.ml index afe3db9fa..5928e5fbe 100644 --- a/infer/src/IR/Typ.ml +++ b/infer/src/IR/Typ.ml @@ -31,7 +31,7 @@ type ikind = | IULongLong (** [unsigned long long] (or [unsigned int64_] on Microsoft Visual C) *) | I128 (** [__int128_t] *) | IU128 (** [__uint128_t] *) - [@@deriving compare] +[@@deriving compare] let ikind_to_string = function | IChar -> @@ -78,7 +78,7 @@ type fkind = | FFloat (** [float] *) | FDouble (** [double] *) | FLongDouble (** [long double] *) - [@@deriving compare] +[@@deriving compare] let fkind_to_string = function | FFloat -> @@ -96,7 +96,7 @@ type ptr_kind = | Pk_objc_weak (** Obj-C __weak pointer *) | Pk_objc_unsafe_unretained (** Obj-C __unsafe_unretained pointer *) | Pk_objc_autoreleasing (** Obj-C __autoreleasing pointer *) - [@@deriving compare] +[@@deriving compare] let equal_ptr_kind = [%compare.equal : ptr_kind] @@ -129,7 +129,7 @@ module T = struct | TVar of string (** type variable (ie. C++ template variables) *) | Tarray of {elt: t; length: IntLit.t option; stride: IntLit.t option} (** array type with statically fixed length and stride *) - [@@deriving compare] + [@@deriving compare] and name = | CStruct of QualifiedCppName.t @@ -138,20 +138,15 @@ module T = struct | JavaClass of Mangled.t | ObjcClass of QualifiedCppName.t | ObjcProtocol of QualifiedCppName.t - [@@deriving compare] + [@@deriving compare] - and template_arg = - | TType of t - | TInt of Int64.t - | TNull - | TNullPtr - | TOpaque - [@@deriving compare] + and template_arg = TType of t | TInt of Int64.t | TNull | TNullPtr | TOpaque + [@@deriving compare] and template_spec_info = | NoTemplate | Template of {mangled: string option; args: template_arg list} - [@@deriving compare] + [@@deriving compare] let equal_desc = [%compare.equal : desc] @@ -555,12 +550,11 @@ module Procname = struct (* in Java, procedures called with invokevirtual, invokespecial, and invokeinterface *) | Static (* in Java, procedures called with invokestatic *) - [@@deriving compare] + [@@deriving compare] (* TODO: use Mangled.t here *) - type java_type = Name.Java.Split.t = - {package: string option; type_name: string} - [@@deriving compare] + type java_type = Name.Java.Split.t = {package: string option; type_name: string} + [@@deriving compare] (** Type of java procedure names. *) type t = @@ -569,7 +563,7 @@ module Procname = struct ; class_name: Name.t ; return_type: java_type option (* option because constructors have no return type *) ; kind: kind } - [@@deriving compare] + [@@deriving compare] let make class_name return_type method_name parameters kind = {class_name; return_type; method_name; parameters; kind} @@ -743,7 +737,7 @@ module Procname = struct | ObjCClassMethod | ObjCInstanceMethod | ObjCInternalMethod - [@@deriving compare] + [@@deriving compare] type t = { method_name: string @@ -751,7 +745,7 @@ module Procname = struct ; kind: kind ; template_args: template_spec_info ; is_generic_model: bool } - [@@deriving compare] + [@@deriving compare] let make class_name method_name kind template_args ~is_generic_model = {class_name; method_name; kind; template_args; is_generic_model} @@ -831,7 +825,7 @@ module Procname = struct ; mangled: string option ; template_args: template_spec_info ; is_generic_model: bool } - [@@deriving compare] + [@@deriving compare] (** Type of Objective C block names. *) type block_name = string [@@deriving compare] @@ -844,7 +838,7 @@ module Procname = struct | Block of block_name | ObjC_Cpp of ObjC_Cpp.t | WithBlockParameters of t * block_name list - [@@deriving compare] + [@@deriving compare] let equal = [%compare.equal : t] @@ -1152,7 +1146,6 @@ module Procname = struct let sexp_of_t p = Sexp.Atom (to_string p) end ) - () let serialize pname = @@ -1174,10 +1167,8 @@ module Procname = struct end module Fieldname = struct - type t = - | Clang of {class_name: Name.t; field_name: string} - | Java of string - [@@deriving compare] + type t = Clang of {class_name: Name.t; field_name: string} | Java of string + [@@deriving compare] let equal = [%compare.equal : t] @@ -1306,7 +1297,8 @@ module Struct = struct \tmethods: {%a@\n\ \t}@\n\ \tannots: {%a@\n\ - \t}" Name.pp name + \t}" + Name.pp name (Pp.seq (pp_field pe)) fields (Pp.seq (fun f n -> F.fprintf f "@\n\t\t%a" Name.pp n)) diff --git a/infer/src/IR/Typ.mli b/infer/src/IR/Typ.mli index ddbfeb2b7..214c67b9b 100644 --- a/infer/src/IR/Typ.mli +++ b/infer/src/IR/Typ.mli @@ -29,7 +29,7 @@ type ikind = | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft Visual C) *) | I128 (** [__int128_t] *) | IU128 (** [__uint128_t] *) - [@@deriving compare] +[@@deriving compare] val ikind_is_char : ikind -> bool (** Check whether the integer kind is a char *) @@ -42,7 +42,7 @@ type fkind = | FFloat (** [float] *) | FDouble (** [double] *) | FLongDouble (** [long double] *) - [@@deriving compare] +[@@deriving compare] (** kind of pointer *) type ptr_kind = @@ -51,7 +51,7 @@ type ptr_kind = | Pk_objc_weak (** Obj-C __weak pointer *) | Pk_objc_unsafe_unretained (** Obj-C __unsafe_unretained pointer *) | Pk_objc_autoreleasing (** Obj-C __autoreleasing pointer *) - [@@deriving compare] +[@@deriving compare] val equal_ptr_kind : ptr_kind -> ptr_kind -> bool @@ -80,7 +80,7 @@ and desc = | TVar of string (** type variable (ie. C++ template variables) *) | Tarray of {elt: t; length: IntLit.t option; stride: IntLit.t option} (** array type with statically fixed length and stride *) - [@@deriving compare] +[@@deriving compare] and name = | CStruct of QualifiedCppName.t @@ -92,7 +92,7 @@ and name = | JavaClass of Mangled.t | ObjcClass of QualifiedCppName.t | ObjcProtocol of QualifiedCppName.t - [@@deriving compare] +[@@deriving compare] and template_arg = TType of t | TInt of Int64.t | TNull | TNullPtr | TOpaque [@@deriving compare] @@ -104,7 +104,7 @@ and template_spec_info = mangling is not guaranteed to be unique to a single type. All the information in the template arguments is also needed for uniqueness. *) ; args: template_arg list } - [@@deriving compare] +[@@deriving compare] val mk : ?default:t -> ?quals:type_quals -> desc -> t (** Create Typ.t from given desc. if [default] is passed then use its value to set other fields such as quals *) @@ -376,7 +376,7 @@ module Procname : sig | ObjCClassMethod | ObjCInstanceMethod | ObjCInternalMethod - [@@deriving compare] + [@@deriving compare] (** Type of Objective C and C++ procedure names: method signatures. *) type t = @@ -385,7 +385,7 @@ module Procname : sig ; kind: kind ; template_args: template_spec_info ; is_generic_model: bool } - [@@deriving compare] + [@@deriving compare] val make : Name.t -> string -> kind -> template_spec_info -> is_generic_model:bool -> t (** Create an objc procedure name from a class_name and method_name. *) @@ -444,7 +444,7 @@ module Procname : sig | Block of block_name | ObjC_Cpp of ObjC_Cpp.t | WithBlockParameters of t * block_name list - [@@deriving compare] + [@@deriving compare] val block_name_of_procname : t -> block_name diff --git a/infer/src/IR/Unop.ml b/infer/src/IR/Unop.ml index 138296ce0..79addad0e 100644 --- a/infer/src/IR/Unop.ml +++ b/infer/src/IR/Unop.ml @@ -19,7 +19,7 @@ type t = | Neg (** Unary minus *) | BNot (** Bitwise complement (~) *) | LNot (** Logical Not (!) *) - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] diff --git a/infer/src/IR/Unop.mli b/infer/src/IR/Unop.mli index dbdfa907d..dd9d595e5 100644 --- a/infer/src/IR/Unop.mli +++ b/infer/src/IR/Unop.mli @@ -19,7 +19,7 @@ type t = | Neg (** Unary minus *) | BNot (** Bitwise complement (~) *) | LNot (** Logical Not (!) *) - [@@deriving compare] +[@@deriving compare] val equal : t -> t -> bool diff --git a/infer/src/absint/AbstractDomain.ml b/infer/src/absint/AbstractDomain.ml index ff25e772f..795f670f7 100644 --- a/infer/src/absint/AbstractDomain.ml +++ b/infer/src/absint/AbstractDomain.ml @@ -191,7 +191,7 @@ module MapOfPPMap (M : PrettyPrintable.PPMap) (ValueDomain : S) = struct else M.for_all (fun k lhs_v -> - try ValueDomain.( <= ) ~lhs:lhs_v ~rhs:(M.find k rhs) with Not_found -> false ) + try ValueDomain.( <= ) ~lhs:lhs_v ~rhs:(M.find k rhs) with Caml.Not_found -> false ) lhs @@ -241,7 +241,7 @@ module InvertedMap (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S if phys_equal lhs rhs then true else try M.for_all (fun k rhs_v -> ValueDomain.( <= ) ~lhs:(M.find k lhs) ~rhs:rhs_v) rhs - with Not_found -> false + with Caml.Not_found -> false let join astate1 astate2 = diff --git a/infer/src/absint/AbstractInterpreter.ml b/infer/src/absint/AbstractInterpreter.ml index 84e8c67be..6f2ad91a2 100644 --- a/infer/src/absint/AbstractInterpreter.ml +++ b/infer/src/absint/AbstractInterpreter.ml @@ -49,9 +49,7 @@ struct type invariant_map = Domain.astate state InvariantMap.t (** extract the state of node [n] from [inv_map] *) - let extract_state node_id inv_map = - try Some (InvariantMap.find node_id inv_map) with Not_found -> None - + let extract_state node_id inv_map = InvariantMap.find_opt node_id inv_map (** extract the postcondition of node [n] from [inv_map] *) let extract_post node_id inv_map = @@ -106,8 +104,8 @@ struct if visit_count' > Config.max_widens then L.(die InternalError) "Exceeded max widening threshold %d while analyzing %a. Please check your widening \ - operator or increase the threshold" Config.max_widens Typ.Procname.pp - (Procdesc.get_proc_name pdesc) ; + operator or increase the threshold" + Config.max_widens Typ.Procname.pp (Procdesc.get_proc_name pdesc) ; update_inv_map widened_pre visit_count' ) else (* first time visiting this node *) diff --git a/infer/src/absint/FormalMap.ml b/infer/src/absint/FormalMap.ml index 48fee033c..c8b3dbabf 100644 --- a/infer/src/absint/FormalMap.ml +++ b/infer/src/absint/FormalMap.ml @@ -32,7 +32,7 @@ let empty = AccessPath.BaseMap.empty let is_formal = AccessPath.BaseMap.mem -let get_formal_index base t = try Some (AccessPath.BaseMap.find base t) with Not_found -> None +let get_formal_index base t = AccessPath.BaseMap.find_opt base t let get_formal_base index t = List.find ~f:(fun (_, i) -> Int.equal i index) (AccessPath.BaseMap.bindings t) diff --git a/infer/src/absint/LowerHil.ml b/infer/src/absint/LowerHil.ml index 0e8e2de99..9d108cfe2 100644 --- a/infer/src/absint/LowerHil.ml +++ b/infer/src/absint/LowerHil.ml @@ -48,9 +48,7 @@ struct let exec_instr ((actual_state, id_map) as astate) extras node instr = - let f_resolve_id id = - try Some (IdAccessPathMapDomain.find id id_map) with Not_found -> None - in + let f_resolve_id id = IdAccessPathMapDomain.find_opt id id_map in match HilInstr.of_sil ~include_array_indexes:HilConfig.include_array_indexes ~f_resolve_id instr with diff --git a/infer/src/absint/PatternMatch.ml b/infer/src/absint/PatternMatch.ml index 402f7ae01..bf0059abe 100644 --- a/infer/src/absint/PatternMatch.ml +++ b/infer/src/absint/PatternMatch.ml @@ -121,8 +121,8 @@ let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : str (* Is this the node creating ivar? *) let rec initializes_array instrs = match instrs with - | (Sil.Call (Some (t1, _), Exp.Const Const.Cfun pn, _, _, _)) - :: (Sil.Store (Exp.Lvar iv, _, Exp.Var t2, _)) :: is -> + | Sil.Call (Some (t1, _), Exp.Const (Const.Cfun pn), _, _, _) + :: Sil.Store (Exp.Lvar iv, _, Exp.Var t2, _) :: is -> Pvar.equal ivar iv && Ident.equal t1 t2 && Typ.Procname.equal pn (Typ.Procname.from_string_c_fun "__new_array") || initializes_array is @@ -135,9 +135,9 @@ let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : str let added_type_name node = let rec nvar_type_name nvar instrs = match instrs with - | (Sil.Load (nv, Exp.Lfield (_, id, t), _, _)) :: _ when Ident.equal nv nvar -> + | Sil.Load (nv, Exp.Lfield (_, id, t), _, _) :: _ when Ident.equal nv nvar -> get_field_type_name tenv t id - | (Sil.Load (nv, _, t, _)) :: _ when Ident.equal nv nvar -> + | Sil.Load (nv, _, t, _) :: _ when Ident.equal nv nvar -> Some (get_type_name t) | _ :: is -> nvar_type_name nvar is @@ -146,10 +146,10 @@ let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : str in let rec added_nvar array_nvar instrs = match instrs with - | (Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Var nvar, _)) :: _ + | Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Var nvar, _) :: _ when Ident.equal iv array_nvar -> nvar_type_name nvar (Procdesc.Node.get_instrs node) - | (Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Const c, _)) :: _ + | Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Const c, _) :: _ when Ident.equal iv array_nvar -> Some (java_get_const_type_name c) | _ :: is -> @@ -159,7 +159,7 @@ let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : str in let rec array_nvar instrs = match instrs with - | (Sil.Load (nv, Exp.Lvar iv, _, _)) :: _ when Pvar.equal iv ivar -> + | Sil.Load (nv, Exp.Lvar iv, _, _) :: _ when Pvar.equal iv ivar -> added_nvar nv instrs | _ :: is -> array_nvar is @@ -176,7 +176,7 @@ let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : str | [n] -> ( match added_type_name node with Some name -> name :: type_names n | None -> type_names n ) | _ -> - raise Not_found + raise Caml.Not_found in List.rev (type_names call_node) @@ -263,7 +263,7 @@ let proc_calls resolve_attributes pdesc filter : (Typ.Procname.t * ProcAttribute let res = ref [] in let do_instruction _ instr = match instr with - | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) -> ( + | Sil.Call (_, Exp.Const (Const.Cfun callee_pn), _, _, _) -> ( match resolve_attributes callee_pn with | Some callee_attributes -> if filter callee_pn callee_attributes then res := (callee_pn, callee_attributes) :: !res diff --git a/infer/src/absint/ProcCfg.ml b/infer/src/absint/ProcCfg.ml index 7f4fd1787..93f4e1ce2 100644 --- a/infer/src/absint/ProcCfg.ml +++ b/infer/src/absint/ProcCfg.ml @@ -215,7 +215,7 @@ module Exceptional = struct let add_exn_pred exn_preds_acc exn_succ_node = let exn_succ_node_id = Procdesc.Node.get_id exn_succ_node in let existing_exn_preds = - try Procdesc.IdMap.find exn_succ_node_id exn_preds_acc with Not_found -> [] + try Procdesc.IdMap.find exn_succ_node_id exn_preds_acc with Caml.Not_found -> [] in if not (List.mem ~equal:Procdesc.Node.equal existing_exn_preds n) then (* don't add duplicates *) @@ -241,7 +241,7 @@ module Exceptional = struct let normal_preds _ n = Procdesc.Node.get_preds n let exceptional_preds (_, exn_pred_map) n = - try Procdesc.IdMap.find (Procdesc.Node.get_id n) exn_pred_map with Not_found -> [] + try Procdesc.IdMap.find (Procdesc.Node.get_id n) exn_pred_map with Caml.Not_found -> [] (** get all normal and exceptional successors of [n]. *) @@ -251,7 +251,7 @@ module Exceptional = struct | [] -> normal_succs | exceptional_succs -> - normal_succs @ exceptional_succs |> List.sort ~cmp:Procdesc.Node.compare + normal_succs @ exceptional_succs |> List.sort ~compare:Procdesc.Node.compare |> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal @@ -262,7 +262,7 @@ module Exceptional = struct | [] -> normal_preds | exceptional_preds -> - normal_preds @ exceptional_preds |> List.sort ~cmp:Procdesc.Node.compare + normal_preds @ exceptional_preds |> List.sort ~compare:Procdesc.Node.compare |> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal diff --git a/infer/src/absint/Scheduler.ml b/infer/src/absint/Scheduler.ml index 665ae399b..20c62ffd9 100644 --- a/infer/src/absint/Scheduler.ml +++ b/infer/src/absint/Scheduler.ml @@ -77,7 +77,7 @@ module ReversePostorder (CFG : ProcCfg.S) = struct let schedule_succ worklist_acc node_to_schedule = let id_to_schedule = CFG.id node_to_schedule in let old_work = - try M.find id_to_schedule worklist_acc with Not_found -> + try M.find id_to_schedule worklist_acc with Caml.Not_found -> WorkUnit.make t.cfg node_to_schedule in let new_work = WorkUnit.add_visited_pred t.cfg old_work node_id in @@ -106,7 +106,7 @@ module ReversePostorder (CFG : ProcCfg.S) = struct let node = WorkUnit.node max_priority_work in let t' = {t with worklist= M.remove (CFG.id node) t.worklist} in Some (node, WorkUnit.visited_preds max_priority_work, t') - with Not_found -> None + with Caml.Not_found -> None let empty cfg = {worklist= M.empty; cfg} diff --git a/infer/src/atd/InferCommand.ml b/infer/src/atd/InferCommand.ml index 5463fe599..b93448364 100644 --- a/infer/src/atd/InferCommand.ml +++ b/infer/src/atd/InferCommand.ml @@ -9,17 +9,8 @@ open Core (* NOTE: All variants must be also added to `all_commands` below *) -type t = - | Analyze - | Capture - | Compile - | Diff - | Events - | Explore - | Report - | ReportDiff - | Run - [@@deriving compare] +type t = Analyze | Capture | Compile | Diff | Events | Explore | Report | ReportDiff | Run +[@@deriving compare] let equal = [%compare.equal : t] diff --git a/infer/src/atd/InferCommand.mli b/infer/src/atd/InferCommand.mli index 52ab29ecf..e1c0db7a0 100644 --- a/infer/src/atd/InferCommand.mli +++ b/infer/src/atd/InferCommand.mli @@ -22,7 +22,7 @@ type t = | Report (** post-process infer results and reports *) | ReportDiff (** compute the difference of two infer reports *) | Run (** orchestrate the capture, analysis, and reporting of a compilation command *) - [@@deriving compare] +[@@deriving compare] val of_string : string -> t diff --git a/infer/src/backend/Differential.ml b/infer/src/backend/Differential.ml index dd473a64a..9f349047d 100644 --- a/infer/src/backend/Differential.ml +++ b/infer/src/backend/Differential.ml @@ -15,9 +15,9 @@ module LocListSet = struct type t = Location.t list [@@deriving compare] end) - let mem s xs = not (List.is_empty xs) && mem (List.sort ~cmp: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 ~cmp: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 let is_duplicate_report end_locs reported_ends = @@ -25,21 +25,21 @@ let is_duplicate_report end_locs reported_ends = let sort_by_decreasing_preference_to_report issues = - let cmp (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 let n = String.compare x.hash y.hash in if n <> 0 then n else Pervasives.compare x y in - List.sort ~cmp issues + List.sort ~compare issues let sort_by_location issues = - let cmp (x: Jsonbug_t.jsonbug) (y: Jsonbug_t.jsonbug) = + 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 ~cmp issues + List.sort ~compare issues let dedup (issues: Jsonbug_t.jsonbug list) = diff --git a/infer/src/backend/DifferentialFilters.ml b/infer/src/backend/DifferentialFilters.ml index 8757a537e..39c45870a 100644 --- a/infer/src/backend/DifferentialFilters.ml +++ b/infer/src/backend/DifferentialFilters.ml @@ -33,13 +33,13 @@ module FileRenamings = struct 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 - | Some `String current, Some `String previous -> + | Some (`String current), Some (`String previous) -> {current; previous} | None, _ -> raise (Yojson.Json_error "\"current\" field missing") | Some _, None -> raise (Yojson.Json_error "\"previous\" field missing") - | Some _, Some `String _ -> + | Some _, Some (`String _) -> raise (Yojson.Json_error "\"current\" field is not a string") | Some _, Some _ -> raise (Yojson.Json_error "\"previous\" field is not a string") ) @@ -48,8 +48,9 @@ module FileRenamings = struct with Yojson.Json_error err -> L.(die UserError) "Error parsing file renamings: %s@\n\ - Expected JSON object of the following form: '%s', but instead got: '%s'" err - "{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"}" (Yojson.Basic.to_string assoc) + Expected JSON object of the following form: '%s', but instead got: '%s'" + err "{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"}" + (Yojson.Basic.to_string assoc) in match j with | `List json_renamings -> @@ -84,15 +85,17 @@ 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 ~cmp ?(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 (cmp ld v) 0 | [] -> false in + let is_last_seen_dup v = + match dups with ld :: _ -> Int.equal (compare ld v) 0 | [] -> false + in match (in_l1, in_l2) with - | i :: is, f :: fs when Int.equal (cmp i f) 0 -> + | i :: is, f :: fs when Int.equal (compare i f) 0 -> (* i = f *) if pred i then aux (out_l1, i :: dups, out_l2) is fs else aux (i :: out_l1, dups, f :: out_l2) is fs - | i :: is, f :: _ when cmp i f < 0 -> + | i :: is, f :: _ when compare i f < 0 -> (* i < f *) let out_l1' = if is_last_seen_dup i then out_l1 else i :: out_l1 in aux (out_l1', dups, out_l2) is in_l2 @@ -107,8 +110,8 @@ let relative_complements ~cmp ?(pred= fun _ -> true) l1 l2 = | _, _ -> (List.rev_append in_l1 out_l1, dups, List.rev_append in_l2 out_l2) in - let l1_sorted = List.sort ~cmp l1 in - let l2_sorted = List.sort ~cmp l2 in + let l1_sorted = List.sort ~compare l1 in + let l2_sorted = List.sort ~compare l2 in aux ([], [], []) l1_sorted l2_sorted @@ -122,7 +125,7 @@ let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differ in String.compare f1 f2 in - let cmp ((issue1, _) as issue_with_previous_file1) ((issue2, _) as issue_with_previous_file2) = + 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) @@ -137,7 +140,7 @@ let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differ in let fixed_normalized = List.map diff.fixed ~f:(fun f -> (f, None)) in let introduced_normalized', preexisting', fixed_normalized' = - relative_complements ~cmp introduced_normalized fixed_normalized + relative_complements ~compare introduced_normalized fixed_normalized in let list_map_fst = List.map ~f:fst in ( list_map_fst introduced_normalized' @@ -185,7 +188,7 @@ let skip_anonymous_class_renamings (diff: Differential.t) : Differential.t = *) let string_of_procedure_id issue = DB.strip_crc issue.Jsonbug_t.procedure_id in let extension fname = snd (Filename.split_extension fname) in - let cmp (i1: Jsonbug_t.jsonbug) (i2: Jsonbug_t.jsonbug) = + let compare (i1: Jsonbug_t.jsonbug) (i2: Jsonbug_t.jsonbug) = [%compare : file_extension option * weak_hash * procedure_id] (extension i1.file, (i1.kind, i1.bug_type, i1.file, i1.key), string_of_procedure_id i1) (extension i2.file, (i2.kind, i2.bug_type, i2.file, i2.key), string_of_procedure_id i2) @@ -202,12 +205,12 @@ let skip_anonymous_class_renamings (diff: Differential.t) : Differential.t = try ignore (Str.search_forward java_anon_class_pattern issue.procedure_id 0) ; true - with Not_found -> false + with Caml.Not_found -> false in is_java_file () && has_anonymous_class_token () in let introduced, preexisting, fixed = - relative_complements ~cmp ~pred diff.introduced diff.fixed + relative_complements ~compare ~pred diff.introduced diff.fixed in {introduced; fixed; preexisting= preexisting @ diff.preexisting} diff --git a/infer/src/backend/DifferentialFilters.mli b/infer/src/backend/DifferentialFilters.mli index 2fdc48ecc..022313718 100644 --- a/infer/src/backend/DifferentialFilters.mli +++ b/infer/src/backend/DifferentialFilters.mli @@ -37,7 +37,7 @@ val do_filter : module VISIBLE_FOR_TESTING_DO_NOT_USE_DIRECTLY : sig val relative_complements : - cmp:('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/InferPrint.ml b/infer/src/backend/InferPrint.ml index bf962c895..a031f1ad7 100644 --- a/infer/src/backend/InferPrint.ml +++ b/infer/src/backend/InferPrint.ml @@ -229,9 +229,10 @@ module IssuesJson = struct let should_report_source_file = not (SourceFile.is_infer_model source_file) || Config.debug_mode || Config.debug_exceptions in - if key.in_footprint && error_filter source_file key.err_desc key.err_name - && should_report_source_file - && should_report key.err_kind key.err_name key.err_desc err_data.err_class + if + key.in_footprint && error_filter source_file key.err_desc key.err_name + && should_report_source_file + && should_report key.err_kind key.err_name key.err_desc err_data.err_class then ( let kind = Exceptions.err_kind_string key.err_kind in let bug_type = key.err_name.IssueType.unique_id in @@ -366,8 +367,9 @@ module IssuesTxt = struct | None -> err_data.loc.Location.file in - if key.in_footprint && error_filter source_file key.err_desc key.err_name - && (not Config.filtering || String.is_empty (censored_reason key.err_name source_file)) + if + key.in_footprint && error_filter source_file key.err_desc key.err_name + && (not Config.filtering || String.is_empty (censored_reason key.err_name source_file)) then Exceptions.pp_err ~node_key:err_data.node_id_key.node_key err_data.loc key.err_kind key.err_name key.err_desc None fmt () @@ -420,7 +422,7 @@ module Stats = struct let process_loc loc stats = - try Hashtbl.find stats.files loc.Location.file with Not_found -> + try Hashtbl.find stats.files loc.Location.file with Caml.Not_found -> Hashtbl.add stats.files loc.Location.file () @@ -493,7 +495,7 @@ module Stats = struct let is_verified = specs <> [] && not is_defective in let is_checked = not (is_defective || is_verified) in let is_timeout = - match Specs.(summary.stats.stats_failure) with None | Some FKcrash _ -> false | _ -> true + match Specs.(summary.stats.stats_failure) with None | Some (FKcrash _) -> false | _ -> true in stats.nprocs <- stats.nprocs + 1 ; stats.nspecs <- stats.nspecs + List.length specs ; @@ -609,7 +611,7 @@ module Issue = struct type t = {proc_name: proc_name_; proc_location: Location.t; err_key: Errlog.err_key; err_data: err_data_} - [@@deriving compare] + [@@deriving compare] (* If two issues are identical except for their procnames, they are probably duplicate reports on two different instantiations of the same template. We don't want to spam users by reporting @@ -798,7 +800,7 @@ let pp_json_report_by_report_kind formats_by_report_kind fname = in let sorted_report = let report = Jsonbug_j.report_of_string (String.concat ~sep:"\n" report_lines) in - List.sort ~cmp:tests_jsonbug_compare report + List.sort ~compare:tests_jsonbug_compare report in let pp_report_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with @@ -861,7 +863,7 @@ let spec_files_from_cmdline () = (** Create an iterator which loads spec files one at a time *) let get_summary_iterator () = - let sorted_spec_files = List.sort ~cmp:String.compare (spec_files_from_cmdline ()) in + let sorted_spec_files = List.sort ~compare:String.compare (spec_files_from_cmdline ()) in let do_spec f fname = match Specs.load_summary (DB.filename_from_string fname) with | None -> @@ -954,8 +956,8 @@ let pp_summary_and_issues formats_by_report_kind issue_formats = let iterate_summaries = get_summary_iterator () in let all_issues = ref [] in iterate_summaries (fun summary -> - all_issues - := process_summary filters formats_by_report_kind linereader stats summary !all_issues ) ; + all_issues := + process_summary filters formats_by_report_kind linereader stats summary !all_issues ) ; List.iter ~f:(fun ({Issue.proc_name} as issue) -> let error_filter = error_filter filters proc_name in diff --git a/infer/src/backend/crashcontext.ml b/infer/src/backend/crashcontext.ml index 64f1535d1..f3e5aa809 100644 --- a/infer/src/backend/crashcontext.ml +++ b/infer/src/backend/crashcontext.ml @@ -73,8 +73,9 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = Utils.directory_fold (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" - && String.is_suffix ~suffix:"crashcontext" (Filename.dirname path) + if + Sys.is_directory path <> `Yes && Filename.check_suffix path "json" + && String.is_suffix ~suffix:"crashcontext" (Filename.dirname path) then path :: summaries else summaries ) [] root_summaries_dir @@ -108,7 +109,7 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = (* trace_fold runs immediately after trace_file_matcher in the DB.fold_paths_matching statement below, so we don't need to call Str.string_match again. *) - | Not_found + | Caml.Not_found -> assert false in let input_output_file_pairs = diff --git a/infer/src/backend/dotty.ml b/infer/src/backend/dotty.ml index eeab1a7b6..10366b092 100644 --- a/infer/src/backend/dotty.ml +++ b/infer/src/backend/dotty.ml @@ -35,7 +35,7 @@ type kind_of_links = | LinkToSSL | LinkToDLL | LinkRetainCycle - [@@deriving compare] +[@@deriving compare] (* coordinate identifies a node using two dimension: id is an numerical identifier of the node,*) (* lambda identifies in which hpred parameter id lays in*) @@ -45,7 +45,7 @@ type coordinate = {id: int; lambda: int} [@@deriving compare] (* useful for having nodes from within a struct and/or to inside a struct *) type link = {kind: kind_of_links; src: coordinate; src_fld: string; trg: coordinate; trg_fld: string} - [@@deriving compare] +[@@deriving compare] let equal_link = [%compare.equal : link] @@ -218,7 +218,7 @@ let rec look_up_for_back_pointer e dotnodes lambda = match dotnodes with | [] -> [] - | (Dotdllseg (coo, _, _, _, e4, _, _, _)) :: dotnodes' -> + | Dotdllseg (coo, _, _, _, e4, _, _, _) :: dotnodes' -> if Exp.equal e e4 && Int.equal lambda coo.lambda then [coo.id + 1] else look_up_for_back_pointer e dotnodes' lambda | _ :: dotnodes' -> @@ -312,7 +312,7 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list match l with | [] -> [] - | (Dotdangling (coo, e, color)) :: l' -> + | Dotdangling (coo, e, color) :: l' -> if List.exists ~f:(Exp.equal e) seen_exp then filter_duplicate l' seen_exp else Dotdangling (coo, e, color) :: filter_duplicate l' (e :: seen_exp) | box :: l' -> @@ -381,7 +381,7 @@ let rec dotty_mk_node pe sigma = let set_exps_neq_zero pi = let f = function - | Sil.Aneq (e, Exp.Const Const.Cint i) when IntLit.iszero i -> + | Sil.Aneq (e, Exp.Const (Const.Cint i)) when IntLit.iszero i -> exps_neq_zero := e :: !exps_neq_zero | _ -> () @@ -396,7 +396,7 @@ let box_dangling e = ~f:(fun b -> match b with Dotdangling (_, e', _) -> Exp.equal e e' | _ -> false) !dangling_dotboxes in - match entry_e with [] -> None | (Dotdangling (coo, _, _)) :: _ -> Some coo.id | _ -> None + match entry_e with [] -> None | Dotdangling (coo, _, _) :: _ -> Some coo.id | _ -> None (* NOTE: this cannot be possible since entry_e can be composed only by Dotdangling, see def of entry_e*) @@ -423,7 +423,7 @@ let compute_fields_struct sigma = match s with | [] -> () - | (Sil.Hpointsto (_, se, _)) :: s' -> + | Sil.Hpointsto (_, se, _) :: s' -> do_strexp se false ; fs s' | _ :: s' -> fs s' @@ -437,7 +437,7 @@ let compute_struct_exp_nodes sigma = match s with | [] -> () - | (Sil.Hpointsto (e, Sil.Estruct _, _)) :: s' -> + | Sil.Hpointsto (e, Sil.Estruct _, _) :: s' -> struct_exp_nodes := e :: !struct_exp_nodes ; sen s' | _ :: s' -> @@ -490,7 +490,7 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = [] | Some n' -> [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] ) - | [node] | [(Dotpointsto _); node] | [node; (Dotpointsto _)] -> + | [node] | [Dotpointsto _; node] | [node; Dotpointsto _] -> let n = get_coordinate_id node in if List.mem ~equal:Exp.equal !struct_exp_nodes e then let e_no_special_char = strip_special_chars (Exp.to_string e) in @@ -536,7 +536,7 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda = [] | Some n' -> [(LinkArrayToExp, Exp.to_string idx, n', "")] ) - | [node] | [(Dotpointsto _); node] | [node; (Dotpointsto _)] -> + | [node] | [Dotpointsto _; node] | [node; Dotpointsto _] -> let n = get_coordinate_id node in if List.mem ~equal:Exp.equal !struct_exp_nodes e then let e_no_special_char = strip_special_chars (Exp.to_string e) in diff --git a/infer/src/backend/errdesc.ml b/infer/src/backend/errdesc.ml index 6f48f899d..7e27ce49d 100644 --- a/infer/src/backend/errdesc.ml +++ b/infer/src/backend/errdesc.ml @@ -55,7 +55,7 @@ let is_special_field matcher field_name_opt field = let hpred_is_open_resource tenv prop = function | Sil.Hpointsto (e, _, _) -> ( match Attribute.get_resource tenv prop e with - | Some Apred (Aresource {ra_kind= Racquire; ra_res= res}, _) -> + | Some (Apred (Aresource {ra_kind= Racquire; ra_res= res}, _)) -> Some res | _ -> None ) @@ -133,7 +133,7 @@ let find_program_variable_assignment node pvar : (Procdesc.Node.t * Ident.t) opt let find_struct_by_value_assignment node pvar = if Pvar.is_frontend_tmp pvar then let find_instr node = function - | Sil.Call (_, Const Cfun pname, args, loc, cf) -> ( + | Sil.Call (_, Const (Cfun pname), args, loc, cf) -> ( match List.last args with | Some (Exp.Lvar last_arg, _) when Pvar.equal pvar last_arg -> Some (node, pname, loc, cf) @@ -162,7 +162,7 @@ let find_ident_assignment node id : (Procdesc.Node.t * Exp.t) option = let rec find_boolean_assignment node pvar true_branch : Procdesc.Node.t option = let find_instr n = let filter = function - | Sil.Store (Exp.Lvar pvar_, _, Exp.Const Const.Cint i, _) when Pvar.equal pvar pvar_ -> + | Sil.Store (Exp.Lvar pvar_, _, Exp.Const (Const.Cint i), _) when Pvar.equal pvar pvar_ -> IntLit.iszero i <> true_branch | _ -> false @@ -188,14 +188,14 @@ let rec find_normal_variable_load_ tenv (seen: Exp.Set.t) node id : DExp.t optio Sil.d_exp e ; L.d_ln () ) ; exp_lv_dexp_ tenv seen node e - | Sil.Call (Some (id0, _), Exp.Const Const.Cfun pn, (e, _) :: _, _, _) + | Sil.Call (Some (id0, _), Exp.Const (Const.Cfun pn), (e, _) :: _, _, _) when Ident.equal id id0 && Typ.Procname.equal pn (Typ.Procname.from_string_c_fun "__cast") -> if verbose then ( L.d_str "find_normal_variable_load cast on " ; Sil.d_exp e ; L.d_ln () ) ; exp_rv_dexp_ tenv seen node e - | Sil.Call (Some (id0, _), (Exp.Const Const.Cfun pname as fun_exp), args, loc, call_flags) + | Sil.Call (Some (id0, _), (Exp.Const (Const.Cfun pname) as fun_exp), args, loc, call_flags) when Ident.equal id id0 -> if verbose then ( L.d_str "find_normal_variable_load function call " ; @@ -447,9 +447,9 @@ let leak_from_list_abstraction hpred prop = let hpred_type = function | Sil.Hpointsto (_, _, texp) -> Some texp - | Sil.Hlseg (_, {Sil.body= [(Sil.Hpointsto (_, _, texp))]}, _, _, _) -> + | Sil.Hlseg (_, {Sil.body= [Sil.Hpointsto (_, _, texp)]}, _, _, _) -> Some texp - | Sil.Hdllseg (_, {Sil.body_dll= [(Sil.Hpointsto (_, _, texp))]}, _, _, _, _, _) -> + | Sil.Hdllseg (_, {Sil.body_dll= [Sil.Hpointsto (_, _, texp)]}, _, _, _, _, _) -> Some texp | _ -> None @@ -513,7 +513,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = in let res_action_opt, resource_opt, vpath = match alloc_att_opt with - | Some PredSymb.Aresource ({ra_kind= Racquire} as ra) -> + | Some (PredSymb.Aresource ({ra_kind= Racquire} as ra)) -> (Some ra, Some ra.ra_res, ra.ra_vpath) | _ -> (None, None, None) @@ -524,9 +524,9 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = (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, _)}} -> + | Some (Exp.Sizeof {typ= t1}), Some (Exp.Sizeof {typ= {Typ.desc= Tptr (t2, _)}}) -> Typ.equal t1 t2 - | Some Exp.Sizeof {typ= {Typ.desc= Tint _}}, Some Exp.Sizeof {typ= {Typ.desc= Tint _}} + | Some (Exp.Sizeof {typ= {Typ.desc= Tint _}}), Some (Exp.Sizeof {typ= {Typ.desc= Tint _}}) when is_file -> (* must be a file opened with "open" *) true @@ -540,7 +540,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 " ; @@ -551,7 +551,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = Some (DExp.to_string de) | _ -> None ) - | Some Sil.Abstract _ -> + | Some (Sil.Abstract _) -> if verbose then ( L.d_str "explain_leak: current instruction is Abstract" ; L.d_ln () ) ; @@ -570,7 +570,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = List.filter ~f:(fun pvar -> not (Pvar.is_frontend_tmp pvar)) nullify_pvars in value_str_from_pvars_vpath nullify_pvars_notmp vpath - | Some Sil.Store (lexp, _, _, _) when is_none vpath + | Some (Sil.Store (lexp, _, _, _)) when is_none vpath -> ( if verbose then ( L.d_str "explain_leak: current instruction Set for " ; @@ -686,7 +686,7 @@ let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = 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 -> + 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) @@ -738,7 +738,7 @@ let explain_dexp_access prop dexp is_nullable = let sexpo_to_inst = function | None -> None - | Some Sil.Eexp (_, inst) -> + | Some (Sil.Eexp (_, inst)) -> Some inst | Some se -> if verbose then ( @@ -783,7 +783,7 @@ let explain_dexp_access prop dexp is_nullable = match (lookup de1, lookup de2) with | None, _ | _, None -> None - | Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) -> + | Some (Sil.Earray (_, esel, _)), Some (Sil.Eexp (e, _)) -> lookup_esel esel e | Some se1, Some se2 -> if verbose then ( @@ -797,7 +797,7 @@ let explain_dexp_access prop dexp is_nullable = match lookup (DExp.Dpvaraddr pvar) with | None -> None - | Some Sil.Estruct (fsel, _) -> + | Some (Sil.Estruct (fsel, _)) -> lookup_fld fsel f | Some _ -> if verbose then ( @@ -808,7 +808,7 @@ let explain_dexp_access prop dexp is_nullable = match lookup (DExp.Dderef de1) with | None -> None - | Some Sil.Estruct (fsel, _) -> + | Some (Sil.Estruct (fsel, _)) -> lookup_fld fsel f | Some _ -> if verbose then ( @@ -819,9 +819,9 @@ let explain_dexp_access prop dexp is_nullable = match lookup de1 with | None -> None - | Some Sil.Estruct (fsel, _) -> + | Some (Sil.Estruct (fsel, _)) -> lookup_fld fsel f - | Some (Sil.Eexp (Const Cfun _, _) as fun_strexp) -> + | Some (Sil.Eexp (Const (Cfun _), _) as fun_strexp) -> Some fun_strexp | Some _ -> if verbose then ( @@ -832,7 +832,7 @@ let explain_dexp_access prop dexp is_nullable = if verbose then ( L.d_str "lookup: found Dpvar " ; L.d_ln () ) ; find_ptsto (Exp.Lvar pvar) | DExp.Dderef de -> ( - match lookup de with None -> None | Some Sil.Eexp (e, _) -> find_ptsto e | Some _ -> None ) + match lookup de with None -> None | Some (Sil.Eexp (e, _)) -> find_ptsto e | Some _ -> None ) | 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 @@ -901,7 +901,7 @@ let create_dereference_desc proc_name tenv ?(use_buckets= false) ?(outermost_arr let value_str, access_opt = explain_dereference_access outermost_array is_nullable de_opt prop in let access_opt' = match access_opt with - | Some Localise.Last_accessed _ when outermost_array -> + | Some (Localise.Last_accessed _) when outermost_array -> None (* don't report last accessed for arrays *) | _ -> access_opt @@ -910,23 +910,24 @@ let create_dereference_desc proc_name tenv ?(use_buckets= false) ?(outermost_arr let desc = if Language.curr_language_is Clang && not is_premature_nil then match de_opt with - | Some DExp.Dpvar pvar | Some DExp.Dpvaraddr pvar -> ( + | Some (DExp.Dpvar pvar) | Some (DExp.Dpvaraddr pvar) -> ( match Attribute.get_objc_null tenv prop (Exp.Lvar pvar) with - | Some Apred (Aobjc_null, [_; vfs]) -> + | Some (Apred (Aobjc_null, [_; vfs])) -> Localise.parameter_field_not_null_checked_desc desc vfs | _ -> desc ) - | Some DExp.Dretcall (Dconst Cfun pname, this_dexp :: _, loc, _) -> + | Some (DExp.Dretcall (Dconst (Cfun pname), this_dexp :: _, loc, _)) -> if is_mutex_method pname then Localise.desc_double_lock (Some pname) (DExp.to_string this_dexp) loc else if is_vector_method pname then Localise.desc_empty_vector_access (Some pname) (DExp.to_string this_dexp) loc else desc - | Some DExp.Darrow (dexp, fieldname) | Some DExp.Ddot (dexp, fieldname) -> + | Some (DExp.Darrow (dexp, fieldname)) | Some (DExp.Ddot (dexp, fieldname)) -> if is_special_field mutex_matcher (Some "null_if_locked") fieldname then Localise.desc_double_lock None (DExp.to_string dexp) loc - else if is_special_field vector_matcher (Some "beginPtr") fieldname - || is_special_field vector_matcher (Some "endPtr") fieldname + else if + is_special_field vector_matcher (Some "beginPtr") fieldname + || is_special_field vector_matcher (Some "endPtr") fieldname then Localise.desc_empty_vector_access None (DExp.to_string dexp) loc else desc | _ -> @@ -998,19 +999,19 @@ let explain_access_ proc_name tenv ?(use_buckets= false) ?(outermost_array= fals loc = let find_exp_dereferenced () = match State.get_instr () with - | Some Sil.Store (e, _, _, _) -> + | Some (Sil.Store (e, _, _, _)) -> if verbose then ( L.d_str "explain_dereference Sil.Store " ; Sil.d_exp e ; L.d_ln () ) ; Some e - | Some Sil.Load (_, e, _, _) -> + | Some (Sil.Load (_, e, _, _)) -> if verbose then ( L.d_str "explain_dereference Binop.Leteref " ; Sil.d_exp e ; L.d_ln () ) ; Some e - | Some Sil.Call (_, Exp.Const Const.Cfun fn, [(e, _)], _, _) + | Some (Sil.Call (_, Exp.Const (Const.Cfun fn), [(e, _)], _, _)) when List.exists ~f:(Typ.Procname.equal fn) [BuiltinDecl.free; BuiltinDecl.__delete; BuiltinDecl.__delete_array] -> if verbose then ( @@ -1018,7 +1019,7 @@ let explain_access_ proc_name tenv ?(use_buckets= false) ?(outermost_array= fals Sil.d_exp e ; L.d_ln () ) ; Some e - | Some Sil.Call (_, (Exp.Var _ as e), _, _, _) -> + | Some (Sil.Call (_, (Exp.Var _ as e), _, _, _)) -> if verbose then ( L.d_str "explain_dereference Sil.Call " ; Sil.d_exp e ; @@ -1082,7 +1083,7 @@ let explain_nth_function_parameter proc_name tenv use_buckets deref_str prop n p let node = State.get_node () in let loc = State.get_loc () in match State.get_instr () with - | Some Sil.Call (_, _, args, _, _) -> ( + | Some (Sil.Call (_, _, args, _, _)) -> ( try let arg = fst (List.nth_exn args (n - 1)) in let dexp_opt = exp_rv_dexp tenv node arg in @@ -1208,7 +1209,7 @@ let explain_unreachable_code_after loc = Localise.desc_unreachable_code_after lo let explain_stack_variable_address_escape loc pvar addr_dexp_opt = let addr_dexp_str = match addr_dexp_opt with - | Some DExp.Dpvar pv + | Some (DExp.Dpvar pv) when Pvar.is_local pv && Mangled.equal (Pvar.get_name pv) Ident.name_return -> Some "the caller via a return" | Some dexp -> diff --git a/infer/src/backend/exe_env.ml b/infer/src/backend/exe_env.ml index 7cea10f16..004ef811a 100644 --- a/infer/src/backend/exe_env.ml +++ b/infer/src/backend/exe_env.ml @@ -32,7 +32,7 @@ let create_file_data table source = match SourceFile.Hash.find table source with | file_data -> file_data - | exception Not_found -> + | exception Caml.Not_found -> let file_data = new_file_data source in SourceFile.Hash.add table source file_data ; file_data @@ -44,7 +44,7 @@ type t = ; source_file: SourceFile.t (** source file being analyzed *) } let get_file_data exe_env pname = - try Some (Typ.Procname.Hash.find exe_env.proc_map pname) with Not_found -> + try Some (Typ.Procname.Hash.find exe_env.proc_map pname) with Caml.Not_found -> let source_file_opt = match Attributes.load pname with | None -> @@ -114,12 +114,8 @@ let get_cfg exe_env pname = (** return the proc desc associated to the procedure *) let get_proc_desc exe_env pname = match get_cfg exe_env pname with - | Some cfg -> ( - match Typ.Procname.Hash.find cfg pname with - | proc_desc -> - Some proc_desc - | exception Not_found -> - None ) + | Some cfg -> + Typ.Procname.Hash.find_opt cfg pname | None -> None diff --git a/infer/src/backend/inferconfig.ml b/infer/src/backend/inferconfig.ml index b09860243..e665e0408 100644 --- a/infer/src/backend/inferconfig.ml +++ b/infer/src/backend/inferconfig.ml @@ -41,7 +41,7 @@ let is_matching patterns source_file = let path = SourceFile.to_rel_path source_file in List.exists ~f:(fun pattern -> - try Int.equal (Str.search_forward pattern path 0) 0 with Not_found -> false ) + try Int.equal (Str.search_forward pattern path 0) 0 with Caml.Not_found -> false ) patterns @@ -61,7 +61,7 @@ module FileContainsStringMatcher = struct let file_contains regexp file_in = let rec loop () = try Str.search_forward regexp (In_channel.input_line_exn file_in) 0 >= 0 with - | Not_found -> + | Caml.Not_found -> loop () | End_of_file -> false @@ -75,7 +75,7 @@ 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 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 @@ -103,7 +103,11 @@ module FileOrProcMatcher = struct let pattern_map = List.fold ~f:(fun map pattern -> - let previous = try String.Map.find_exn map pattern.class_name with Not_found -> [] in + let previous = + try String.Map.find_exn map pattern.class_name with + | Not_found_s _ | Caml.Not_found -> + [] + in String.Map.set ~key:pattern.class_name ~data:(pattern :: previous) map ) ~init:String.Map.empty m_patterns in @@ -116,7 +120,9 @@ module FileOrProcMatcher = struct ~f:(fun p -> match p.method_name with None -> true | Some m -> String.equal m method_name ) class_patterns - with Not_found -> false + with + | Not_found_s _ | Caml.Not_found -> + false in fun _ proc_name -> match proc_name with Typ.Procname.Java pname_java -> do_java pname_java | _ -> false @@ -245,9 +251,9 @@ let patterns_of_json_with_key (json_key, json) = List.fold ~f:loop ~init:default_source_contains assoc in match detect_pattern assoc with - | Ok Method_pattern (language, _) -> + | Ok (Method_pattern (language, _)) -> Ok (Method_pattern (language, create_method_pattern assoc)) - | Ok Source_contains (language, _) -> + | Ok (Source_contains (language, _)) -> Ok (Source_contains (language, create_string_contains assoc)) | Error _ as error -> error diff --git a/infer/src/backend/ondemand.ml b/infer/src/backend/ondemand.ml index 509104a24..065c24c43 100644 --- a/infer/src/backend/ondemand.ml +++ b/infer/src/backend/ondemand.ml @@ -177,7 +177,7 @@ let analyze_proc_desc ~caller_pdesc callee_pdesc = if is_active callee_pname then None else let cache = Lazy.force cached_results in - try Typ.Procname.Hash.find cache callee_pname with Not_found -> + try Typ.Procname.Hash.find cache callee_pname with Caml.Not_found -> let summary_option = let proc_attributes = Procdesc.get_attributes callee_pdesc in if should_be_analyzed callee_pname proc_attributes then @@ -194,7 +194,7 @@ let analyze_proc_name ?caller_pdesc callee_pname = if is_active callee_pname then None else let cache = Lazy.force cached_results in - try Typ.Procname.Hash.find cache callee_pname with Not_found -> + try Typ.Procname.Hash.find cache callee_pname with Caml.Not_found -> let summary_option = let callbacks = Option.value_exn !callbacks_ref in if procedure_should_be_analyzed callee_pname then diff --git a/infer/src/backend/printer.ml b/infer/src/backend/printer.ml index 76dddad76..3d4287b5a 100644 --- a/infer/src/backend/printer.ml +++ b/infer/src/backend/printer.ml @@ -46,7 +46,7 @@ module LineReader = struct let file_data (hash: t) fname = - try Some (Hashtbl.find hash fname) with Not_found -> + 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 @@ -330,10 +330,11 @@ 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 node_id = Procdesc.Node.get_id node in - if NodesHtml.start_node - (node_id :> int) - loc proc_name (Procdesc.Node.get_preds node) (Procdesc.Node.get_succs node) - (Procdesc.Node.get_exn node) source + if + NodesHtml.start_node + (node_id :> int) + loc proc_name (Procdesc.Node.get_preds node) (Procdesc.Node.get_succs node) + (Procdesc.Node.get_exn node) source then F.fprintf !curr_html_formatter "%a%a%a" Io_infer.Html.pp_start_color Pp.Green @@ -371,7 +372,7 @@ let write_proc_html pdesc = if Config.write_html then ( let pname = Procdesc.get_proc_name pdesc in let source = (Procdesc.get_loc pdesc).file in - let nodes = List.sort ~cmp:Procdesc.Node.compare (Procdesc.get_nodes pdesc) in + let nodes = List.sort ~compare:Procdesc.Node.compare (Procdesc.get_nodes pdesc) in let linenum = (Procdesc.Node.get_loc (List.hd_exn nodes)).Location.line in let fd, fmt = Io_infer.Html.create (DB.Results_dir.Abs_source_dir source) [Typ.Procname.to_filename pname] @@ -400,7 +401,7 @@ let create_table_err_per_line err_log = try let set = Hashtbl.find err_per_line err_data.loc.Location.line in Hashtbl.replace err_per_line err_data.loc.Location.line (String.Set.add set err_str) - with Not_found -> + with Caml.Not_found -> Hashtbl.add err_per_line err_data.loc.Location.line (String.Set.singleton err_str) in Errlog.iter add_err err_log ; err_per_line @@ -415,7 +416,7 @@ let write_html_proc source proof_cover table_nodes_at_linenum global_err_log pro let proc_name = Procdesc.get_proc_name proc_desc in let process_node n = let lnum = (Procdesc.Node.get_loc n).Location.line in - let curr_nodes = try Hashtbl.find table_nodes_at_linenum lnum with Not_found -> [] in + let curr_nodes = try Hashtbl.find table_nodes_at_linenum lnum with Caml.Not_found -> [] in Hashtbl.replace table_nodes_at_linenum lnum (n :: curr_nodes) in let proc_loc = Procdesc.get_loc proc_desc in @@ -459,13 +460,13 @@ let write_html_file linereader filename procs = raise End_of_file in let nodes_at_linenum = - try Hashtbl.find table_nodes_at_linenum line_number with Not_found -> [] + try Hashtbl.find table_nodes_at_linenum line_number with Caml.Not_found -> [] in let errors_at_linenum = try let errset = Hashtbl.find table_err_per_line line_number in String.Set.elements errset - with Not_found -> [] + with Caml.Not_found -> [] in F.fprintf fmt "%d%s " line_number line_number line_html ; diff --git a/infer/src/backend/reporting.ml b/infer/src/backend/reporting.ml index 6c79c20bd..a31a47669 100644 --- a/infer/src/backend/reporting.ml +++ b/infer/src/backend/reporting.ml @@ -75,8 +75,8 @@ let log_issue_deprecated ?(store_summary= false) err_kind proc_name ?loc ?node_i | None -> L.(die InternalError) "Trying to report error on procedure %a, but cannot because no summary exists for this \ - procedure. Did you mean to log the error on the caller of %a instead?" Typ.Procname.pp - proc_name Typ.Procname.pp proc_name + procedure. Did you mean to log the error on the caller of %a instead?" + Typ.Procname.pp proc_name Typ.Procname.pp proc_name let log_error = log_issue_from_summary Exceptions.Kerror diff --git a/infer/src/backend/specs.ml b/infer/src/backend/specs.ml index 9160b9858..9c1723ace 100644 --- a/infer/src/backend/specs.ml +++ b/infer/src/backend/specs.ml @@ -27,10 +27,8 @@ module Jprop = struct let compare_id_ _ _ = 0 (** Remember when a prop is obtained as the join of two other props; the first parameter is an id *) - type 'a t = - | Prop of id_ * 'a Prop.t - | Joined of id_ * 'a Prop.t * 'a t * 'a t - [@@deriving compare] + type 'a t = Prop of id_ * 'a Prop.t | Joined of id_ * 'a Prop.t * 'a t * 'a t + [@@deriving compare] (** Comparison for joined_prop *) let compare jp1 jp2 = compare (fun _ _ -> 0) jp1 jp2 @@ -79,9 +77,9 @@ module Jprop = struct let rec pp_seq_newline f = function | [] -> () - | [(Prop (n, p))] -> + | [Prop (n, p)] -> F.fprintf f "PROP %d:@\n%a" n (Prop.pp_prop pe) p - | [(Joined (n, p, p1, p2))] -> + | [Joined (n, p, p1, p2)] -> if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p1] ; if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p2] ; F.fprintf f "PROP %d (join of %d,%d):@\n%a" n (get_id p1) (get_id p2) (Prop.pp_prop pe) p @@ -555,7 +553,7 @@ let load_summary_to_spec_table = let get_summary proc_name = - try Some (Typ.Procname.Hash.find spec_tbl proc_name) with Not_found -> + try Some (Typ.Procname.Hash.find spec_tbl proc_name) with Caml.Not_found -> load_summary_to_spec_table proc_name diff --git a/infer/src/base/CommandDoc.ml b/infer/src/base/CommandDoc.ml index 30cadb8b8..c6f6a5027 100644 --- a/infer/src/base/CommandDoc.ml +++ b/infer/src/base/CommandDoc.ml @@ -54,7 +54,7 @@ let analyze = ~synopsis:{|$(b,infer) $(b,analyze) $(i,[options]) $(b,infer) $(i,[options])|} ~description:[`P "Analyze the files captured in the project results directory and report."] - ~see_also:InferCommand.([Report; Run]) + ~see_also:InferCommand.[Report; Run] let capture = @@ -78,7 +78,7 @@ $(b,infer) $(b,capture) $(i,[--no-xcpretty]) $(i,[options]) $(b,--) $(b,xcodebui intercepts calls to the compiler to read source files, translate them into infer's \ intermediate representation, and store the result of the translation in the results \ directory." ] - ~see_also:InferCommand.([Analyze; Compile; Run]) + ~see_also:InferCommand.[Analyze; Compile; Run] let compile = @@ -112,7 +112,7 @@ let compile = cmake -DCMAKE_EXPORT_COMPILE_COMMANDS=1 .. infer capture --compilation-database compile_commands.json|} ] - ~see_also:InferCommand.([Capture]) + ~see_also:InferCommand.[Capture] let diff = @@ -120,7 +120,7 @@ let diff = ~short_description:"Report the difference between two versions of a project" ~synopsis:"$(b,infer) $(b,diff) $(i,[options])" ~description:[`P "EXPERIMENTAL AND IN NO WAY READY TO USE"] - ~see_also:InferCommand.([ReportDiff; Run]) + ~see_also:InferCommand.[ReportDiff; Run] let explore = @@ -136,7 +136,7 @@ $(b,infer) $(b,explore) $(b,--procedures) $(i,[options])|} ; `P "If $(b,--procedures) is passed, print information about each procedure captured by \ infer." ] - ~see_also:InferCommand.([Report; Run]) + ~see_also:InferCommand.[Report; Run] let infer = @@ -174,9 +174,9 @@ $(b,infer) $(i,[options])|} variable, then from the command line. Options in $(b,%s) take precedence over \ options in $(b,%s), and options passed on the command line take precedence over \ options in $(b,%s). See the $(i,%s) and $(i,%s) sections of this manual for more \ - information." inferconfig_file CLOpt.args_env_var CLOpt.args_env_var - inferconfig_file CLOpt.args_env_var Cmdliner.Manpage.s_environment - Cmdliner.Manpage.s_files) + information." + inferconfig_file CLOpt.args_env_var CLOpt.args_env_var inferconfig_file + CLOpt.args_env_var Cmdliner.Manpage.s_environment Cmdliner.Manpage.s_files) ; `P "Options can be specified inside an argument file $(i,file) by passing \ $(b,@)$(i,file) as argument. The format is one option per line, and enclosing single \ @@ -196,8 +196,9 @@ $(b,infer) $(i,[options])|} "Extra arguments may be passed to all infer commands using the $(b,%s) environment \ variable (see the $(i,%s) section). $(b,%s) is expected to contain a string of \ %c-separated options. For instance, calling `%s=--debug^--print-logs infer` is \ - equivalent to calling `infer --debug --print-logs`." CLOpt.args_env_var - Cmdliner.Manpage.s_options CLOpt.args_env_var CLOpt.env_var_sep CLOpt.args_env_var) + equivalent to calling `infer --debug --print-logs`." + CLOpt.args_env_var Cmdliner.Manpage.s_options CLOpt.args_env_var CLOpt.env_var_sep + CLOpt.args_env_var) ; `P (Printf.sprintf "$(b,%s): Tells infer where to find the %s file. (See the %s section)" inferconfig_env_var inferconfig_file Cmdliner.Manpage.s_files) @@ -205,13 +206,15 @@ $(b,infer) $(i,[options])|} (Printf.sprintf "If $(b,%s) is set to \"1\", then infer commands will exit with an error code in \ some cases when otherwise a simple warning would be emitted on stderr, for instance \ - if a deprecated form of an option is used." CLOpt.strict_mode_env_var) ] + if a deprecated form of an option is used." + CLOpt.strict_mode_env_var) ] ~files: [ `P (Printf.sprintf "$(b,%s) can be used to store infer options. Its format is that of a JSON record, \ where fields are infer long-form options, without their leading \"--\", and values \ - depend on the type of the option:" inferconfig_file) + depend on the type of the option:" + inferconfig_file) ; `Noblank ; `P "- for switches options, the value is a JSON boolean (true or false, without quotes)" ; `Noblank @@ -222,13 +225,15 @@ $(b,infer) $(i,[options])|} ; `P (Printf.sprintf "- path options have string values, and are interpreted relative to the location of \ - the %s file" inferconfig_file) + the %s file" + inferconfig_file) ; `Noblank ; `P "- cumulative options are JSON arrays of the appropriate type" ; `P (Printf.sprintf "Infer will look for an $(b,%s) file in the current directory, then its parent, \ - etc., stopping at the first $(b,%s) file found." inferconfig_file inferconfig_file) + etc., stopping at the first $(b,%s) file found." + inferconfig_file inferconfig_file) ; `P "Example:" ; `Pre {| { @@ -248,7 +253,7 @@ let report = ; `P "If no specs file are passed on the command line, process all the .specs in the results \ directory." ] - ~see_also:InferCommand.([ReportDiff; Run]) + ~see_also:InferCommand.[ReportDiff; Run] let reportdiff = @@ -272,7 +277,7 @@ let reportdiff = "- $(b,preexisting.json) contains the issues found in both $(i,previous) and \ $(i,current)." ; `P "All three files follow the same format as normal infer reports." ] - ~see_also:InferCommand.([Report]) + ~see_also:InferCommand.[Report] let events = @@ -283,7 +288,7 @@ let events = [ `P "Emit to stdout one JSON object per line, each describing a logged event happened \ during the execution of Infer" ] - ~see_also:InferCommand.([Report; Run]) + ~see_also:InferCommand.[Report; Run] let run = @@ -298,7 +303,7 @@ $(b,infer) $(i,[options]) $(b,--) $(i,compile command)|} following sequence of commands:" ; `Pre {|$(b,infer) $(b,capture) $(i,[options]) $(b,infer) $(b,analyze) $(i,[options])|} ] - ~see_also:InferCommand.([Analyze; Capture; Report]) + ~see_also:InferCommand.[Analyze; Capture; Report] let command_to_data = diff --git a/infer/src/base/CommandLineOption.ml b/infer/src/base/CommandLineOption.ml index a9784d425..0f0e63350 100644 --- a/infer/src/base/CommandLineOption.ml +++ b/infer/src/base/CommandLineOption.ml @@ -153,7 +153,8 @@ let check_no_duplicates desc_list = | _ :: tl -> check_for_duplicates_ tl in - check_for_duplicates_ (List.sort ~cmp:(fun (x, _, _) (y, _, _) -> String.compare x y) desc_list) + check_for_duplicates_ + (List.sort ~compare:(fun (x, _, _) (y, _, _) -> String.compare x y) desc_list) let parse_mode_desc_lists = List.map ~f:(fun parse_mode -> (parse_mode, ref [])) all_parse_modes @@ -192,7 +193,7 @@ let add parse_mode sections desc = let sections = List.Assoc.find_exn ~equal:InferCommand.equal help_sections_desc_lists command in - let prev_contents = try SectionMap.find section !sections with Not_found -> [] in + let prev_contents = try SectionMap.find section !sections with Caml.Not_found -> [] in sections := SectionMap.add section (desc :: prev_contents) !sections in List.iter sections ~f:add_to_section ; @@ -219,7 +220,7 @@ 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 ~cmp: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 @@ -620,7 +621,7 @@ let normalize_desc_list speclist = let lower_norm s = String.lowercase @@ norm s in String.compare (lower_norm x) (lower_norm y) in - let sort speclist = List.sort ~cmp:compare_specs speclist in + let sort speclist = List.sort ~compare:compare_specs speclist in sort speclist @@ -677,9 +678,9 @@ let set_curr_speclist_for_parse_mode ~usage parse_mode = let full_desc_list = 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 ; + curr_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 @@ -712,7 +713,7 @@ let mk_subcommand command ?on_unknown_arg:(on_unknown = `Reject) ~name ?deprecat ?in_help command_doc = let switch () = curr_command := Some command ; - anon_arg_action := {(!anon_arg_action) with on_unknown} + anon_arg_action := {!anon_arg_action with on_unknown} in ( match deprecated_long with | Some long -> @@ -750,8 +751,9 @@ let anon_fun arg = if !anon_arg_action.parse_argfiles && String.is_prefix arg ~prefix:"@" then (* stop parsing the current args and go look in that argfile *) raise (SubArguments (args_from_argfile arg)) - else if !anon_arg_action.parse_subcommands - && List.Assoc.mem !subcommand_actions ~equal:String.equal arg + else if + !anon_arg_action.parse_subcommands + && List.Assoc.mem !subcommand_actions ~equal:String.equal arg then let command_switch = List.Assoc.find_exn !subcommand_actions ~equal:String.equal arg in match (!curr_command, is_originator) with @@ -796,7 +798,7 @@ let decode_inferconfig_to_argv path = in decode_json ~inferconfig_dir json_val @ result with - | Not_found -> + | Not_found_s _ | Caml.Not_found -> warnf "WARNING: while reading config file %s:@\nUnknown option %s@." path key ; result | YBU.Type_error (msg, json) -> @@ -816,9 +818,9 @@ let encode_argv_to_env argv = ~f:(fun arg -> not (String.contains arg env_var_sep) || - (warnf "WARNING: Ignoring unsupported option containing '%c' character: %s@\n" env_var_sep - arg ; - false) ) + ( warnf "WARNING: Ignoring unsupported option containing '%c' character: %s@\n" + env_var_sep arg ; + false ) ) argv) diff --git a/infer/src/base/CommandLineOption.mli b/infer/src/base/CommandLineOption.mli index 0c8c93b49..bb141e2dd 100644 --- a/infer/src/base/CommandLineOption.mli +++ b/infer/src/base/CommandLineOption.mli @@ -18,7 +18,7 @@ type parse_mode = | InferCommand (** parse arguments as arguments for infer *) | Javac (** parse arguments passed to the Java compiler *) | NoParse (** all arguments are anonymous arguments, no parsing is attempted *) - [@@deriving compare] +[@@deriving compare] val is_originator : bool diff --git a/infer/src/base/Config.ml b/infer/src/base/Config.ml index 190e97f4a..faf2215c2 100644 --- a/infer/src/base/Config.ml +++ b/infer/src/base/Config.ml @@ -18,13 +18,8 @@ module F = Format module CLOpt = CommandLineOption module L = Die -type analyzer = - | CaptureOnly - | CompileOnly - | Checkers - | Crashcontext - | Linters - [@@deriving compare] +type analyzer = CaptureOnly | CompileOnly | Checkers | Crashcontext | Linters +[@@deriving compare] let equal_analyzer = [%compare.equal : analyzer] @@ -83,7 +78,7 @@ type compilation_database_dependencies = (* get the compilation database of the dependencies up to depth n by [Deps (Some n)], or all by [Deps None] *) | NoDeps - [@@deriving compare] +[@@deriving compare] type build_system = | BAnalyze @@ -98,7 +93,7 @@ type build_system = | BNdk | BPython | BXcode - [@@deriving compare] +[@@deriving compare] let equal_build_system = [%compare.equal : build_system] @@ -131,8 +126,9 @@ let build_system_exe_assoc = let build_system_of_exe_name name = - try List.Assoc.find_exn ~equal:String.equal (List.Assoc.inverse build_system_exe_assoc) name - with Not_found -> L.(die InternalError) "Unsupported build command %s" name + try List.Assoc.find_exn ~equal:String.equal (List.Assoc.inverse build_system_exe_assoc) name with + | Not_found_s _ | Caml.Not_found -> + L.(die InternalError) "Unsupported build command %s" name let string_of_build_system build_system = @@ -606,7 +602,7 @@ and ( analysis_blacklist_files_containing_options (let long = "-" ^ suffix in CLOpt.mk_string_list ~long ~meta ~f:(fun _ -> raise (Arg.Bad "invalid option")) - ~in_help:InferCommand.([(Report, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic); (Run, manual_generic)] help) ; List.map ~f:(fun (name, analyzer) -> (analyzer, mk_option analyzer name)) string_to_analyzer in @@ -614,11 +610,13 @@ and ( analysis_blacklist_files_containing_options ~deprecated_suffix:["blacklist_files_containing"] ~help: "blacklist files containing the specified string for the given analyzer (see \ - $(b,--analyzer) for valid values)" ~meta:"string" + $(b,--analyzer) for valid values)" + ~meta:"string" , mk_filtering_options ~suffix:"blacklist-path-regex" ~deprecated_suffix:["blacklist"] ~help: "blacklist the analysis of files whose relative path matches the specified OCaml-style \ - regex (to whitelist: $(b,---whitelist-path-regex))" ~meta:"path_regex" + regex (to whitelist: $(b,---whitelist-path-regex))" + ~meta:"path_regex" , mk_filtering_options ~suffix:"whitelist-path-regex" ~deprecated_suffix:["whitelist"] ~help:"" ~meta:"path_regex" , mk_filtering_options ~suffix:"suppress-errors" ~deprecated_suffix:["suppress_errors"] @@ -643,7 +641,7 @@ and analyzer = () in CLOpt.mk_symbol_opt ~deprecated:["analyzer"] ~long:"analyzer" ~short:'a' - ~in_help:InferCommand.([(Analyze, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic); (Run, manual_generic)] {|Specify which analyzer to run (only one at a time is supported): - $(b,biabduction): run the bi-abduction based checker only, in particular to check for memory errors - $(b,checkers): run the default checkers, including the bi-abduction based checker for memory errors (default) @@ -661,7 +659,8 @@ and analyzer = CLOpt.warnf "WARNING: The analyzer '%s' is deprecated, use the '%s' subcommand instead:@\n\ @\n \ - infer %s ..." analyzer_str analyzer_str analyzer_str ; + infer %s ..." + analyzer_str analyzer_str analyzer_str ; x | _ as x -> x) @@ -692,7 +691,7 @@ and ( annotation_reachability let mk_checker ?(default= false) ?(deprecated= []) ~long doc = let var = CLOpt.mk_bool ~long - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] ~default ~deprecated doc in all_checkers := (var, long, doc, default) :: !all_checkers ; @@ -749,7 +748,7 @@ and ( annotation_reachability let mk_only (var, long, doc, _) = let _ : bool ref = CLOpt.mk_bool_group ~long:(long ^ "-only") - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] ~f:(fun b -> disable_all_checkers () ; var := b ; @@ -765,7 +764,7 @@ and ( annotation_reachability List.iter ~f:mk_only !all_checkers ; let _default_checkers : bool ref = CLOpt.mk_bool_group ~long:"default-checkers" - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] ~default:true ( "Default checkers: " ^ ( List.rev_filter_map @@ -807,7 +806,7 @@ and ( annotation_reachability and annotation_reachability_custom_pairs = CLOpt.mk_json ~long:"annotation-reachability-custom-pairs" - ~in_help:InferCommand.([(Analyze, manual_java)]) + ~in_help:InferCommand.[(Analyze, manual_java)] {|Specify custom sources/sink for the annotation reachability checker Example format: for custom annotations com.my.annotation.{Source1,Source2,Sink1} { "sources" : ["Source1", "Source2"], "sink" : "Sink1" }|} @@ -815,7 +814,7 @@ Example format: for custom annotations com.my.annotation.{Source1,Source2,Sink1} and append_buck_flavors = CLOpt.mk_string_list ~long:"append-buck-flavors" - ~in_help:InferCommand.([(Capture, manual_buck_flavors)]) + ~in_help:InferCommand.[(Capture, manual_buck_flavors)] "Additional Buck flavors to append to targets discovered by the \ $(b,--buck-compilation-database) option." @@ -831,13 +830,13 @@ and array_level = and blacklist = CLOpt.mk_string_opt ~deprecated:["-blacklist-regex"; "-blacklist"] ~long:"buck-blacklist" - ~in_help:InferCommand.([(Run, manual_buck_flavors); (Capture, manual_buck_flavors)]) + ~in_help:InferCommand.[(Run, manual_buck_flavors); (Capture, manual_buck_flavors)] ~meta:"regex" "Skip analysis of files matched by the specified regular expression" and bootclasspath = CLOpt.mk_string_opt ~long:"bootclasspath" - ~in_help:InferCommand.([(Capture, manual_java)]) + ~in_help:InferCommand.[(Capture, manual_java)] "Specify the Java bootclasspath" @@ -846,27 +845,28 @@ and buck = CLOpt.mk_bool ~long:"buck" "" and buck_build_args = CLOpt.mk_string_list ~long:"Xbuck" - ~in_help:InferCommand.([(Capture, manual_buck_flavors)]) + ~in_help:InferCommand.[(Capture, manual_buck_flavors)] "Pass values as command-line arguments to invocations of $(i,`buck build`)" and buck_compilation_database_depth = CLOpt.mk_int_opt ~long:"buck-compilation-database-depth" - ~in_help:InferCommand.([(Capture, manual_buck_compilation_db)]) + ~in_help:InferCommand.[(Capture, manual_buck_compilation_db)] "Depth of dependencies used by the $(b,--buck-compilation-database deps) option. By default, \ - all recursive dependencies are captured." ~meta:"int" + all recursive dependencies are captured." + ~meta:"int" and buck_compilation_database = CLOpt.mk_symbol_opt ~long:"buck-compilation-database" ~deprecated:["-use-compilation-database"] - ~in_help:InferCommand.([(Capture, manual_buck_compilation_db)]) + ~in_help:InferCommand.[(Capture, manual_buck_compilation_db)] "Buck integration using the compilation database, with or without dependencies." ~symbols:[("no-deps", `NoDeps); ("deps", `DepsTmp)] and buck_out = CLOpt.mk_path_opt ~long:"buck-out" - ~in_help:InferCommand.([(Capture, manual_buck_java)]) + ~in_help:InferCommand.[(Capture, manual_buck_java)] ~meta:"dir" "Specify the root directory of buck-out" @@ -877,7 +877,7 @@ and capture = and changed_files_index = CLOpt.mk_path_opt ~long:"changed-files-index" - ~in_help:InferCommand.([(Analyze, manual_generic); (Diff, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic); (Diff, manual_generic)] ~meta:"file" "Specify the file containing the list of source files from which reactive analysis should \ start. Source files should be specified relative to project root or be absolute" @@ -890,7 +890,7 @@ and check_version = and clang_biniou_file = CLOpt.mk_path_opt ~long:"clang-biniou-file" - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] ~meta:"file" "Specify a file containing the AST of the program, in biniou format" @@ -898,7 +898,7 @@ and clang_compilation_dbs = ref [] and clang_frontend_action = CLOpt.mk_symbol_opt ~long:"" ~deprecated:["-clang-frontend-action"] - ~in_help:InferCommand.([(Capture, manual_clang); (Run, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang); (Run, manual_clang)] (* doc only shows up in deprecation warnings *) "use --capture and --linters instead" ~symbols:clang_frontend_action_symbols @@ -927,21 +927,21 @@ and cluster = and compilation_database = CLOpt.mk_path_list ~long:"compilation-database" ~deprecated:["-clang-compilation-db-files"] - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "File that contain compilation commands (can be specified multiple times)" and compilation_database_escaped = CLOpt.mk_path_list ~long:"compilation-database-escaped" ~deprecated:["-clang-compilation-db-files-escaped"] - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "File that contain compilation commands where all entries are escaped for the shell, eg \ coming from Xcode (can be specified multiple times)" and compute_analytics = CLOpt.mk_bool ~long:"compute-analytics" ~default:false - ~in_help:InferCommand.([(Capture, manual_clang); (Run, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang); (Run, manual_clang)] "Emit analytics as info-level issues, like component kit line count and component kit file \ cyclomatic complexity" @@ -950,14 +950,14 @@ and compute_analytics = If a procedure was changed beforehand, keep the changed marking. *) and continue = CLOpt.mk_bool ~deprecated:["continue"] ~long:"continue" - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] "Continue the capture for the reactive analysis, increasing the changed files/procedures. (If \ a procedure was changed beforehand, keep the changed marking.)" and current_to_previous_script = CLOpt.mk_string_opt ~long:"current-to-previous-script" - ~in_help:InferCommand.([(Diff, manual_generic)]) + ~in_help:InferCommand.[(Diff, manual_generic)] ~meta:"shell" "Specify a script to checkout a previous version of the project to compare against, assuming \ we are on the current version already." @@ -965,7 +965,7 @@ and current_to_previous_script = and cxx_infer_headers = CLOpt.mk_bool ~long:"cxx-infer-headers" ~default:false - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "Include C++ header models during compilation. Infer swaps some C++ headers for its own in \ order to get a better model of, eg, the standard library. This can sometimes cause \ compilation failures." @@ -973,14 +973,14 @@ and cxx_infer_headers = and cxx_scope_guards = CLOpt.mk_json ~long:"cxx-scope-guards" - ~in_help:InferCommand.([(Analyze, manual_clang)]) + ~in_help:InferCommand.[(Analyze, manual_clang)] "Specify scope guard classes that can be read only by destructors without being reported as \ dead stores." and cxx = CLOpt.mk_bool ~long:"cxx" ~default:true - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "Analyze C++ methods" @@ -1012,7 +1012,7 @@ and ( bo_debug in let bo_debug = CLOpt.mk_int ~default:0 ~long:"bo-debug" - ~in_help:InferCommand.([(Analyze, manual_buffer_overrun)]) + ~in_help:InferCommand.[(Analyze, manual_buffer_overrun)] "Debug level for buffer-overrun checker (0-4)" and debug_level_analysis = CLOpt.mk_int ~long:"debug-level-analysis" ~default:0 ~in_help:all_generic_manuals @@ -1030,7 +1030,7 @@ and ( bo_debug "Show internal exceptions" and filtering = CLOpt.mk_bool ~deprecated_no:["nf"] ~long:"filtering" ~short:'f' ~default:true - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] "Do not show the experimental and blacklisted issue types" and only_cheap_debug = CLOpt.mk_bool ~long:"only-cheap-debug" ~default:true "Disable expensive debugging output" @@ -1041,7 +1041,7 @@ and ( bo_debug CLOpt.mk_bool ~long:"print-types" ~default:false "Print types in symbolic heaps" and keep_going = CLOpt.mk_bool ~deprecated_no:["-no-failures-allowed"] ~long:"keep-going" - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] "Keep going when the analysis encounters a failure" and reports_include_ml_loc = CLOpt.mk_bool ~deprecated:["with_infer_src_loc"] ~long:"reports-include-ml-loc" @@ -1090,32 +1090,33 @@ and ( bo_debug CLOpt.mk_bool_group ~long:"debug-exceptions" "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] + $(b,--reports-include-ml-loc))" + [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)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] ~default:true "Use the default linters for the analysis." and frontend_tests = CLOpt.mk_bool_group ~long:"frontend-tests" - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "Save filename.ext.test.dot with the cfg in dotty format for frontend tests (also sets \ - $(b,--print-types))" [print_types] [] + $(b,--print-types))" + [print_types] [] and models_mode = CLOpt.mk_bool_group ~long:"models-mode" "Mode for analyzing the models" [] [keep_going] and print_logs = CLOpt.mk_bool ~long:"print-logs" ~in_help: - InferCommand.( + InferCommand. [ (Analyze, manual_generic) ; (Capture, manual_generic) ; (Run, manual_generic) - ; (Report, manual_generic) ]) + ; (Report, manual_generic) ] "Also log messages to stdout and stderr" in let linters_developer_mode = CLOpt.mk_bool_group ~long:"linters-developer-mode" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] "Debug mode for developing new linters. (Sets the analyzer to $(b,linters); also sets \ $(b,--debug), $(b,--debug-level-linters 2), $(b,--developer-mode), and unsets \ $(b,--allowed-failures) and $(b,--default-linters)." @@ -1150,14 +1151,14 @@ and ( bo_debug and dependencies = CLOpt.mk_bool ~deprecated:["dependencies"] ~long:"dependencies" - ~in_help:InferCommand.([(Capture, manual_java)]) + ~in_help:InferCommand.[(Capture, manual_java)] "Translate all the dependencies during the capture. The classes in the given jar file will be \ translated. No sources needed." and differential_filter_files = CLOpt.mk_string_opt ~long:"differential-filter-files" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] "Specify the file containing the list of source files for which a differential report is \ desired. Source files should be specified relative to project root or be absolute" @@ -1179,7 +1180,7 @@ and () = let issue = IssueType.from_string issue_id in IssueType.set_enabled issue b ; issue_id ) ?default ~meta:"issue_type" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] doc in () @@ -1196,10 +1197,8 @@ and () = issue types. This option provides fine-grained filtering over which types of issue should \ be reported once the checkers have run. In particular, note that disabling issue types \ does not make the corresponding checker not run.\n \ - By default, the following issue types are disabled: %s.\n\ - \n \ - See also $(b,--report-issue-type).\n\ - " + 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"] "Show reports coming from this type of issue. By default, all issue types are enabled except \ @@ -1214,7 +1213,7 @@ and dotty_cfg_libs = and dump_duplicate_symbols = CLOpt.mk_bool ~long:"dump-duplicate-symbols" - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "Dump all symbols with the same name that are defined in more than one file." @@ -1248,7 +1247,7 @@ and eradicate_verbose = and external_java_packages = CLOpt.mk_string_list ~long:"external-java-packages" - ~in_help:InferCommand.([(Analyze, manual_java)]) + ~in_help:InferCommand.[(Analyze, manual_java)] ~meta:"prefix" "Specify a list of Java package prefixes for external Java packages. If set, the analysis \ will not report non-actionable warnings on those packages." @@ -1256,7 +1255,7 @@ and external_java_packages = and fail_on_bug = CLOpt.mk_bool ~deprecated:["-fail-on-bug"] ~long:"fail-on-issue" ~default:false - ~in_help:InferCommand.([(Run, manual_generic)]) + ~in_help:InferCommand.[(Run, manual_generic)] (Printf.sprintf "Exit with error code %d if Infer found something to report" fail_on_issue_exit_code) @@ -1269,7 +1268,7 @@ and fcp_syntax_only = CLOpt.mk_bool ~long:"fcp-syntax-only" "Skip creation of ob and file_renamings = CLOpt.mk_path_opt ~long:"file-renamings" - ~in_help:InferCommand.([(ReportDiff, manual_generic)]) + ~in_help:InferCommand.[(ReportDiff, manual_generic)] "JSON with a list of file renamings to use while computing differential reports" @@ -1279,7 +1278,7 @@ and filter_paths = and filter_report = CLOpt.mk_string_list ~long:"filter-report" - ~in_help:InferCommand.([(Report, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic); (Run, manual_generic)] "Specify a filter for issues to report. If multiple filters are specified, they are applied \ in the order in which they are specified. Each filter is applied to each issue detected, and \ only issues which are accepted by all filters are reported. Each filter is of the form: \ @@ -1294,7 +1293,7 @@ and filter_report = and flavors = CLOpt.mk_bool ~deprecated:["-use-flavors"] ~long:"flavors" - ~in_help:InferCommand.([(Capture, manual_buck_flavors)]) + ~in_help:InferCommand.[(Capture, manual_buck_flavors)] "Buck integration using Buck flavors (clang only), eg $(i,`infer --flavors -- buck build \ //foo:bar#infer`)" @@ -1302,11 +1301,11 @@ and flavors = and force_delete_results_dir = CLOpt.mk_bool ~long:"force-delete-results-dir" ~default:false ~in_help: - InferCommand.( + InferCommand. [ (Capture, manual_generic) ; (Compile, manual_generic) ; (Diff, manual_generic) - ; (Run, manual_generic) ]) + ; (Run, manual_generic) ] "Do not refuse to delete the results directory if it doesn't look like an infer results \ directory." @@ -1314,7 +1313,7 @@ and force_delete_results_dir = and force_integration = CLOpt.mk_symbol_opt ~long:"force-integration" ~meta:"command" ~symbols:(List.Assoc.inverse build_system_exe_assoc) - ~in_help:InferCommand.([(Capture, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Capture, manual_generic); (Run, manual_generic)] (Printf.sprintf "Proceed as if the first argument after $(b,--) was $(i,command). Possible values: %s." ( List.map build_system_exe_assoc ~f:(fun (_, s) -> Printf.sprintf "$(i,%s)" s) @@ -1323,7 +1322,7 @@ and force_integration = and from_json_report = CLOpt.mk_path_opt ~long:"from-json-report" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] ~meta:"report.json" "Load analysis results from a report file (default is to load the results from the specs \ files generated by the analysis)." @@ -1336,7 +1335,7 @@ and frontend_stats = and gen_previous_build_command_script = CLOpt.mk_string_opt ~long:"gen-previous-build-command-script" - ~in_help:InferCommand.([(Diff, manual_generic)]) + ~in_help:InferCommand.[(Diff, manual_generic)] ~meta:"shell" "Specify a script that outputs the build command to capture in the previous version of the \ project. The script should output the command on stdout. For example \"echo make\"." @@ -1344,13 +1343,13 @@ and gen_previous_build_command_script = and generated_classes = CLOpt.mk_path_opt ~long:"generated-classes" - ~in_help:InferCommand.([(Capture, manual_java)]) + ~in_help:InferCommand.[(Capture, manual_java)] "Specify where to load the generated class files" and headers = CLOpt.mk_bool ~deprecated:["headers"; "hd"] ~deprecated_no:["no_headers"; "nhd"] ~long:"headers" - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "Analyze code in header files" @@ -1376,7 +1375,7 @@ and help_format = and html = CLOpt.mk_bool ~long:"html" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Generate html report." @@ -1398,20 +1397,20 @@ and infer_cache = and iphoneos_target_sdk_version = CLOpt.mk_string_opt ~long:"iphoneos-target-sdk-version" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] "Specify the target SDK version to use for iphoneos" and iphoneos_target_sdk_version_path_regex = CLOpt.mk_string_list ~long:"iphoneos-target-sdk-version-path-regex" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] "To pass a specific target SDK version to use for iphoneos in a particular path, with the \ format path:version (can be specified multiple times)" and issues_fields = CLOpt.mk_symbol_seq ~long:"issues-fields" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] ~default: [ `Issue_field_file ; `Issue_field_procedure @@ -1424,13 +1423,13 @@ and issues_fields = and issues_tests = CLOpt.mk_path_opt ~long:"issues-tests" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] ~meta:"file" "Write a list of issues in a format suitable for tests to $(i,file)" and issues_txt = CLOpt.mk_path_opt ~deprecated:["bugs_txt"] ~long:"issues-txt" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] ~meta:"file" "Write a list of issues in text format to $(i,file) (default: infer-out/bugs.txt)" @@ -1442,7 +1441,7 @@ and iterations = and java_jar_compiler = CLOpt.mk_path_opt ~long:"java-jar-compiler" - ~in_help:InferCommand.([(Capture, manual_java)]) + ~in_help:InferCommand.[(Capture, manual_java)] ~meta:"path" "Specify the Java compiler jar used to generate the bytecode" @@ -1450,7 +1449,7 @@ and job_id = CLOpt.mk_string_opt ~long:"job-id" "Specify the job ID of this Infe and jobs = CLOpt.mk_int ~deprecated:["-multicore"] ~long:"jobs" ~short:'j' ~default:ncpu - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] ~meta:"int" "Run the specified number of analysis jobs simultaneously" @@ -1464,7 +1463,7 @@ and join_cond = and log_events = CLOpt.mk_bool ~long:"log-events" - ~in_help:InferCommand.([(Run, manual_generic)]) + ~in_help:InferCommand.[(Run, manual_generic)] "Turn on the feature that logs events in a machine-readable format" @@ -1475,21 +1474,21 @@ and log_file = and linter = CLOpt.mk_string_opt ~long:"linter" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] "From the linters available, only run this one linter. (Useful together with \ $(b,--linters-developer-mode))" and linters_def_file = CLOpt.mk_path_list ~default:[] ~long:"linters-def-file" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] ~meta:"file" "Specify the file containing linters definition (e.g. 'linters.al')" and linters_def_folder = let linters_def_folder = CLOpt.mk_path_list ~default:[] ~long:"linters-def-folder" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] ~meta:"dir" "Specify the folder containing linters files with extension .al" in let () = @@ -1502,7 +1501,7 @@ and linters_def_folder = and linters_doc_url = CLOpt.mk_string_list ~long:"linters-doc-url" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] "Specify custom documentation URL for some linter that overrides the default one. Useful if \ your project has specific ways of fixing a lint error that is not true in general or public \ info. Format: linter_name:doc_url." @@ -1510,20 +1509,20 @@ and linters_doc_url = and linters_ignore_clang_failures = CLOpt.mk_bool ~long:"linters-ignore-clang-failures" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] ~default:false "Continue linting files even if some compilation fails." and linters_validate_syntax_only = CLOpt.mk_bool ~long:"linters-validate-syntax-only" - ~in_help:InferCommand.([(Capture, manual_clang_linters)]) + ~in_help:InferCommand.[(Capture, manual_clang_linters)] ~default:false "Validate syntax of AL files, then emit possible errors in JSON format to stdout" and load_average = CLOpt.mk_float_opt ~long:"load-average" ~short:'l' - ~in_help:InferCommand.([(Capture, manual_generic)]) + ~in_help:InferCommand.[(Capture, manual_generic)] ~meta:"float" "Do not start new parallel jobs if the load average is greater than that specified (Buck and \ make only)" @@ -1536,21 +1535,21 @@ and margin = and max_nesting = CLOpt.mk_int_opt ~long:"max-nesting" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Level of nested procedure calls to show. Trace elements beyond the maximum nesting level are \ skipped. If omitted, all levels are shown." and merge = CLOpt.mk_bool ~deprecated:["merge"] ~long:"merge" - ~in_help:InferCommand.([(Analyze, manual_buck_flavors)]) + ~in_help:InferCommand.[(Analyze, manual_buck_flavors)] "Merge the captured results directories specified in the dependency file" and ml_buckets = CLOpt.mk_symbol_seq ~deprecated:["ml_buckets"; "-ml_buckets"] ~long:"ml-buckets" ~default:[`MLeak_cf] - ~in_help:InferCommand.([(Analyze, manual_clang)]) + ~in_help:InferCommand.[(Analyze, manual_clang)] {|Specify the memory leak buckets to be checked in C++: - $(b,cpp) from C++ code |} @@ -1579,7 +1578,7 @@ and only_footprint = and only_show = CLOpt.mk_bool ~long:"only-show" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Show the list of reports and exit" @@ -1626,7 +1625,7 @@ and per_procedure_parallelism = and pmd_xml = CLOpt.mk_bool ~long:"pmd-xml" - ~in_help:InferCommand.([(Run, manual_generic)]) + ~in_help:InferCommand.[(Run, manual_generic)] "Output issues in (PMD) XML format" @@ -1637,7 +1636,7 @@ and precondition_stats = and previous_to_current_script = CLOpt.mk_string_opt ~long:"previous-to-current-script" - ~in_help:InferCommand.([(Diff, manual_generic)]) + ~in_help:InferCommand.[(Diff, manual_generic)] ~meta:"shell" "Specify a script to checkout the current version of the project. The project is supposed to \ already be at that current version when running $(b,infer diff); the script is used after \ @@ -1647,7 +1646,7 @@ and previous_to_current_script = and print_active_checkers = CLOpt.mk_bool ~long:"print-active-checkers" - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] "Print the active checkers before starting the analysis" @@ -1658,7 +1657,7 @@ and print_builtins = and print_log_identifier = CLOpt.mk_bool ~long:"print-log-identifier" - ~in_help:InferCommand.([(Run, manual_generic)]) + ~in_help:InferCommand.[(Run, manual_generic)] "Print the unique identifier that is common to all logged events" @@ -1669,19 +1668,19 @@ and print_using_diff = and procedures = CLOpt.mk_bool ~long:"procedures" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Print functions and methods discovered by infer" and procedures_attributes = CLOpt.mk_bool ~long:"procedures-attributes" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Print the attributes of each procedure in the output of $(b,--procedures)" and procedures_definedness = CLOpt.mk_bool ~long:"procedures-definedness" ~default:true - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Include procedures definedness in the output of $(b,--procedures), i.e. whether the \ procedure definition was found, or only the procedure declaration, or the procedure is an \ auto-generated Objective-C accessor" @@ -1689,7 +1688,7 @@ and procedures_definedness = and procedures_filter = CLOpt.mk_string_opt ~long:"procedures-filter" ~meta:"filter" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "With $(b,--procedures), only print functions and methods (procedures) matching the specified \ $(i,filter). A procedure filter is of the form $(i,path_pattern:procedure_name). Patterns \ are interpreted by SQLite: use $(b,_) to match any one character and $(b,%) to match any \ @@ -1699,7 +1698,7 @@ and procedures_filter = and procedures_name = CLOpt.mk_bool ~long:"procedures-name" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Include procedures names in the output of $(b,--procedures)" @@ -1712,7 +1711,7 @@ and procedures_per_process = and procedures_source_file = CLOpt.mk_bool ~long:"procedures-source-file" ~default:true - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Include the source file in which the procedure definition or declaration was found in the \ output of $(b,--procedures)" @@ -1725,7 +1724,7 @@ and procs_csv = and progress_bar = CLOpt.mk_bool ~deprecated:["pb"] ~deprecated_no:["no_progress_bar"; "npb"] ~short:'p' ~long:"progress-bar" ~default:true - ~in_help:InferCommand.([(Run, manual_generic)]) + ~in_help:InferCommand.[(Run, manual_generic)] "Show a progress bar" @@ -1733,41 +1732,41 @@ and project_root = CLOpt.mk_path ~deprecated:["project_root"; "-project_root"; "pr"] ~long:"project-root" ~short:'C' ~default:CLOpt.init_work_dir ~in_help: - InferCommand.( + InferCommand. [ (Analyze, manual_generic) ; (Capture, manual_generic) ; (Run, manual_generic) - ; (Report, manual_generic) ]) + ; (Report, manual_generic) ] ~meta:"dir" "Specify the root directory of the project" and quandary_endpoints = CLOpt.mk_json ~long:"quandary-endpoints" - ~in_help:InferCommand.([(Analyze, manual_quandary)]) + ~in_help:InferCommand.[(Analyze, manual_quandary)] "Specify endpoint classes for Quandary" and quandary_sanitizers = CLOpt.mk_json ~long:"quandary-sanitizers" - ~in_help:InferCommand.([(Analyze, manual_quandary)]) + ~in_help:InferCommand.[(Analyze, manual_quandary)] "Specify custom sanitizers for Quandary" and quandary_sources = CLOpt.mk_json ~long:"quandary-sources" - ~in_help:InferCommand.([(Analyze, manual_quandary)]) + ~in_help:InferCommand.[(Analyze, manual_quandary)] "Specify custom sources for Quandary" and quandary_sinks = CLOpt.mk_json ~long:"quandary-sinks" - ~in_help:InferCommand.([(Analyze, manual_quandary)]) + ~in_help:InferCommand.[(Analyze, manual_quandary)] "Specify custom sinks for Quandary" and quiet = CLOpt.mk_bool ~long:"quiet" ~short:'q' ~default:false - ~in_help:InferCommand.([(Analyze, manual_generic); (Report, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic); (Report, manual_generic)] "Do not print specs on standard output (default: only print for the $(b,report) command)" @@ -1778,7 +1777,7 @@ and racerd_use_path_stability = and reactive = CLOpt.mk_bool ~deprecated:["reactive"] ~long:"reactive" ~short:'r' - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] "Reactive mode: the analysis starts from the files captured since the $(i,infer) command \ started" @@ -1790,13 +1789,13 @@ and reactive_capture = and report = CLOpt.mk_bool ~long:"report" ~default:true - ~in_help:InferCommand.([(Analyze, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic); (Run, manual_generic)] "Run the reporting phase once the analysis has completed" and report_current = CLOpt.mk_path_opt ~long:"report-current" - ~in_help:InferCommand.([(ReportDiff, manual_generic)]) + ~in_help:InferCommand.[(ReportDiff, manual_generic)] "report of the latest revision" @@ -1804,7 +1803,7 @@ and report_custom_error = CLOpt.mk_bool ~long:"report-custom-error" "" and report_formatter = CLOpt.mk_symbol ~long:"report-formatter" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] ~default:`Phabricator_formatter ~symbols:[("none", `No_formatter); ("phabricator", `Phabricator_formatter)] ~eq:PolyVariantEqual.( = ) "Which formatter to use when emitting the report" @@ -1812,7 +1811,7 @@ and report_formatter = and report_hook = CLOpt.mk_string_opt ~long:"report-hook" - ~in_help:InferCommand.([(Analyze, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic); (Run, manual_generic)] ~default:(lib_dir ^/ "python" ^/ "report.py") ~meta:"script" "Specify a script to be executed after the analysis results are written. This script will be \ @@ -1822,13 +1821,13 @@ and report_hook = and report_previous = CLOpt.mk_path_opt ~long:"report-previous" - ~in_help:InferCommand.([(ReportDiff, manual_generic)]) + ~in_help:InferCommand.[(ReportDiff, manual_generic)] "Report of the base revision to use for comparison" and rest = CLOpt.mk_rest_actions - ~in_help:InferCommand.([(Capture, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Capture, manual_generic); (Run, manual_generic)] "Stop argument processing, use remaining arguments as a build command" ~usage:exe_usage (fun build_exe -> match Filename.basename build_exe with "java" | "javac" -> CLOpt.Javac | _ -> CLOpt.NoParse @@ -1839,12 +1838,12 @@ and results_dir = CLOpt.mk_path ~deprecated:["results_dir"; "-out"] ~long:"results-dir" ~short:'o' ~default:(CLOpt.init_work_dir ^/ "infer-out") ~in_help: - InferCommand.( + InferCommand. [ (Analyze, manual_generic) ; (Capture, manual_generic) ; (Explore, manual_generic) ; (Run, manual_generic) - ; (Report, manual_generic) ]) + ; (Report, manual_generic) ] ~meta:"dir" "Write results and internal files in the specified directory" @@ -1855,45 +1854,45 @@ and seconds_per_iteration = and select = CLOpt.mk_int_opt ~long:"select" ~meta:"N" - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "Select bug number $(i,N). If omitted, prompt for input." and siof_safe_methods = CLOpt.mk_string_list ~long:"siof-safe-methods" - ~in_help:InferCommand.([(Analyze, manual_siof)]) + ~in_help:InferCommand.[(Analyze, manual_siof)] "Methods that are SIOF-safe; \"foo::bar\" will match \"foo::bar()\", \"foo::bar()\", \ etc. (can be specified multiple times)" and skip_analysis_in_path = CLOpt.mk_string_list ~deprecated:["-skip-clang-analysis-in-path"] ~long:"skip-analysis-in-path" - ~in_help:InferCommand.([(Capture, manual_generic); (Run, manual_generic)]) + ~in_help:InferCommand.[(Capture, manual_generic); (Run, manual_generic)] ~meta:"path_prefix_OCaml_regex" "Ignore files whose path matches the given prefix (can be specified multiple times)" and skip_analysis_in_path_skips_compilation = CLOpt.mk_bool ~long:"skip-analysis-in-path-skips-compilation" - ~in_help:InferCommand.([(Report, manual_generic)]) + ~in_help:InferCommand.[(Report, manual_generic)] ~default:false "Whether paths in --skip-analysis-in-path should be compiled or not" and skip_duplicated_types = CLOpt.mk_bool ~long:"skip-duplicated-types" ~default:true - ~in_help:InferCommand.([(ReportDiff, manual_generic)]) + ~in_help:InferCommand.[(ReportDiff, manual_generic)] "Skip fixed-then-introduced duplicated types while computing differential reports" and skip_translation_headers = CLOpt.mk_string_list ~deprecated:["skip_translation_headers"] ~long:"skip-translation-headers" - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] ~meta:"path_prefix" "Ignore headers whose path matches the given prefix" and source_preview = CLOpt.mk_bool ~long:"source-preview" ~default:true - ~in_help:InferCommand.([(Explore, manual_generic)]) + ~in_help:InferCommand.[(Explore, manual_generic)] "print code excerpts around trace elements" @@ -1931,7 +1930,7 @@ and specs_library = ~f:(fun file -> specs_library := read_specs_dir_list_file file @ !specs_library ; "" ) - ~in_help:InferCommand.([(Analyze, manual_generic)]) + ~in_help:InferCommand.[(Analyze, manual_generic)] ~meta:"file" "" in specs_library @@ -1952,7 +1951,7 @@ and sqlite_vfs = and stacktrace = CLOpt.mk_path_opt ~deprecated:["st"] ~long:"stacktrace" - ~in_help:InferCommand.([(Analyze, manual_crashcontext)]) + ~in_help:InferCommand.[(Analyze, manual_crashcontext)] ~meta:"file" "File path containing a json-encoded Java crash stacktrace. Used to guide the analysis (only \ with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json for examples of \ @@ -1961,7 +1960,7 @@ and stacktrace = and stacktraces_dir = CLOpt.mk_path_opt ~long:"stacktraces-dir" - ~in_help:InferCommand.([(Analyze, manual_crashcontext)]) + ~in_help:InferCommand.[(Analyze, manual_crashcontext)] ~meta:"dir" "Directory path containing multiple json-encoded Java crash stacktraces. Used to guide the \ analysis (only with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json \ @@ -1996,7 +1995,7 @@ and testing_mode = and threadsafe_aliases = CLOpt.mk_json ~long:"threadsafe-aliases" - ~in_help:InferCommand.([(Analyze, manual_racerd)]) + ~in_help:InferCommand.[(Analyze, manual_racerd)] "Specify custom annotations that should be considered aliases of @ThreadSafe" @@ -2044,17 +2043,17 @@ and uninit_interproc = and unsafe_malloc = CLOpt.mk_bool ~long:"unsafe-malloc" - ~in_help:InferCommand.([(Analyze, manual_clang)]) + ~in_help:InferCommand.[(Analyze, manual_clang)] "Assume that malloc(3) never returns null." and version = let var = ref `None in CLOpt.mk_set var `Full ~deprecated:["version"] ~long:"version" - ~in_help:InferCommand.([(Run, manual_generic)]) + ~in_help:InferCommand.[(Run, manual_generic)] "Print version information and exit" ; CLOpt.mk_set var `Json ~deprecated:["version_json"] ~long:"version-json" - ~in_help:InferCommand.([(Run, manual_generic)]) + ~in_help:InferCommand.[(Run, manual_generic)] "Print version information in json format and exit" ; CLOpt.mk_set var `Vcs ~long:"version-vcs" "Print version control system commit and exit" ; var @@ -2076,13 +2075,13 @@ and worklist_mode = and xcode_developer_dir = CLOpt.mk_path_opt ~long:"xcode-developer-dir" - ~in_help:InferCommand.([(Capture, manual_buck_flavors)]) + ~in_help:InferCommand.[(Capture, manual_buck_flavors)] ~meta:"XCODE_DEVELOPER_DIR" "Specify the path to Xcode developer directory" and xcpretty = CLOpt.mk_bool ~long:"xcpretty" ~default:false - ~in_help:InferCommand.([(Capture, manual_clang)]) + ~in_help:InferCommand.[(Capture, manual_clang)] "Infer will use xcpretty together with xcodebuild to analyze an iOS app. xcpretty just needs \ to be in the path, infer command is still just $(i,`infer -- `)." @@ -2258,9 +2257,9 @@ let post_parsing_initialization command_opt = in if is_none !symops_per_iteration then symops_per_iteration := symops_timeout ; if is_none !seconds_per_iteration then seconds_per_iteration := seconds_timeout ; - clang_compilation_dbs - := List.rev_map ~f:(fun x -> `Raw x) !compilation_database - |> List.rev_map_append ~f:(fun x -> `Escaped x) !compilation_database_escaped ; + clang_compilation_dbs := + List.rev_map ~f:(fun x -> `Raw x) !compilation_database + |> List.rev_map_append ~f:(fun x -> `Escaped x) !compilation_database_escaped ; (* set analyzer mode to linters in linters developer mode *) if !linters_developer_mode then linters := true ; if !default_linters then linters_def_file := linters_def_default_file :: !linters_def_file ; @@ -2305,7 +2304,8 @@ let process_iphoneos_target_sdk_version_path_regex args = | None -> L.(die UserError) "Incorrect format for the option iphoneos-target-sdk_version-path-regex. The correct \ - format is path:version but got %s" arg + format is path:version but got %s" + arg in List.map ~f:process_iphoneos_target_sdk_version_path_regex args @@ -2320,7 +2320,8 @@ let process_linters_doc_url args = | None -> L.(die UserError) "Incorrect format for the option linters-doc-url. The correct format is linter:doc_url \ - but got %s" arg + but got %s" + arg in List.map ~f:linters_doc_url args @@ -2825,7 +2826,7 @@ let dynamic_dispatch = a call to unknown code and true triggers lazy dynamic dispatch. The latter mode follows the \ JVM semantics and creates procedure descriptions during symbolic execution using the type \ information found in the abstract state" - ~in_help:InferCommand.([(Analyze, manual_java)]) + ~in_help:InferCommand.[(Analyze, manual_java)] let dynamic_dispatch = !dynamic_dispatch diff --git a/infer/src/base/Config.mli b/infer/src/base/Config.mli index 4aeab399b..280e8176e 100644 --- a/infer/src/base/Config.mli +++ b/infer/src/base/Config.mli @@ -14,13 +14,8 @@ module CLOpt = CommandLineOption (** Configuration values: either constant, determined at compile time, or set at startup time by system calls, environment variables, or command line options *) -type analyzer = - | CaptureOnly - | CompileOnly - | Checkers - | Crashcontext - | Linters - [@@deriving compare] +type analyzer = CaptureOnly | CompileOnly | Checkers | Crashcontext | Linters +[@@deriving compare] val equal_analyzer : analyzer -> analyzer -> bool @@ -36,7 +31,7 @@ type compilation_database_dependencies = (** get the compilation database of the dependencies up to depth n by [Deps (Some n)], or all by [Deps None] *) | NoDeps - [@@deriving compare] +[@@deriving compare] type build_system = | BAnalyze @@ -51,7 +46,7 @@ type build_system = | BNdk | BPython | BXcode - [@@deriving compare] +[@@deriving compare] val equal_build_system : build_system -> build_system -> bool diff --git a/infer/src/base/DB.ml b/infer/src/base/DB.ml index fbf028fa9..e70b53934 100644 --- a/infer/src/base/DB.ml +++ b/infer/src/base/DB.ml @@ -117,7 +117,7 @@ let update_file_with_lock dir fname update = in Utils.create_dir dir ; let path = Filename.concat dir fname in - let fd = Unix.openfile path ~mode:Unix.([O_CREAT; O_SYNC; O_RDWR]) ~perm:0o640 in + let fd = Unix.openfile path ~mode:Unix.[O_CREAT; O_SYNC; O_RDWR] ~perm:0o640 in Unix.lockf fd ~mode:Unix.F_LOCK ~len:0L ; let buf = read_whole_file fd in reset_file fd ; @@ -135,7 +135,7 @@ let update_file_with_lock dir fname update = let read_file_with_lock dir fname = let path = Filename.concat dir fname in try - let fd = Unix.openfile path ~mode:Unix.([O_RSYNC; O_RDONLY]) ~perm:0o646 in + let fd = Unix.openfile path ~mode:Unix.[O_RSYNC; O_RDONLY] ~perm:0o646 in try Unix.lockf fd ~mode:Unix.F_RLOCK ~len:0L ; let buf = read_whole_file fd in @@ -223,7 +223,7 @@ module Results_dir = struct L.(die InternalError) "create_path" in let full_fname = Filename.concat (create dir_path) filename in - Unix.openfile full_fname ~mode:Unix.([O_WRONLY; O_CREAT; O_TRUNC]) ~perm:0o777 + Unix.openfile full_fname ~mode:Unix.[O_WRONLY; O_CREAT; O_TRUNC] ~perm:0o777 end let is_source_file path = diff --git a/infer/src/base/IssueType.ml b/infer/src/base/IssueType.ml index 4ea7d3797..281608f48 100644 --- a/infer/src/base/IssueType.ml +++ b/infer/src/base/IssueType.ml @@ -11,9 +11,8 @@ open! IStd (* Make sure we cannot create new issue types other than by calling [from_string]. This is because we want to keep track of the list of all the issues ever declared. *) module Unsafe : sig - type t = private - {unique_id: string; mutable enabled: bool; mutable hum: string} - [@@deriving compare] + type t = private {unique_id: string; mutable enabled: bool; mutable hum: string} + [@@deriving compare] val equal : t -> t -> bool @@ -63,7 +62,7 @@ end = struct value of enabled (see doc comment) *) if Option.is_some hum0 then old.hum <- hum ; old - with Not_found -> + with Caml.Not_found -> all_issues := IssueSet.add issue !all_issues ; issue diff --git a/infer/src/base/IssueType.mli b/infer/src/base/IssueType.mli index 6a779dd31..aa310c6ff 100644 --- a/infer/src/base/IssueType.mli +++ b/infer/src/base/IssueType.mli @@ -10,9 +10,8 @@ open! IStd (** type of string used for localisation *) -type t = private - {unique_id: string; mutable enabled: bool; mutable hum: string} - [@@deriving compare] +type t = private {unique_id: string; mutable enabled: bool; mutable hum: string} +[@@deriving compare] val equal : t -> t -> bool diff --git a/infer/src/base/Location.ml b/infer/src/base/Location.ml index e7c4f2801..c46c7f9ae 100644 --- a/infer/src/base/Location.ml +++ b/infer/src/base/Location.ml @@ -15,7 +15,7 @@ type t = { line: int (** The line number. -1 means "do not know" *) ; col: int (** The column number. -1 means "do not know" *) ; file: SourceFile.t (** The name of the source file *) } - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] diff --git a/infer/src/base/Location.mli b/infer/src/base/Location.mli index 659078db5..002245cce 100644 --- a/infer/src/base/Location.mli +++ b/infer/src/base/Location.mli @@ -14,7 +14,7 @@ type t = { line: int (** The line number. -1 means "do not know" *) ; col: int (** The column number. -1 means "do not know" *) ; file: SourceFile.t (** The name of the source file *) } - [@@deriving compare] +[@@deriving compare] val equal : t -> t -> bool diff --git a/infer/src/base/Logging.mli b/infer/src/base/Logging.mli index 9cb7de883..01fc115c6 100644 --- a/infer/src/base/Logging.mli +++ b/infer/src/base/Logging.mli @@ -67,7 +67,7 @@ val debug_dev : ('a, Format.formatter, unit) format -> 'a [@@deprecated "Only use to debug during development. If you want more permanent logging, use \ [Logging.debug] instead."] -[@@warning "-32"] + [@@warning "-32"] (** For debugging during development. *) (** Type of location in ml source: __POS__ *) diff --git a/infer/src/base/Multilinks.ml b/infer/src/base/Multilinks.ml index 54e35318a..55ae485fc 100644 --- a/infer/src/base/Multilinks.ml +++ b/infer/src/base/Multilinks.ml @@ -50,7 +50,9 @@ let write multilinks ~dir = let lookup ~dir = - try Some (String.Table.find_exn multilink_files_cache dir) with Not_found -> read ~dir + try Some (String.Table.find_exn multilink_files_cache dir) with + | Not_found_s _ | Caml.Not_found -> + read ~dir let resolve fname = @@ -63,4 +65,6 @@ let resolve fname = | None -> fname | Some links -> - try DB.filename_from_string (String.Table.find_exn links base) with Not_found -> fname + try DB.filename_from_string (String.Table.find_exn links base) with + | Not_found_s _ | Caml.Not_found -> + fname diff --git a/infer/src/base/ResultsDir.ml b/infer/src/base/ResultsDir.ml index 2042d95e4..3a112e4fd 100644 --- a/infer/src/base/ResultsDir.ml +++ b/infer/src/base/ResultsDir.ml @@ -19,12 +19,12 @@ let is_results_dir ~check_correct_version () = List.for_all results_dir_dir_markers ~f:(fun d -> Sys.is_directory d = `Yes || - (not_found := d ^ "/" ; - false) ) + ( not_found := d ^ "/" ; + false ) ) && ( not check_correct_version || Sys.is_file ResultsDatabase.database_fullpath = `Yes || - (not_found := ResultsDatabase.database_fullpath ; - false) ) + ( not_found := ResultsDatabase.database_fullpath ; + false ) ) in Result.ok_if_true has_all_markers ~error:(Printf.sprintf "'%s' not found" !not_found) @@ -42,8 +42,8 @@ let remove_results_dir () = Result.iter_error (is_results_dir ~check_correct_version:false ()) ~f:(fun err -> L.(die UserError) "ERROR: '%s' exists but does not seem to be an infer results directory: %s@\n\ - ERROR: Please delete '%s' and try again@." Config.results_dir err Config.results_dir - ) ; + ERROR: Please delete '%s' and try again@." + Config.results_dir err Config.results_dir ) ; Utils.rmtree Config.results_dir ) ; RunState.reset () @@ -85,7 +85,7 @@ let assert_results_dir advice = let delete_capture_and_analysis_data () = ResultsDatabase.reset_capture_tables () ; let dirs_to_delete = - List.map ~f:(Filename.concat Config.results_dir) Config.([captured_dir_name; specs_dir_name]) + List.map ~f:(Filename.concat Config.results_dir) Config.[captured_dir_name; specs_dir_name] in List.iter ~f:Utils.rmtree dirs_to_delete ; List.iter ~f:Unix.mkdir_p dirs_to_delete ; diff --git a/infer/src/base/RunState.ml b/infer/src/base/RunState.ml index 09b1f2e07..fef883ae4 100644 --- a/infer/src/base/RunState.ml +++ b/infer/src/base/RunState.ml @@ -27,7 +27,7 @@ let add_run_to_sequence () = ; date= run_time_string ; command= Config.command } in - Runstate_t.(state := {(!state) with run_sequence= run :: !state.run_sequence}) + Runstate_t.(state := {!state with run_sequence= run :: !state.run_sequence}) let state_filename = ".infer_runstate.json" @@ -47,17 +47,18 @@ let load_and_validate () = (Printf.sprintf "Incompatible results directory '%s':\n\ %s\n\ - Was '%s' created using an older version of infer?" Config.results_dir err_msg - Config.results_dir) ) + Was '%s' created using an older version of infer?" + Config.results_dir err_msg Config.results_dir) ) msg in if Sys.file_exists state_file_path <> `Yes then error "save state not found" else try let loaded_state = Ag_util.Json.from_file Runstate_j.read_t state_file_path in - if not - (String.equal !state.Runstate_t.results_dir_format - loaded_state.Runstate_t.results_dir_format) + if + not + (String.equal !state.Runstate_t.results_dir_format + loaded_state.Runstate_t.results_dir_format) then error "Incompatible formats: found\n %s\n\nbut expected this format:\n %s\n\n" loaded_state.results_dir_format !state.Runstate_t.results_dir_format diff --git a/infer/src/base/Serialization.ml b/infer/src/base/Serialization.ml index 824de2e55..6a0632b63 100644 --- a/infer/src/base/Serialization.ml +++ b/infer/src/base/Serialization.ml @@ -35,14 +35,14 @@ let create_serializer (key: Key.t) : 'a serializer = if key <> key' then ( L.user_error "Wrong key in when loading data from %s -- are you running infer with results coming from \ - a previous version of infer?@\n\ - " source_msg ; + a previous version of infer?@\n" + source_msg ; None ) else if version <> version' then ( L.user_error "Wrong version in when loading data from %s -- are you running infer with results coming \ - from a previous version of infer?@\n\ - " source_msg ; + from a previous version of infer?@\n" + source_msg ; None ) else Some value in diff --git a/infer/src/base/SourceFile.ml b/infer/src/base/SourceFile.ml index 17385e1da..21771a82e 100644 --- a/infer/src/base/SourceFile.ml +++ b/infer/src/base/SourceFile.ml @@ -24,7 +24,7 @@ type t = (* relative to project root *) | RelativeInferModel of string (* relative to infer models *) - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] @@ -135,10 +135,11 @@ let is_under_project_root = function let exists_cache = String.Table.create ~size:256 () let path_exists abs_path = - try String.Table.find_exn exists_cache abs_path with Not_found -> - let result = Sys.file_exists abs_path = `Yes in - String.Table.set exists_cache ~key:abs_path ~data:result ; - result + try String.Table.find_exn exists_cache abs_path with + | Not_found_s _ | Caml.Not_found -> + let result = Sys.file_exists abs_path = `Yes in + String.Table.set exists_cache ~key:abs_path ~data:result ; + result let of_header ?(warn_on_error= true) header_file = diff --git a/infer/src/base/Utils.ml b/infer/src/base/Utils.ml index 9001fea81..92507404a 100644 --- a/infer/src/base/Utils.ml +++ b/infer/src/base/Utils.ml @@ -260,7 +260,7 @@ let realpath_cache = Hashtbl.create 1023 let realpath ?(warn_on_error= true) path = match Hashtbl.find realpath_cache path with - | exception Not_found -> ( + | exception Caml.Not_found -> ( match Filename.realpath path with | realpath -> Hashtbl.add realpath_cache path (Ok realpath) ; @@ -303,7 +303,7 @@ let compare_versions v1 v2 = let write_file_with_locking ?(delete= false) ~f:do_write fname = Unix.with_file - ~mode:Unix.([O_WRONLY; O_CREAT]) + ~mode:Unix.[O_WRONLY; O_CREAT] fname ~f:(fun file_descr -> if Unix.flock file_descr Unix.Flock_command.lock_exclusive then ( @@ -326,9 +326,10 @@ let rec rmtree name = let rec rmdir dir = match Unix.readdir_opt dir with | Some entry -> - if not - ( String.equal entry Filename.current_dir_name - || String.equal entry Filename.parent_dir_name ) + if + not + ( String.equal entry Filename.current_dir_name + || String.equal entry Filename.parent_dir_name ) then rmtree (name ^/ entry) ; rmdir dir | None -> diff --git a/infer/src/base/ZipLib.ml b/infer/src/base/ZipLib.ml index a425f9fca..d6f5341f5 100644 --- a/infer/src/base/ZipLib.ml +++ b/infer/src/base/ZipLib.ml @@ -35,7 +35,7 @@ let load_from_cache serializer zip_path cache_dir zip_library = Some data | None -> None - | exception Not_found -> + | exception Caml.Not_found -> None @@ -47,7 +47,7 @@ let load_from_zip serializer zip_path zip_library = Some data | None -> None - | exception Not_found -> + | exception Caml.Not_found -> None diff --git a/infer/src/biabduction/Abs.ml b/infer/src/biabduction/Abs.ml index bf16e41bc..6af6d7682 100644 --- a/infer/src/biabduction/Abs.ml +++ b/infer/src/biabduction/Abs.ml @@ -22,7 +22,7 @@ type rule = ; r_root: Match.hpred_pat ; r_sigma: Match.hpred_pat list ; (* sigma should be in a specific order *) - r_new_sigma: Sil.hpred list + r_new_sigma: Sil.hpred list ; r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Sil.exp_subst -> Sil.atom list ; r_condition: Prop.normal Prop.t -> Sil.exp_subst -> bool } @@ -65,7 +65,7 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.exp_subst) = let inst_private, inst_public = Sil.sub_domain_partition f inst in let insts_of_public_ids = Sil.sub_range inst_public in let inst_of_base = - try Sil.sub_find (Ident.equal id_base) inst_public with Not_found -> assert false + try Sil.sub_find (Ident.equal id_base) inst_public with Caml.Not_found -> assert false in let insts_of_private_ids = Sil.sub_range inst_private in (insts_of_private_ids, insts_of_public_ids, inst_of_base) @@ -550,9 +550,9 @@ let discover_para_candidates tenv p = let rec get_edges_sigma = function | [] -> () - | (Sil.Hlseg _) :: sigma_rest | (Sil.Hdllseg _) :: sigma_rest -> + | Sil.Hlseg _ :: sigma_rest | Sil.Hdllseg _ :: sigma_rest -> get_edges_sigma sigma_rest - | (Sil.Hpointsto (root, se, te)) :: sigma_rest -> + | Sil.Hpointsto (root, se, te) :: sigma_rest -> let rec_flds = typ_get_recursive_flds tenv te in get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest in @@ -600,9 +600,9 @@ let discover_para_dll_candidates tenv p = let rec get_edges_sigma = function | [] -> () - | (Sil.Hlseg _) :: sigma_rest | (Sil.Hdllseg _) :: sigma_rest -> + | Sil.Hlseg _ :: sigma_rest | Sil.Hdllseg _ :: sigma_rest -> get_edges_sigma sigma_rest - | (Sil.Hpointsto (root, se, te)) :: sigma_rest -> + | Sil.Hpointsto (root, se, te) :: sigma_rest -> let rec_flds = typ_get_recursive_flds tenv te in get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest in @@ -877,15 +877,15 @@ let abstract_pure_part tenv p ~(from_abstract_footprint: bool) = ~f:(fun pi a -> match a with (* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *) - | Sil.Aeq (Exp.Const Const.Cint i, Exp.BinOp (Binop.Lt, _, _)) - | Sil.Aeq (Exp.BinOp (Binop.Lt, _, _), Exp.Const Const.Cint i) - | Sil.Aeq (Exp.Const Const.Cint i, Exp.BinOp (Binop.Le, _, _)) - | Sil.Aeq (Exp.BinOp (Binop.Le, _, _), Exp.Const Const.Cint i) + | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Lt, _, _)) + | Sil.Aeq (Exp.BinOp (Binop.Lt, _, _), Exp.Const (Const.Cint i)) + | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Le, _, _)) + | Sil.Aeq (Exp.BinOp (Binop.Le, _, _), Exp.Const (Const.Cint i)) when IntLit.isone i -> a :: pi | Sil.Aeq (Exp.Var name, e) when not (Ident.is_primed name) -> ( match e with Exp.Var _ | Exp.Const _ -> a :: pi | _ -> pi ) - | Sil.Aneq (Var _, _) | Sil.Apred (_, (Var _) :: _) | Anpred (_, (Var _) :: _) -> + | Sil.Aneq (Var _, _) | Sil.Apred (_, Var _ :: _) | Anpred (_, Var _ :: _) -> a :: pi | Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ -> pi ) @@ -982,14 +982,14 @@ let sigma_reachable root_fav sigma = let check_observer_is_unsubscribed_deallocation tenv prop e = let pvar_opt = match Attribute.get_resource tenv prop e with - | Some Apred (Aresource {ra_vpath= Some Dpvar pvar}, _) -> + | Some (Apred (Aresource {ra_vpath= Some (Dpvar pvar)}, _)) -> Some pvar | _ -> None in let loc = State.get_loc () in match Attribute.get_observer tenv prop e with - | Some Apred (Aobserver, _) -> ( + | Some (Apred (Aobserver, _)) -> ( match pvar_opt with | Some pvar when Config.nsnotification_center_checker_backend -> L.d_strln @@ -1043,19 +1043,19 @@ let check_junk pname tenv prop = let do_entry e = check_observer_is_unsubscribed_deallocation tenv prop e ; match Attribute.get_wontleak tenv prop e with - | Some Apred ((Awont_leak as a), _) -> + | 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), _) -> + | 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), _) -> + | Some (Apred ((Aundef _ as a), _)) -> L.d_strln "UNDEF" ; res := Some a | _ -> @@ -1123,7 +1123,7 @@ let check_junk pname tenv prop = | Some _, None | None, Some _ -> false in - is_none alloc_attribute && !leaks_reported <> [] + (is_none alloc_attribute && !leaks_reported <> []) || (* None attribute only reported if it's the first one *) List.mem ~equal:attr_opt_equal !leaks_reported alloc_attribute in diff --git a/infer/src/biabduction/Absarray.ml b/infer/src/biabduction/Absarray.ml index 9cfa27204..6210d7701 100644 --- a/infer/src/biabduction/Absarray.ml +++ b/infer/src/biabduction/Absarray.ml @@ -77,7 +77,7 @@ end = struct match (se, t.desc, syn_offs) with | _, _, [] -> (se, t) - | Sil.Estruct (fsel, _), Tstruct name, (Field (fld, _)) :: syn_offs' -> ( + | Sil.Estruct (fsel, _), Tstruct name, Field (fld, _) :: syn_offs' -> ( match Tenv.lookup tenv name with | Some {fields} -> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in @@ -85,7 +85,7 @@ end = struct get_strexp_at_syn_offsets tenv se' t' syn_offs' | None -> fail () ) - | Sil.Earray (_, esel, _), Typ.Tarray {elt= t'}, (Index ind) :: syn_offs' -> + | Sil.Earray (_, esel, _), Typ.Tarray {elt= t'}, Index ind :: syn_offs' -> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in get_strexp_at_syn_offsets tenv se' t' syn_offs' | _ -> @@ -97,7 +97,7 @@ end = struct match (se, t.desc, syn_offs) with | _, _, [] -> update se - | Sil.Estruct (fsel, inst), Tstruct name, (Field (fld, _)) :: syn_offs' -> ( + | Sil.Estruct (fsel, inst), Tstruct name, Field (fld, _) :: syn_offs' -> ( match Tenv.lookup tenv name with | Some {fields} -> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in @@ -115,7 +115,7 @@ end = struct Sil.Estruct (fsel', inst) | None -> assert false ) - | Sil.Earray (len, esel, inst), Tarray {elt= t'}, (Index idx) :: syn_offs' -> + | Sil.Earray (len, esel, inst), Tarray {elt= t'}, Index idx :: syn_offs' -> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in let esel' = @@ -131,10 +131,10 @@ end = struct let rec convert acc = function | [] -> acc - | (Field (f, t)) :: syn_offs' -> + | Field (f, t) :: syn_offs' -> let acc' = List.map ~f:(fun e -> Exp.Lfield (e, f, t)) acc in convert acc' syn_offs' - | (Index idx) :: syn_offs' -> + | Index idx :: syn_offs' -> let acc' = List.map ~f:(fun e -> Exp.Lindex (e, idx)) acc in convert acc' syn_offs' in @@ -354,7 +354,7 @@ let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal P let match_select_next (matchings_cur, matchings_fp) = match (matchings_cur, matchings_fp) with | [], [] -> - raise Not_found + raise Caml.Not_found | matched :: cur', fp' -> (matched, false, (cur', fp')) | [], matched :: fp' -> @@ -368,7 +368,7 @@ let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal P let strexp_data = StrexpMatch.get_data tenv matched in let p1, changed = do_abstract footprint_part p0 strexp_data in if changed then (p1, true) else match_abstract p0 matchings_cur_fp' - with Not_found -> (p0, false) + with Caml.Not_found -> (p0, false) in let rec find_then_abstract bound p0 = if Int.equal bound 0 then p0 @@ -423,7 +423,7 @@ let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (inde let sigma_fp' = StrexpMatch.replace_index tenv true matched_fp index fresh_index in Prop.set p ~sigma_fp:sigma_fp' else Prop.expose p - with Not_found -> Prop.expose p + with Caml.Not_found -> Prop.expose p in let p3 = let matched = StrexpMatch.find_path p.Prop.sigma path in @@ -437,7 +437,7 @@ let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (inde prop_replace_path_index tenv p3 path map in Prop.normalize tenv p4 - with Not_found -> p + with Caml.Not_found -> p (** Given [p] containing an array at [root], blur [indices] in it *) @@ -466,7 +466,7 @@ let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (ind (sigma', true) | _ -> (sigma, false) - with Not_found -> (sigma, false) + with Caml.Not_found -> (sigma, false) in prop_update_sigma_and_fp_sigma tenv p prune_sigma @@ -658,7 +658,7 @@ let remove_redundant_elements tenv prop = false in match (e, se) with - | Exp.Const Const.Cint i, Sil.Eexp (Exp.Var id, _) + | Exp.Const (Const.Cint i), Sil.Eexp (Exp.Var id, _) when (not fp_part || IntLit.iszero i) && not (Ident.is_normal id) && occurs_at_most_once id -> remove () (* unknown value can be removed in re-execution mode or if the index is zero *) | Exp.Var id, Sil.Eexp _ when not (Ident.is_normal id) && occurs_at_most_once id -> diff --git a/infer/src/biabduction/Attribute.ml b/infer/src/biabduction/Attribute.ml index 23ad08f5e..6885dada2 100644 --- a/infer/src/biabduction/Attribute.ml +++ b/infer/src/biabduction/Attribute.ml @@ -391,7 +391,7 @@ let find_equal_formal_path tenv e prop = Some vfs | None -> match get_objc_null tenv prop e with - | Some Apred (Aobjc_null, [_; vfs]) -> + | Some (Apred (Aobjc_null, [_; vfs])) -> Some vfs | _ -> None diff --git a/infer/src/biabduction/Buckets.ml b/infer/src/biabduction/Buckets.ml index d48e5b14f..bff5dd5e0 100644 --- a/infer/src/biabduction/Buckets.ml +++ b/infer/src/biabduction/Buckets.ml @@ -93,7 +93,7 @@ let check_access access_opt de_opt = let has_call_or_sets_null node = let rec exp_is_null exp = match exp with - | Exp.Const Const.Cint n -> + | Exp.Const (Const.Cint n) -> IntLit.iszero n | Exp.Cast (_, e) -> exp_is_null e @@ -117,8 +117,9 @@ let check_access access_opt de_opt = in let local_access_found = ref false in let do_node node = - if Int.equal (Procdesc.Node.get_loc node).Location.line line_number - && has_call_or_sets_null node + if + Int.equal (Procdesc.Node.get_loc node).Location.line line_number + && has_call_or_sets_null node then local_access_found := true in let path, pos_opt = State.get_path () in @@ -134,14 +135,14 @@ let check_access access_opt de_opt = else None in match access_opt with - | Some Localise.Last_assigned (n, ncf) -> + | Some (Localise.Last_assigned (n, ncf)) -> find_bucket n ncf - | Some Localise.Returned_from_call n -> + | Some (Localise.Returned_from_call n) -> find_bucket n false - | Some Localise.Last_accessed (_, is_nullable) when is_nullable -> + | 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/Builtin.ml b/infer/src/biabduction/Builtin.ml index fb1fc13c1..3c32b73ac 100644 --- a/infer/src/biabduction/Builtin.ml +++ b/infer/src/biabduction/Builtin.ml @@ -41,7 +41,7 @@ let check_register_populated () = (** get the symbolic execution handler associated to the builtin function name *) let get name : t option = - try Some (Typ.Procname.Hash.find builtin_functions name) with Not_found -> + try Some (Typ.Procname.Hash.find builtin_functions name) with Caml.Not_found -> check_register_populated () ; None @@ -55,7 +55,7 @@ let register proc_name sym_exe_fun : registered = let pp_registered fmt () = let builtin_names = ref [] in Typ.Procname.Hash.iter (fun name _ -> builtin_names := name :: !builtin_names) builtin_functions ; - builtin_names := List.sort ~cmp:Typ.Procname.compare !builtin_names ; + builtin_names := List.sort ~compare:Typ.Procname.compare !builtin_names ; let pp pname = Format.fprintf fmt "%a@\n" Typ.Procname.pp pname in Format.fprintf fmt "Registered builtins:@\n @[" ; List.iter ~f:pp !builtin_names ; diff --git a/infer/src/biabduction/BuiltinDefn.ml b/infer/src/biabduction/BuiltinDefn.ml index 54dda96d7..687b8462e 100644 --- a/infer/src/biabduction/BuiltinDefn.ml +++ b/infer/src/biabduction/BuiltinDefn.ml @@ -67,7 +67,7 @@ let add_array_to_prop tenv pdesc prop_ lexp typ = prop.Prop.sigma in match hpred_opt with - | Some Sil.Hpointsto (_, Sil.Earray (len, _, _), _) -> + | Some (Sil.Hpointsto (_, Sil.Earray (len, _, _), _)) -> Some (len, prop) | Some _ -> None (* e points to something but not an array *) @@ -131,7 +131,7 @@ let execute___set_array_length {Builtin.tenv; pdesc; prop_; path; ret_id; args} prop.Prop.sigma in match hpred with - | [(Sil.Hpointsto (e, Sil.Earray (_, esel, inst), t))] -> + | [Sil.Hpointsto (e, Sil.Earray (_, esel, inst), t)] -> let hpred' = Sil.Hpointsto (e, Sil.Earray (n_len, esel, inst), t) in let prop' = Prop.set prop ~sigma:(hpred' :: sigma') in [(Prop.normalize tenv prop', path)] @@ -248,7 +248,7 @@ let replace_ptsto_texp tenv prop root_e texp = sigma in match sigma1 with - | [(Sil.Hpointsto (e, se, _))] -> + | [Sil.Hpointsto (e, se, _)] -> Sil.Hpointsto (e, se, texp) :: sigma2 | _ -> sigma @@ -351,7 +351,7 @@ let execute___cast builtin_args : Builtin.ret_typ = let set_resource_attribute tenv prop path n_lexp loc ra_res = let prop' = match Attribute.get_resource tenv prop n_lexp with - | Some Apred (Aresource ra, _) -> + | Some (Apred (Aresource ra, _)) -> Attribute.add_or_replace tenv prop (Apred (Aresource {ra with ra_res}, [n_lexp])) | _ -> let pname = PredSymb.mem_alloc_pname PredSymb.Mnew in @@ -573,7 +573,7 @@ let execute_alloc mk can_return_null {Builtin.pdesc; tenv; prop_; path; ret_id; | [(size_exp, _)] -> (* for malloc and __new *) (size_exp, PredSymb.mem_alloc_pname mk) - | [(size_exp, _); (Exp.Const Const.Cfun pname, _)] -> + | [(size_exp, _); (Exp.Const (Const.Cfun pname), _)] -> (size_exp, pname) | _ -> raise (Exceptions.Wrong_argument_number __POS__) @@ -721,7 +721,7 @@ let execute___split_get_nth {Builtin.tenv; pdesc; prop_; path; ret_id; args} : B 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 n_sil in try @@ -729,7 +729,7 @@ let execute___split_get_nth {Builtin.tenv; pdesc; prop_; path; ret_id; args} : B let n_part = List.nth_exn parts n in let res = Exp.Const (Const.Cstr n_part) in [(return_result tenv res prop ret_id, path)] - with Not_found -> assert false ) + with Caml.Not_found -> assert false ) | _ -> [(prop, path)] ) | _ -> @@ -754,7 +754,7 @@ let execute___infer_fail {Builtin.pdesc; tenv; prop_; path; args; loc; exe_env} match args with | [(lexp_msg, _)] -> ( match Prop.exp_normalize_prop tenv prop_ lexp_msg with - | Exp.Const Const.Cstr str -> + | Exp.Const (Const.Cstr str) -> str | _ -> assert false ) diff --git a/infer/src/biabduction/Dom.ml b/infer/src/biabduction/Dom.ml index db3c2d53b..26fde79b5 100644 --- a/infer/src/biabduction/Dom.ml +++ b/infer/src/biabduction/Dom.ml @@ -37,8 +37,8 @@ let equal_sigma sigma1 sigma2 = if Sil.equal_hpred hpred1 hpred2 then f sigma1_rest' sigma2_rest' else ( L.d_strln "failure reason 2" ; raise Sil.JoinFail ) in - let sigma1_sorted = List.sort ~cmp:Sil.compare_hpred sigma1 in - let sigma2_sorted = List.sort ~cmp:Sil.compare_hpred sigma2 in + let sigma1_sorted = List.sort ~compare:Sil.compare_hpred sigma1 in + let sigma2_sorted = List.sort ~compare:Sil.compare_hpred sigma2 in f sigma1_sorted sigma2_sorted @@ -46,7 +46,7 @@ let sigma_get_start_lexps_sort sigma = let exp_compare_neg e1 e2 = -Exp.compare e1 e2 in let filter e = Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in let lexps = Sil.hpred_list_get_lexps filter sigma in - List.sort ~cmp:exp_compare_neg lexps + List.sort ~compare:exp_compare_neg lexps (** {2 Utility functions for side} *) @@ -100,7 +100,7 @@ end = struct let lookup' tbl e default = match e with | Exp.Var _ -> ( - try Hashtbl.find tbl e with Not_found -> Hashtbl.replace tbl e default ; default ) + try Hashtbl.find tbl e with Caml.Not_found -> Hashtbl.replace tbl e default ; default ) | _ -> assert false @@ -378,11 +378,11 @@ module CheckMeet : InfoLossCheckerSig = struct match (es, e) with | [], _ -> true - | [(Exp.Const _)], Exp.Lvar _ -> + | [Exp.Const _], Exp.Lvar _ -> false - | [(Exp.Const _)], Exp.Var _ -> + | [Exp.Const _], Exp.Var _ -> not (Exp.Set.mem e lexps) - | [(Exp.Const _)], _ -> + | [Exp.Const _], _ -> assert false | [_], Exp.Lvar _ | [_], Exp.Var _ -> true @@ -498,10 +498,10 @@ end = struct let minus2_to_2 = List.map ~f:IntLit.of_int [-2; -1; 0; 1; 2] let get_induced_pi tenv () = - let t_sorted = List.sort ~cmp:entry_compare !t in + let t_sorted = List.sort ~compare:entry_compare !t in let add_and_chk_eq e1 e1' n = match (e1, e1') with - | Exp.Const Const.Cint n1, Exp.Const Const.Cint n1' -> + | Exp.Const (Const.Cint n1), Exp.Const (Const.Cint n1') -> IntLit.eq (n1 ++ n) n1' | _ -> false @@ -538,7 +538,7 @@ end = struct let eqs, t_minimal = f_eqs [] [] t_sorted in let f_ineqs acc (e1, e2, e) = match (e1, e2) with - | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 -> + | Exp.Const (Const.Cint n1), Exp.Const (Const.Cint n2) -> let strict_lower1, upper1 = if IntLit.leq n1 n2 then (n1 -- IntLit.one, n2) else (n2 -- IntLit.one, n1) in @@ -640,11 +640,11 @@ 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 @@ -694,7 +694,7 @@ end = struct renaming_restricted in let sub_list_side_sorted = - List.sort ~cmp:(fun (_, e) (_, e') -> Exp.compare e e') sub_list_side + List.sort ~compare:(fun (_, e) (_, e') -> Exp.compare e e') sub_list_side in let rec find_duplicates = function | (_, e) :: ((_, e') :: _ as t) -> @@ -722,7 +722,7 @@ end = struct in let sub_list_sorted = let compare (i, _) (i', _) = Ident.compare i i' in - List.sort ~cmp:compare sub_list + List.sort ~compare sub_list in let rec find_duplicates = function | (i, _) :: ((i', _) :: _ as t) -> @@ -812,13 +812,13 @@ end = struct | Sil.Aeq (e', (Exp.Var id as e)) when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> build_other_atoms (fun e0 -> Prop.mk_eq tenv e0 e') side e - | Sil.Aeq (Exp.BinOp (Binop.Le, e, e'), Exp.Const Const.Cint i) - | Sil.Aeq (Exp.Const Const.Cint i, Exp.BinOp (Binop.Le, e, e')) + | Sil.Aeq (Exp.BinOp (Binop.Le, e, e'), Exp.Const (Const.Cint i)) + | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Le, e, e')) when IntLit.isone i && exp_contains_only_normal_ids e' -> let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e0, e')) in build_other_atoms construct side e - | Sil.Aeq (Exp.BinOp (Binop.Lt, e', e), Exp.Const Const.Cint i) - | Sil.Aeq (Exp.Const Const.Cint i, Exp.BinOp (Binop.Lt, e', e)) + | Sil.Aeq (Exp.BinOp (Binop.Lt, e', e), Exp.Const (Const.Cint i)) + | Sil.Aeq (Exp.Const (Const.Cint i), Exp.BinOp (Binop.Lt, e', e)) when IntLit.isone i && exp_contains_only_normal_ids e' -> let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Lt, e', e0)) in build_other_atoms construct side e @@ -843,8 +843,9 @@ end = struct || Exp.free_vars e2 |> Sequence.exists ~f:Ident.is_primed in let e = - if not (Exp.free_vars e1 |> Sequence.exists ~f:can_rename) - && not (Exp.free_vars e2 |> Sequence.exists ~f:can_rename) + if + 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 ) else @@ -927,7 +928,7 @@ let hpred_construct_fresh side = (** {2 Join and Meet for Ids} *) let ident_same_kind_primed_footprint id1 id2 = - Ident.is_primed id1 && Ident.is_primed id2 || Ident.is_footprint id1 && Ident.is_footprint 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) = @@ -998,12 +999,12 @@ let rec exp_partial_join (e1: Exp.t) (e2: Exp.t) : Exp.t = | Exp.Var id1, Exp.BinOp (Binop.PlusA, Exp.Var id2, Exp.Const _) when ident_same_kind_primed_footprint id1 id2 -> Rename.extend e1 e2 Rename.ExtFresh - | Exp.BinOp (Binop.PlusA, Exp.Var id1, Exp.Const Const.Cint c1), Exp.Const Const.Cint c2 + | Exp.BinOp (Binop.PlusA, Exp.Var id1, Exp.Const (Const.Cint c1)), Exp.Const (Const.Cint c2) when can_rename id1 -> let c2' = c2 -- c1 in let e_res = Rename.extend (Exp.Var id1) (Exp.int c2') Rename.ExtFresh in Exp.BinOp (Binop.PlusA, e_res, Exp.int c1) - | Exp.Const Const.Cint c1, Exp.BinOp (Binop.PlusA, Exp.Var id2, Exp.Const Const.Cint c2) + | Exp.Const (Const.Cint c1), Exp.BinOp (Binop.PlusA, Exp.Var id2, Exp.Const (Const.Cint c2)) when can_rename id2 -> let c1' = c1 -- c2 in let e_res = Rename.extend (Exp.int c1') (Exp.Var id2) Rename.ExtFresh in @@ -1615,7 +1616,7 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s CheckJoin.add Rhs iF2 iB2 ; (* add equality iF2=iB2 *) sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2 - | Some Sil.Hpointsto _, Some Sil.Hpointsto _ -> + | Some (Sil.Hpointsto _), Some (Sil.Hpointsto _) -> assert false (* Should be handled by a guarded case *) with Todo.Empty -> @@ -1707,7 +1708,7 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop (* find some array length in the prop, to be used as heuritic for upper bound in widening *) let len_list = ref [] in let do_hpred = function - | Sil.Hpointsto (_, Sil.Earray (Exp.Const Const.Cint n, _, _), _) -> + | Sil.Hpointsto (_, Sil.Earray (Exp.Const (Const.Cint n), _, _), _) -> if IntLit.geq n IntLit.one then len_list := n :: !len_list | _ -> () @@ -1718,7 +1719,7 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop let bounds = let bounds1 = get_array_len ep1 in let bounds2 = get_array_len ep2 in - let bounds_sorted = List.sort ~cmp:IntLit.compare_value (bounds1 @ bounds2) in + let bounds_sorted = List.sort ~compare:IntLit.compare_value (bounds1 @ bounds2) in List.rev (List.remove_consecutive_duplicates ~equal:IntLit.eq bounds_sorted) in let widening_atom a = diff --git a/infer/src/biabduction/Match.ml b/infer/src/biabduction/Match.ml index 03f8ea3a9..74f391aad 100644 --- a/infer/src/biabduction/Match.ml +++ b/infer/src/biabduction/Match.ml @@ -709,7 +709,8 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo ) | None, _ | _, None -> None - | Some Sil.Hpointsto (_, _, te1), Some Sil.Hpointsto (_, _, te2) when not (Exp.equal te1 te2) -> + | Some (Sil.Hpointsto (_, _, te1)), Some (Sil.Hpointsto (_, _, te2)) + when not (Exp.equal te1 te2) -> None | Some (Sil.Hpointsto (_, se1, _) as hpred1), Some (Sil.Hpointsto (_, se2, _) as hpred2) -> ( match generate_todos_from_strexp mode [] se1 se2 with diff --git a/infer/src/biabduction/Paths.ml b/infer/src/biabduction/Paths.ml index e46497b75..6d2de09ba 100644 --- a/infer/src/biabduction/Paths.ml +++ b/infer/src/biabduction/Paths.ml @@ -79,7 +79,7 @@ end = struct type stats = { mutable max_length: int ; (* length of the longest linear sequence *) - mutable linear_num: float + mutable linear_num: float (* number of linear sequences described by the path *) } (* type aliases for components of t values that compare should ignore *) @@ -108,7 +108,7 @@ end = struct and continue with [path]. *) | Pjoin of t * t * stats_ (** join of two paths *) | Pcall of t * procname_ * path_exec_ * stats_ (** add a sub-path originating from a call *) - [@@deriving compare] + [@@deriving compare] let get_dummy_stats () = {max_length= -1; linear_num= -1.0} @@ -361,7 +361,7 @@ end = struct try let n = Procdesc.NodeMap.find node !map in map := Procdesc.NodeMap.add node (n + 1) !map - with Not_found -> map := Procdesc.NodeMap.add node 1 !map ) + with Caml.Not_found -> map := Procdesc.NodeMap.add node 1 !map ) | None -> () in @@ -402,7 +402,7 @@ end = struct let delayed_num = ref 0 in let delayed = ref PathMap.empty in let add_path p = - try ignore (PathMap.find p !delayed) with Not_found -> + try ignore (PathMap.find p !delayed) with Caml.Not_found -> incr delayed_num ; delayed := PathMap.add p !delayed_num !delayed in @@ -424,10 +424,10 @@ end = struct in let rec doit n fmt path = try - if n > 0 then raise Not_found ; + if n > 0 then raise Caml.Not_found ; let num = PathMap.find path !delayed in F.fprintf fmt "P%d" num - with Not_found -> + with Caml.Not_found -> match path with | Pstart (node, _) -> F.fprintf fmt "n%a" Procdesc.Node.pp node @@ -639,7 +639,7 @@ end = struct try let path_old = PropMap.find p ps in Path.join path_old path - with Not_found -> path + with Caml.Not_found -> path in PropMap.add p path_new ps @@ -664,7 +664,7 @@ end = struct let path_old = PropMap.find p !res in if path_nodes_subset path path_old (* do not propagate new path if it has no new nodes *) then res := PropMap.remove p !res - with Not_found -> res := PropMap.remove p !res + with Caml.Not_found -> res := PropMap.remove p !res in PropMap.iter rem ps2 ; !res diff --git a/infer/src/biabduction/Prop.ml b/infer/src/biabduction/Prop.ml index c4907d88d..ca58e9ecb 100644 --- a/infer/src/biabduction/Prop.ml +++ b/infer/src/biabduction/Prop.ml @@ -47,7 +47,7 @@ module Core : sig ; pi: pi (** pure part *) ; sigma_fp: sigma (** abduced spatial part *) ; pi_fp: pi (** abduced pure part *) } - [@@deriving compare] + [@@deriving compare] val prop_emp : normal t (** Proposition [true /\ emp]. *) @@ -75,7 +75,7 @@ end = struct ; pi: pi (** pure part *) ; sigma_fp: sigma (** abduced spatial part *) ; pi_fp: pi (** abduced pure part *) } - [@@deriving compare] + [@@deriving compare] (** Proposition [true /\ emp]. *) let prop_emp : normal t = {sub= Sil.exp_sub_empty; pi= []; sigma= []; pi_fp= []; sigma_fp= []} @@ -198,7 +198,7 @@ let sigma_get_stack_nonstack only_local_vars sigma = let pp_sigma_simple pe env fmt sigma = let sigma_stack, sigma_nonstack = sigma_get_stack_nonstack false sigma in let pp_stack fmt sg_ = - let sg = List.sort ~cmp:Sil.compare_hpred sg_ in + let sg = List.sort ~compare:Sil.compare_hpred sg_ in if sg <> [] then Format.fprintf fmt "%a" (Pp.semicolon_seq ~print_env:pe (pp_hpred_stackvar pe)) sg in @@ -236,7 +236,7 @@ let get_pure_extended p = let old_id = Ident.Map.find pid primed_map in let new_atom = Sil.Aeq (Var id, Var old_id) in (new_atom :: atoms, primed_map) - with Not_found -> (atoms, Ident.Map.add pid id primed_map) + 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) -> @@ -423,7 +423,7 @@ let sigma_sub subst sigma = (** Return [true] if the atom is an inequality *) let atom_is_inequality (atom: Sil.atom) = match atom with - | Aeq (BinOp ((Le | Lt), _, _), Const Cint i) when IntLit.isone i -> + | Aeq (BinOp ((Le | Lt), _, _), Const (Cint i)) when IntLit.isone i -> true | _ -> false @@ -432,7 +432,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) = match atom with - | Aeq (BinOp (Le, e1, Const Cint n), Const Cint i) when IntLit.isone i -> + | Aeq (BinOp (Le, e1, Const (Cint n)), Const (Cint i)) when IntLit.isone i -> Some (e1, n) | _ -> None @@ -441,7 +441,7 @@ let atom_exp_le_const (atom: Sil.atom) = (** If the atom is [n + | Aeq (BinOp (Lt, Const (Cint n), e1), Const (Cint i)) when IntLit.isone i -> Some (n, e1) | _ -> None @@ -478,8 +478,8 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst 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 \ - of type struct %a: %a:%a" Typ.Name.pp name Typ.Name.pp name pp_path (List.rev path) - Typ.Name.pp name ; + of type struct %a: %a:%a" + Typ.Name.pp name Typ.Name.pp name pp_path (List.rev path) Typ.Name.pp name ; match (struct_init_mode, Tenv.lookup tenv name) with | Fld_init, Some {fields} -> (* pass len as an accumulator, so that it is passed to create_strexp_of_type for the last @@ -521,13 +521,13 @@ 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) = 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 + | (Aeq (BinOp (Le, e1, Const (Cint n1)), Const (Cint i1)) as a1) + :: Aeq (BinOp (Le, e2, Const (Cint n2)), Const (Cint i2)) :: rest when IntLit.isone i1 && IntLit.isone i2 && Exp.equal e1 e2 && IntLit.lt n1 n2 -> (* second inequality redundant *) pi_sorted_remove_redundant (a1 :: rest) - | (Aeq (BinOp (Lt, Const Cint n1, e1), Const Cint i1)) - :: (Aeq (BinOp (Lt, Const Cint n2, e2), Const Cint i2) as a2) :: rest + | Aeq (BinOp (Lt, Const (Cint n1), e1), Const (Cint i1)) + :: (Aeq (BinOp (Lt, Const (Cint n2), e2), Const (Cint i2)) as a2) :: rest when IntLit.isone i1 && IntLit.isone i2 && Exp.equal e1 e2 && IntLit.lt n1 n2 -> (* first inequality redundant *) pi_sorted_remove_redundant (a2 :: rest) @@ -615,9 +615,9 @@ module Normalize = struct match sigma1 with | [] -> set - | (Hpointsto (e, _, _)) :: sigma' | (Hlseg (Sil.Lseg_NE, _, e, _, _)) :: sigma' -> + | Hpointsto (e, _, _) :: sigma' | Hlseg (Sil.Lseg_NE, _, e, _, _) :: sigma' -> f_alloc (Exp.Set.add e set) sigma' - | (Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _)) :: sigma' -> + | Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma' -> f_alloc (Exp.Set.add iF (Exp.Set.add iB set)) sigma' | _ :: sigma' -> f_alloc set sigma' @@ -630,12 +630,12 @@ module Normalize = struct (List.rev eqs_zero, List.rev sigma_passed) | (Hpointsto _ as hpred) :: sigma' -> f eqs_zero (hpred :: sigma_passed) sigma' - | (Hlseg (Lseg_PE, _, e1, e2, _)) :: sigma' + | Hlseg (Lseg_PE, _, e1, e2, _) :: sigma' when Exp.equal e1 Exp.zero || Exp.Set.mem e1 alloc_set -> f (Sil.Aeq (e1, e2) :: eqs_zero) sigma_passed sigma' | (Hlseg _ as hpred) :: sigma' -> f eqs_zero (hpred :: sigma_passed) sigma' - | (Hdllseg (Lseg_PE, _, iF, oB, oF, iB, _)) :: sigma' + | Hdllseg (Lseg_PE, _, iF, oB, oF, iB, _) :: sigma' when Exp.equal iF Exp.zero || Exp.Set.mem iF alloc_set || Exp.equal iB Exp.zero || Exp.Set.mem iB alloc_set -> f (Sil.Aeq (iF, oF) :: Sil.Aeq (iB, oB) :: eqs_zero) sigma_passed sigma' @@ -652,14 +652,14 @@ module Normalize = struct List.rev sigma_passed | (Hpointsto _ as hpred) :: sigma' -> f (hpred :: sigma_passed) sigma' - | (Hlseg (Lseg_PE, para, f1, f2, shared)) :: sigma' - when Exp.equal e1 f1 && Exp.equal e2 f2 || Exp.equal e2 f1 && Exp.equal e1 f2 -> + | Hlseg (Lseg_PE, para, f1, f2, shared) :: sigma' + when (Exp.equal e1 f1 && Exp.equal e2 f2) || (Exp.equal e2 f1 && Exp.equal e1 f2) -> f (Sil.Hlseg (Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma' | (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 -> + | 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) -> f (Sil.Hdllseg (Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' | (Hdllseg _ as hpred) :: sigma' -> f (hpred :: sigma_passed) sigma' @@ -699,9 +699,9 @@ module Normalize = struct eval e1 | UnOp (Unop.LNot, e1, topt) -> ( match eval e1 with - | Const Cint i when IntLit.iszero i -> + | Const (Cint i) when IntLit.iszero i -> Exp.one - | Const Cint _ -> + | Const (Cint _) -> Exp.zero | UnOp (LNot, e1', _) -> e1' @@ -711,9 +711,9 @@ module Normalize = struct match eval e1 with | UnOp (Neg, e2', _) -> e2' - | Const Cint i -> + | Const (Cint i) -> Exp.int (IntLit.neg i) - | Const Cfloat v -> + | Const (Cfloat v) -> Exp.float ~-.v | Var id -> UnOp (Neg, Var id, topt) @@ -723,31 +723,31 @@ module Normalize = struct match eval e1 with | UnOp (BNot, e2', _) -> e2' - | Const Cint i -> + | Const (Cint i) -> Exp.int (IntLit.lognot i) | e1' -> if abs then Exp.get_undefined false else UnOp (BNot, e1', topt) ) | BinOp (Le, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.bool (IntLit.leq n m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.bool (v <= w) - | BinOp (PlusA, e3, Const Cint n), Const Cint m -> + | BinOp (PlusA, e3, Const (Cint n)), Const (Cint m) -> BinOp (Le, e3, Exp.int (m -- n)) | e1', e2' -> Exp.le e1' e2' ) | BinOp (Lt, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.bool (IntLit.lt n m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.bool (v < w) - | Const Cint n, BinOp (MinusA, f1, f2) -> + | Const (Cint n), BinOp (MinusA, f1, f2) -> BinOp (Le, BinOp (MinusA, f2, f1), Exp.int (IntLit.minus_one -- n)) - | BinOp (MinusA, f1, f2), Const Cint n -> + | BinOp (MinusA, f1, f2), Const (Cint n) -> Exp.le (BinOp (MinusA, f1, f2)) (Exp.int (n -- IntLit.one)) - | BinOp (PlusA, e3, Const Cint n), Const Cint m -> + | BinOp (PlusA, e3, Const (Cint n)), Const (Cint m) -> BinOp (Lt, e3, Exp.int (m -- n)) | e1', e2' -> Exp.lt e1' e2' ) @@ -757,11 +757,11 @@ module Normalize = struct eval (Exp.lt e2 e1) | BinOp (Eq, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.bool (IntLit.eq n m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.bool (Float.equal v w) - | Const Cint _, Exp.Lvar _ | Exp.Lvar _, Const Cint _ -> + | Const (Cint _), Exp.Lvar _ | Exp.Lvar _, Const (Cint _) -> (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) (* Assume they are not equal *) Exp.zero @@ -769,11 +769,11 @@ module Normalize = struct Exp.eq e1' e2' ) | BinOp (Ne, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.bool (IntLit.neq n m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.bool (v <> w) - | Const Cint _, Exp.Lvar _ | Exp.Lvar _, Const Cint _ -> + | Const (Cint _), Exp.Lvar _ | Exp.Lvar _, Const (Cint _) -> (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) (* Assume they are not equal *) Exp.one @@ -784,13 +784,13 @@ module Normalize = struct let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i -> + | Const (Cint i), _ when IntLit.iszero i -> e1' - | Const Cint _, _ -> + | Const (Cint _), _ -> e2' - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> e2' - | _, Const Cint _ -> + | _, Const (Cint _) -> e1' | _ -> BinOp (LAnd, e1', e2') ) @@ -799,13 +799,13 @@ module Normalize = struct let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i -> + | Const (Cint i), _ when IntLit.iszero i -> e2' - | Const Cint _, _ -> + | Const (Cint _), _ -> e1' - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> e1' - | _, Const Cint _ -> + | _, Const (Cint _) -> e2' | _ -> BinOp (LOr, e1', e2') ) @@ -826,18 +826,18 @@ module Normalize = struct let ominus = if isPlusA then Binop.MinusA else Binop.MinusPI in let ( +++ ) (x: Exp.t) (y: Exp.t) : Exp.t = match (x, y) with - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> x - | Const Cint i, Const Cint j -> + | Const (Cint i), Const (Cint j) -> Const (Cint (IntLit.add i j)) | _ -> BinOp (oplus, x, y) in let ( --- ) (x: Exp.t) (y: Exp.t) : Exp.t = match (x, y) with - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> x - | Const Cint i, Const Cint j -> + | Const (Cint i), Const (Cint j) -> Const (Cint (IntLit.sub i j)) | _ -> BinOp (ominus, x, y) @@ -859,19 +859,19 @@ module Normalize = struct e2' | _, Const c when Const.iszero_int_float c -> e1' - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.int (n ++ m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.float (v +. w) | UnOp (Neg, f1, _), f2 | f2, UnOp (Neg, f1, _) -> BinOp (ominus, f2, f1) - | BinOp (PlusA, e, Const Cint n1), Const Cint n2 - | BinOp (PlusPI, e, Const Cint n1), Const Cint n2 - | Const Cint n2, BinOp (PlusA, e, Const Cint n1) - | Const Cint n2, BinOp (PlusPI, e, Const Cint n1) -> + | BinOp (PlusA, e, Const (Cint n1)), Const (Cint n2) + | BinOp (PlusPI, e, Const (Cint n1)), Const (Cint n2) + | Const (Cint n2), BinOp (PlusA, e, Const (Cint n1)) + | Const (Cint n2), BinOp (PlusPI, e, Const (Cint n1)) -> e +++ Exp.int (n1 ++ n2) - | BinOp (MinusA, Const Cint n1, e), Const Cint n2 - | Const Cint n2, BinOp (MinusA, Const Cint n1, e) -> + | BinOp (MinusA, Const (Cint n1), e), Const (Cint n2) + | Const (Cint n2), BinOp (MinusA, Const (Cint n1), e) -> Exp.int (n1 ++ n2) --- e | BinOp (MinusA, e1, e2), e3 -> (* (e1-e2)+e3 --> e1 + (e3-e2) *) @@ -902,13 +902,13 @@ module Normalize = struct eval (Exp.UnOp (Neg, e2', None)) | _, Const c when Const.iszero_int_float c -> e1' - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.int (n -- m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.float (v -. w) | _, UnOp (Neg, f2, _) -> eval (e1 +++ f2) - | _, Const Cint n -> + | _, Const (Cint n) -> eval (e1' +++ Exp.int (IntLit.neg n)) | Const _, _ -> e1' --- e2' @@ -935,9 +935,9 @@ module Normalize = struct e1' | _, Const c when Const.isminusone_int_float c -> eval (Exp.UnOp (Neg, e1', None)) - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.int (IntLit.mul n m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.float (v *. w) | Var _, Var _ -> BinOp (Mult, e1', e2') @@ -956,9 +956,9 @@ module Normalize = struct e1' | _, Const c when Const.isone_int_float c -> e1' - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.int (IntLit.div n m) - | Const Cfloat v, Const Cfloat w -> + | Const (Cfloat v), Const (Cfloat w) -> Exp.float (v /. w) | ( Sizeof {typ= {desc= Tarray {elt}}; dynamic_length= Some len} , Sizeof {typ= elt2; dynamic_length= None} ) @@ -977,13 +977,13 @@ module Normalize = struct let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> Exp.get_undefined false - | Const Cint i, _ when IntLit.iszero i -> + | Const (Cint i), _ when IntLit.iszero i -> e1' - | _, Const Cint i when IntLit.isone i -> + | _, Const (Cint i) when IntLit.isone i -> Exp.zero - | Const Cint n, Const Cint m -> + | Const (Cint n), Const (Cint m) -> Exp.int (IntLit.rem n m) | _ -> if abs then Exp.get_undefined false else BinOp (Mod, e1', e2') ) @@ -992,14 +992,14 @@ module Normalize = struct if abs then Exp.get_undefined false else match (e1, e2) with - | Const Cint n, Const Cint m -> ( + | Const (Cint n), Const (Cint m) -> ( try Exp.int (IntLit.shift_left n m) with IntLit.OversizedShift -> BinOp (Shiftlt, eval e1, eval e2) ) - | _, Const Cint m when IntLit.iszero m -> + | _, Const (Cint m) when IntLit.iszero m -> eval e1 - | _, Const Cint m when IntLit.isone m -> + | _, Const (Cint m) when IntLit.isone m -> eval (Exp.BinOp (PlusA, e1, e1)) - | Const Cint m, _ when IntLit.iszero m -> + | Const (Cint m), _ when IntLit.iszero m -> e1 | _ -> BinOp (Shiftlt, eval e1, eval e2) ) @@ -1008,12 +1008,12 @@ module Normalize = struct if abs then Exp.get_undefined false else match (e1, e2) with - | Const Cint n, Const Cint m -> ( + | Const (Cint n), Const (Cint m) -> ( try Exp.int (IntLit.shift_right n m) with IntLit.OversizedShift -> BinOp (Shiftrt, eval e1, eval e2) ) - | _, Const Cint m when IntLit.iszero m -> + | _, Const (Cint m) when IntLit.iszero m -> eval e1 - | Const Cint m, _ when IntLit.iszero m -> + | Const (Cint m), _ when IntLit.iszero m -> e1 | _ -> BinOp (Shiftrt, eval e1, eval e2) ) @@ -1022,11 +1022,11 @@ module Normalize = struct let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i -> + | Const (Cint i), _ when IntLit.iszero i -> e1' - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> e2' - | Const Cint i1, Const Cint i2 -> + | Const (Cint i1), Const (Cint i2) -> Exp.int (IntLit.logand i1 i2) | _ -> if abs then Exp.get_undefined false else BinOp (BAnd, e1', e2') ) @@ -1035,11 +1035,11 @@ module Normalize = struct let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i -> + | Const (Cint i), _ when IntLit.iszero i -> e2' - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> e1' - | Const Cint i1, Const Cint i2 -> + | Const (Cint i1), Const (Cint i2) -> Exp.int (IntLit.logor i1 i2) | _ -> if abs then Exp.get_undefined false else BinOp (BOr, e1', e2') ) @@ -1048,11 +1048,11 @@ module Normalize = struct let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i -> + | Const (Cint i), _ when IntLit.iszero i -> e2' - | _, Const Cint i when IntLit.iszero i -> + | _, Const (Cint i) when IntLit.iszero i -> e1' - | Const Cint i1, Const Cint i2 -> + | Const (Cint i1), Const (Cint i2) -> Exp.int (IntLit.logxor i1 i2) | _ -> if abs then Exp.get_undefined false else BinOp (BXor, e1', e2') ) @@ -1106,24 +1106,24 @@ module Normalize = struct (** Turn an inequality expression into an 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 - | BinOp (PlusA, base', Const Cint n') -> + | BinOp (PlusA, base', Const (Cint n')) -> let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) - | BinOp (PlusA, Const Cint n', base') -> + | BinOp (PlusA, Const (Cint n'), base') -> let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) - | BinOp (MinusA, base', Const Cint n') -> + | BinOp (MinusA, base', Const (Cint n')) -> let new_offset = Exp.int (n ++ n') in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) - | BinOp (MinusA, Const Cint n', base') -> + | BinOp (MinusA, Const (Cint n'), base') -> let new_offset = Exp.int (n' -- n -- IntLit.one) in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) @@ -1134,24 +1134,24 @@ 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 - | BinOp (PlusA, base', Const Cint n') -> + | BinOp (PlusA, base', Const (Cint n')) -> let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) - | BinOp (PlusA, Const Const.Cint n', base') -> + | BinOp (PlusA, Const (Const.Cint n'), base') -> let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) - | BinOp (MinusA, base', Const Cint n') -> + | BinOp (MinusA, base', Const (Cint n')) -> let new_offset = Exp.int (n ++ n') in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) - | BinOp (MinusA, Const Cint n', base') -> + | BinOp (MinusA, Const (Cint n'), base') -> let new_offset = Exp.int (n' -- n -- IntLit.one) in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) @@ -1172,7 +1172,7 @@ module Normalize = struct integer offset representing inequality [sum(pos) - sum(neg) + off <= 0] *) let rec exp_to_posnegoff (e: Exp.t) = match e with - | Const Cint n -> + | Const (Cint n) -> ([], [], n) | BinOp (PlusA, e1, e2) | BinOp (PlusPI, e1, e2) -> let pos1, neg1, n1 = exp_to_posnegoff e1 in @@ -1190,8 +1190,8 @@ module Normalize = struct in (* sort and filter out expressions appearing in both the positive and negative part *) let normalize_posnegoff (pos, neg, off) = - let pos' = List.sort ~cmp:Exp.compare pos in - let neg' = List.sort ~cmp:Exp.compare neg in + let pos' = List.sort ~compare:Exp.compare pos in + let neg' = List.sort ~compare:Exp.compare neg in let rec combine pacc nacc = function | x :: ps, y :: ng -> ( match Exp.compare x y with @@ -1229,7 +1229,7 @@ module Normalize = struct BinOp (Le, lhs_e, Exp.int (IntLit.zero -- n)) in let ineq = - match a with Aeq (ineq, Const Cint i) when IntLit.isone i -> ineq | _ -> assert false + match a with Aeq (ineq, Const (Cint i)) when IntLit.isone i -> ineq | _ -> assert false in match ineq with | BinOp (Le, e1, e2) -> @@ -1249,15 +1249,15 @@ module Normalize = struct let a = Sil.atom_sub sub a0 in let rec normalize_eq (eq: Exp.t * Exp.t) = match eq with - | BinOp (PlusA, e1, Const Cint n1), Const Cint n2 + | BinOp (PlusA, e1, Const (Cint n1)), Const (Cint n2) (* e1+n1==n2 ---> e1==n2-n1 *) - | BinOp (PlusPI, e1, Const Cint n1), Const Cint n2 -> + | BinOp (PlusPI, e1, Const (Cint n1)), Const (Cint n2) -> (e1, Exp.int (n2 -- n1)) - | BinOp (MinusA, e1, Const Cint n1), Const Cint n2 + | BinOp (MinusA, e1, Const (Cint n1)), Const (Cint n2) (* e1-n1==n2 ---> e1==n1+n2 *) - | BinOp (MinusPI, e1, Const Cint n1), Const Cint n2 -> + | BinOp (MinusPI, e1, Const (Cint n1)), Const (Cint n2) -> (e1, Exp.int (n1 ++ n2)) - | BinOp (MinusA, Const Cint n1, e1), Const Cint n2 -> + | BinOp (MinusA, Const (Cint n1), e1), Const (Cint n2) -> (* n1-e1 == n2 -> e1==n1-n2 *) (e1, Exp.int (n1 -- n2)) | Lfield (e1', fld1, _), Lfield (e2', fld2, _) -> @@ -1279,7 +1279,7 @@ module Normalize = struct in 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', _)) + | (UnOp (LNot, e1', _), Const (Cint i) | Const (Cint i), UnOp (LNot, e1', _)) when IntLit.iszero i -> (e1', Exp.zero, true) | _ -> @@ -1316,15 +1316,15 @@ module Normalize = struct 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 -> + | Aeq (BinOp (Le, Var id, Const (Cint n)), Const (Cint i)) when IntLit.isone i -> let lower = Exp.int (n -- IntLit.one) in let a_lower : Sil.atom = Aeq (BinOp (Lt, lower, Var id), Exp.one) in if not (List.mem ~equal:Sil.equal_atom p.pi a_lower) then a' else Aeq (Var id, Exp.int n) - | Aeq (BinOp (Lt, Const Cint n, Var id), Const Cint i) when IntLit.isone i -> + | Aeq (BinOp (Lt, Const (Cint n), Var id), Const (Cint i)) when IntLit.isone i -> let upper = Exp.int (n ++ IntLit.one) in let a_upper : Sil.atom = Aeq (BinOp (Le, Var id, upper), Exp.one) in if not (List.mem ~equal:Sil.equal_atom p.pi a_upper) then a' else Aeq (Var id, upper) - | Aeq (BinOp (Ne, e1, e2), Const Cint i) when IntLit.isone i -> + | Aeq (BinOp (Ne, e1, e2), Const (Cint i)) when IntLit.isone i -> Aneq (e1, e2) | _ -> a' @@ -1347,11 +1347,14 @@ module Normalize = struct 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 + if + phys_equal fld_cnts fld_cnts' + && List.is_sorted ~compare:[%compare : Typ.Fieldname.t * Sil.strexp] fld_cnts then se else - let fld_cnts'' = List.sort ~cmp:[%compare : Typ.Fieldname.t * Sil.strexp] fld_cnts' in + let fld_cnts'' = + List.sort ~compare:[%compare : Typ.Fieldname.t * Sil.strexp] fld_cnts' + in Estruct (fld_cnts'', inst) ) | Earray (len, idx_cnts, inst) -> let len' = exp_normalize_noabs tenv sub len in @@ -1367,11 +1370,12 @@ module Normalize = struct let cnt' = strexp_normalize tenv sub cnt in if phys_equal idx idx' && phys_equal cnt cnt' then x else (idx', cnt') ) in - if phys_equal idx_cnts idx_cnts' - && List.is_sorted ~compare:[%compare : Exp.t * Sil.strexp] idx_cnts + if + phys_equal idx_cnts idx_cnts' + && List.is_sorted ~compare:[%compare : Exp.t * Sil.strexp] idx_cnts then se else - let idx_cnts'' = List.sort ~cmp:[%compare : Exp.t * Sil.strexp] idx_cnts' in + let idx_cnts'' = List.sort ~compare:[%compare : Exp.t * Sil.strexp] idx_cnts' in Earray (len', idx_cnts'', inst) @@ -1533,20 +1537,20 @@ module Normalize = struct 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 ~cmp:Sil.compare_hpred normalized_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) = let normalized_body = List.map ~f:(hpred_normalize tenv Sil.sub_empty) para.body_dll in - let sorted_body = List.sort ~cmp:Sil.compare_hpred normalized_body in + let sorted_body = List.sort ~compare:Sil.compare_hpred normalized_body in {para with body_dll= sorted_body} let sigma_normalize tenv sub sigma = let sigma' = List.map ~f:(hpred_normalize tenv sub) sigma |> make_captured_in_closures_consistent - |> List.stable_sort ~cmp:Sil.compare_hpred + |> List.stable_sort ~compare:Sil.compare_hpred in if equal_sigma sigma sigma' then sigma else sigma' @@ -1555,7 +1559,11 @@ module Normalize = struct 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) = - match a with Aneq (Const Cint n, e) | Aneq (e, Const Cint n) -> (e, n) :: acc | _ -> acc + match a with + | Aneq (Const (Cint n), e) | Aneq (e, Const (Cint n)) -> + (e, n) :: acc + | _ -> + acc in List.fold ~f:get_disequality_info ~init:[] nonineq_list in @@ -1607,7 +1615,7 @@ module Normalize = struct List.filter ~f:(fun (a: Sil.atom) -> match a with - | Aneq (Const Cint n, e) | Aneq (e, Const Cint n) -> + | 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) @@ -1641,7 +1649,7 @@ 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 -> + | 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)) @@ -1651,7 +1659,7 @@ module Normalize = struct true in let pi' = - List.stable_sort ~cmp:Sil.compare_atom + List.stable_sort ~compare:Sil.compare_atom (List.filter ~f:filter_useful_atom nonineq_list @ ineq_list) in let pi'' = pi_sorted_remove_redundant pi' in @@ -1891,7 +1899,7 @@ let sigma_get_start_lexps_sort sigma = let exp_compare_neg e1 e2 = -Exp.compare e1 e2 in let filter e = Exp.free_vars e |> Sequence.for_all ~f:Ident.is_normal in let lexps = Sil.hpred_list_get_lexps filter sigma in - List.sort ~cmp:exp_compare_neg lexps + List.sort ~compare:exp_compare_neg lexps let sigma_dfs_sort tenv sigma = @@ -1982,7 +1990,7 @@ let sigma_get_array_indices sigma = let compute_reindexing_from_indices list = let get_id_offset (e: Exp.t) = match e with - | BinOp (PlusA, Var id, Const Cint offset) -> + | BinOp (PlusA, Var id, Const (Cint offset)) -> if Ident.is_primed id then Some (id, offset) else None | _ -> None @@ -2042,7 +2050,7 @@ let prop_rename_array_indices tenv prop = let indices = sigma_get_array_indices prop.sigma in 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') -> + | BinOp (PlusA, e1', Const (Cint n1')), BinOp (PlusA, e2', Const (Cint n2')) -> not (Exp.equal e1' e2' && IntLit.lt n1' n2') | _ -> true @@ -2081,12 +2089,12 @@ let compute_renaming free_vars = let rec idlist_assoc id = function | [] -> - raise Not_found + raise Caml.Not_found | (i, x) :: l -> if Ident.equal i id then x else idlist_assoc id l -let ident_captured_ren ren id = try idlist_assoc id ren with Not_found -> id +let ident_captured_ren ren id = try idlist_assoc id ren with Caml.Not_found -> id (* If not defined in ren, id should be mapped to itself *) @@ -2322,7 +2330,7 @@ type 'a prop_iter = ; pit_pi: pi (** pure part *) ; pit_newpi: (bool * Sil.atom) list (** newly added atoms. *) ; (* The first records !Config.footprint. *) - pit_old: sigma (** sigma already visited *) + pit_old: sigma (** sigma already visited *) ; pit_curr: Sil.hpred (** current element *) ; pit_state: 'a (** state of current element *) ; pit_new: sigma (** sigma not yet visited *) diff --git a/infer/src/biabduction/Prop.mli b/infer/src/biabduction/Prop.mli index 1d10dccfb..5c80b8e0a 100644 --- a/infer/src/biabduction/Prop.mli +++ b/infer/src/biabduction/Prop.mli @@ -36,7 +36,7 @@ type 'a t = private ; pi: pi (** pure part *) ; sigma_fp: sigma (** abduced spatial part *) ; pi_fp: pi (** abduced pure part *) } - [@@deriving compare] +[@@deriving compare] (** type to describe different strategies for initializing fields of a structure. [No_init] does not initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh diff --git a/infer/src/biabduction/Propgraph.ml b/infer/src/biabduction/Propgraph.ml index ee506dcc8..0b58922f5 100644 --- a/infer/src/biabduction/Propgraph.ml +++ b/infer/src/biabduction/Propgraph.ml @@ -28,15 +28,15 @@ let edge_is_hpred = function Ehpred _ -> true | Eatom _ -> false | Esub_entry _ (** Return the source of the edge *) let edge_get_source = function - | Ehpred Sil.Hpointsto (e, _, _) -> + | Ehpred (Sil.Hpointsto (e, _, _)) -> Some e - | Ehpred Sil.Hlseg (_, _, e, _, _) -> + | Ehpred (Sil.Hlseg (_, _, e, _, _)) -> Some e - | Ehpred Sil.Hdllseg (_, _, e1, _, _, _, _) -> + | Ehpred (Sil.Hdllseg (_, _, e1, _, _, _, _)) -> Some e1 (* only one direction supported for now *) - | Eatom Sil.Aeq (e1, _) -> + | Eatom (Sil.Aeq (e1, _)) -> Some e1 - | Eatom Sil.Aneq (e1, _) -> + | Eatom (Sil.Aneq (e1, _)) -> Some e1 | Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _)) -> Some e @@ -155,14 +155,14 @@ 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 = match (oldedge, newedge) with - | Ehpred Sil.Hpointsto (_, se1, e1), Ehpred Sil.Hpointsto (_, se2, e2) -> + | Ehpred (Sil.Hpointsto (_, se1, e1)), Ehpred (Sil.Hpointsto (_, se2, e2)) -> compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2 - | Eatom Sil.Aeq (_, e1), Eatom Sil.Aeq (_, e2) -> + | Eatom (Sil.Aeq (_, e1)), Eatom (Sil.Aeq (_, e2)) -> compute_exp_diff e1 e2 - | Eatom Sil.Aneq (_, e1), Eatom Sil.Aneq (_, e2) -> + | Eatom (Sil.Aneq (_, e1)), Eatom (Sil.Aneq (_, e2)) -> compute_exp_diff e1 e2 - | Eatom Sil.Apred (_, es1), Eatom Sil.Apred (_, es2) - | Eatom Sil.Anpred (_, es1), Eatom Sil.Anpred (_, es2) -> + | Eatom (Sil.Apred (_, es1)), Eatom (Sil.Apred (_, es2)) + | Eatom (Sil.Anpred (_, es1)), Eatom (Sil.Anpred (_, es2)) -> List.concat (try List.map2_exn ~f:compute_exp_diff es1 es2 with Invalid_argument _ -> []) | Esub_entry (_, e1), Esub_entry (_, e2) -> compute_exp_diff e1 e2 diff --git a/infer/src/biabduction/Prover.ml b/infer/src/biabduction/Prover.ml index b6836c6f2..20ab71138 100644 --- a/infer/src/biabduction/Prover.ml +++ b/infer/src/biabduction/Prover.ml @@ -20,9 +20,9 @@ let decrease_indent_when_exception thunk = IExn.reraise_after exn ~f:(fun () -> L.d_decrease_indent 1) -let compute_max_from_nonempty_int_list l = uw (List.max_elt ~cmp:IntLit.compare_value l) +let compute_max_from_nonempty_int_list l = uw (List.max_elt ~compare:IntLit.compare_value l) -let compute_min_from_nonempty_int_list l = uw (List.min_elt ~cmp:IntLit.compare_value l) +let compute_min_from_nonempty_int_list l = uw (List.min_elt ~compare:IntLit.compare_value l) let rec list_rev_acc acc = function [] -> acc | x :: l -> list_rev_acc (x :: acc) l @@ -48,9 +48,9 @@ let rec is_java_class tenv (typ: Typ.t) = (** Negate an atom *) let atom_negate tenv = function - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> Prop.mk_inequality tenv (Exp.lt e2 e1) - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> Prop.mk_inequality tenv (Exp.le e2 e1) | Sil.Aeq (e1, e2) -> Sil.Aneq (e1, e2) @@ -100,7 +100,7 @@ end = struct let from_leq acc (e1, e2) = match (e1, e2) with | ( Exp.BinOp (Binop.MinusA, (Exp.Var id11 as e11), (Exp.Var id12 as e12)) - , Exp.Const Const.Cint n ) + , Exp.Const (Const.Cint n) ) when not (Ident.equal id11 id12) -> ( match IntLit.to_signed n with | None -> @@ -113,7 +113,8 @@ end = struct let from_lt acc (e1, e2) = match (e1, e2) with - | Exp.Const Const.Cint n, Exp.BinOp (Binop.MinusA, (Exp.Var id21 as e21), (Exp.Var id22 as e22)) + | ( Exp.Const (Const.Cint n) + , Exp.BinOp (Binop.MinusA, (Exp.Var id21 as e21), (Exp.Var id22 as e22)) ) when not (Ident.equal id21 id22) -> ( match IntLit.to_signed n with | None -> @@ -144,7 +145,7 @@ end = struct let sort_then_remove_redundancy constraints = - let constraints_sorted = List.sort ~cmp:compare constraints in + 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) in @@ -303,10 +304,10 @@ end = struct let leqs_sort_then_remove_redundancy leqs = - let leqs_sorted = List.sort ~cmp:leq_compare leqs in + let leqs_sorted = List.sort ~compare:leq_compare leqs in let have_same_key leq1 leq2 = match (leq1, leq2) with - | (e1, Exp.Const Const.Cint n1), (e2, Exp.Const Const.Cint n2) -> + | (e1, Exp.Const (Const.Cint n1)), (e2, Exp.Const (Const.Cint n2)) -> Exp.equal e1 e2 && IntLit.leq n1 n2 | _, _ -> false @@ -315,10 +316,10 @@ end = struct let lts_sort_then_remove_redundancy lts = - let lts_sorted = List.sort ~cmp:lt_compare lts in + let lts_sorted = List.sort ~compare:lt_compare lts in let have_same_key lt1 lt2 = match (lt1, lt2) with - | (Exp.Const Const.Cint n1, e1), (Exp.Const Const.Cint n2, e2) -> + | (Exp.Const (Const.Cint n1), e1), (Exp.Const (Const.Cint n2), e2) -> Exp.equal e1 e2 && IntLit.geq n1 n2 | _, _ -> false @@ -337,18 +338,18 @@ end = struct try let old_upper = Exp.Map.find e umap in if IntLit.leq old_upper new_upper then umap else Exp.Map.add e new_upper umap - with Not_found -> Exp.Map.add e new_upper umap + with Caml.Not_found -> Exp.Map.add e new_upper umap in let lmap_add lmap e new_lower = try let old_lower = Exp.Map.find e lmap in if IntLit.geq old_lower new_lower then lmap else Exp.Map.add e new_lower lmap - with Not_found -> Exp.Map.add e new_lower lmap + with Caml.Not_found -> Exp.Map.add e new_lower lmap in let rec umap_create_from_leqs umap = function | [] -> umap - | (e1, Exp.Const Const.Cint upper1) :: leqs_rest -> + | (e1, Exp.Const (Const.Cint upper1)) :: leqs_rest -> let umap' = umap_add umap e1 upper1 in umap_create_from_leqs umap' leqs_rest | _ :: leqs_rest -> @@ -357,7 +358,7 @@ end = struct let rec lmap_create_from_lts lmap = function | [] -> lmap - | (Exp.Const Const.Cint lower1, e1) :: lts_rest -> + | (Exp.Const (Const.Cint lower1), e1) :: lts_rest -> let lmap' = lmap_add lmap e1 lower1 in lmap_create_from_lts lmap' lts_rest | _ :: lts_rest -> @@ -373,7 +374,7 @@ end = struct 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 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 | [] -> @@ -386,7 +387,7 @@ end = struct 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 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 @@ -419,9 +420,9 @@ end = struct | Sil.Aneq (e1, e2) -> (* != *) neqs := (e1, e2) :: !neqs - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> leqs := (e1, e2) :: !leqs (* <= *) - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> lts := (e1, e2) :: !lts (* < *) | Sil.Aeq _ | Sil.Apred _ | Anpred _ -> () @@ -495,27 +496,28 @@ end = struct let check_le {leqs; lts; neqs= _} e1 e2 = (* L.d_str "check_le "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) match (e1, e2) with - | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 -> + | Exp.Const (Const.Cint n1), Exp.Const (Const.Cint n2) -> IntLit.leq n1 n2 | ( Exp.BinOp (Binop.MinusA, Exp.Sizeof {nbytes= Some nb1}, Exp.Sizeof {nbytes= Some nb2}) - , Exp.Const Const.Cint n2 ) -> + , Exp.Const (Const.Cint n2) ) -> (* [ sizeof(t1) - sizeof(t2) <= n2 ] *) IntLit.(leq (sub (of_int nb1) (of_int nb2)) n2) - | Exp.BinOp (Binop.MinusA, Exp.Sizeof {typ= t1}, Exp.Sizeof {typ= t2}), Exp.Const Const.Cint n2 + | ( Exp.BinOp (Binop.MinusA, Exp.Sizeof {typ= t1}, Exp.Sizeof {typ= t2}) + , Exp.Const (Const.Cint n2) ) when IntLit.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *) check_type_size_lt t1 t2 - | e, Exp.Const Const.Cint n -> + | e, Exp.Const (Const.Cint n) -> (* [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 -> + | Exp.Const (Const.Cint n), e -> (* [ n-1 <= n' < e |- n <= e] *) List.exists ~f:(function - | Exp.Const Const.Cint n', e' -> + | Exp.Const (Const.Cint n'), e' -> Exp.equal e e' && IntLit.leq (n -- IntLit.one) n' | _, _ -> false) @@ -528,19 +530,19 @@ end = struct let check_lt {leqs; lts; neqs= _} e1 e2 = (* L.d_str "check_lt "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) match (e1, e2) with - | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 -> + | Exp.Const (Const.Cint n1), Exp.Const (Const.Cint n2) -> IntLit.lt n1 n2 - | Exp.Const Const.Cint n, e -> + | Exp.Const (Const.Cint n), e -> (* [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, Exp.Const (Const.Cint n) -> (* [e <= n' <= n-1 |- e < n] *) List.exists ~f:(function - | e', Exp.Const Const.Cint n' -> + | e', Exp.Const (Const.Cint n') -> Exp.equal e e' && IntLit.leq n' (n -- IntLit.one) | _, _ -> false) @@ -558,16 +560,18 @@ end = struct (** Find a IntLit.t n such that [t |- e<=n] if possible. *) let compute_upper_bound {leqs; lts= _; neqs= _} e1 = match e1 with - | Exp.Const Const.Cint n1 -> + | Exp.Const (Const.Cint n1) -> Some n1 | _ -> let e_upper_list = List.filter - ~f:(function e', Exp.Const Const.Cint _ -> Exp.equal e1 e' | _, _ -> false) + ~f:(function e', Exp.Const (Const.Cint _) -> Exp.equal e1 e' | _, _ -> false) leqs in let upper_list = - List.map ~f:(function _, Exp.Const Const.Cint n -> n | _ -> assert false) e_upper_list + List.map + ~f:(function _, Exp.Const (Const.Cint n) -> n | _ -> assert false) + e_upper_list in if List.is_empty upper_list then None else Some (compute_min_from_nonempty_int_list upper_list) @@ -576,7 +580,7 @@ end = struct (** Find a IntLit.t n such that [t |- n < e] if possible. *) let compute_lower_bound {leqs= _; lts; neqs= _} e1 = match e1 with - | Exp.Const Const.Cint n1 -> + | Exp.Const (Const.Cint n1) -> Some (n1 -- IntLit.one) | Exp.Sizeof {nbytes= Some n1} -> Some (IntLit.of_int n1 -- IntLit.one) @@ -585,11 +589,13 @@ end = struct | _ -> let e_lower_list = List.filter - ~f:(function Exp.Const Const.Cint _, e' -> Exp.equal e1 e' | _, _ -> false) + ~f:(function Exp.Const (Const.Cint _), e' -> Exp.equal e1 e' | _, _ -> false) lts in let lower_list = - List.map ~f:(function Exp.Const Const.Cint n, _ -> n | _ -> assert false) e_lower_list + List.map + ~f:(function Exp.Const (Const.Cint n), _ -> n | _ -> assert false) + e_lower_list in if List.is_empty lower_list then None else Some (compute_max_from_nonempty_int_list lower_list) @@ -634,12 +640,12 @@ let check_equal tenv prop e1_0 e2_0 = let check_equal () = Exp.equal n_e1 n_e2 in let check_equal_const () = match (n_e1, n_e2) with - | Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d), e2 - | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d) -> + | Exp.BinOp (Binop.PlusA, e1, Exp.Const (Const.Cint d)), e2 + | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const (Const.Cint d)) -> if Exp.equal e1 e2 then IntLit.iszero d else false - | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const Const.Cint i) when IntLit.iszero i -> + | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const (Const.Cint i)) when IntLit.iszero i -> Const.equal c1 c2 - | Exp.Lindex (Exp.Const c1, Exp.Const Const.Cint i), Exp.Const c2 when IntLit.iszero i -> + | Exp.Lindex (Exp.Const c1, Exp.Const (Const.Cint i)), Exp.Const c2 when IntLit.iszero i -> Const.equal c1 c2 | _, _ -> false @@ -688,9 +694,9 @@ let get_bounds tenv prop e0 = let e_norm = Prop.exp_normalize_prop ~destructive:true tenv prop e0 in let e_root, off = match e_norm with - | Exp.BinOp (Binop.PlusA, e, Exp.Const Const.Cint n1) -> + | Exp.BinOp (Binop.PlusA, e, Exp.Const (Const.Cint n1)) -> (e, IntLit.neg n1) - | Exp.BinOp (Binop.MinusA, e, Exp.Const Const.Cint n1) -> + | Exp.BinOp (Binop.MinusA, e, Exp.Const (Const.Cint n1)) -> (e, n1) | _ -> (e_norm, IntLit.zero) @@ -711,24 +717,24 @@ let check_disequal tenv prop e1 e2 = match (ce1, ce2) with | Exp.Const c1, Exp.Const c2 -> Const.kind_equal c1 c2 && not (Const.equal c1 c2) - | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const Const.Cint d) -> + | 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 *) - | ( Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d1) - , Exp.BinOp (Binop.PlusA, e2, Exp.Const Const.Cint d2) ) -> + | ( 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 - | Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d), e2 - | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d) -> + | Exp.BinOp (Binop.PlusA, e1, Exp.Const (Const.Cint d)), e2 + | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const (Const.Cint d)) -> if Exp.equal e1 e2 then not (IntLit.iszero d) else false - | Exp.Lindex (Exp.Const c1, Exp.Const Const.Cint d), Exp.Const c2 -> + | Exp.Lindex (Exp.Const c1, Exp.Const (Const.Cint d)), Exp.Const c2 -> if IntLit.iszero d then not (Const.equal c1 c2) else Const.equal c1 c2 | Exp.Lindex (Exp.Const c1, Exp.Const d1), Exp.Lindex (Exp.Const c2, Exp.Const d2) -> Const.equal c1 c2 && not (Const.equal d1 d2) - | Exp.Const Const.Cint n, Exp.BinOp (Binop.Mult, Exp.Sizeof _, e21) - | Exp.Const Const.Cint n, Exp.BinOp (Binop.Mult, e21, Sizeof _) - | Exp.BinOp (Binop.Mult, Exp.Sizeof _, e21), Exp.Const Const.Cint n - | Exp.BinOp (Binop.Mult, e21, Exp.Sizeof _), Exp.Const Const.Cint n -> + | Exp.Const (Const.Cint n), Exp.BinOp (Binop.Mult, Exp.Sizeof _, e21) + | Exp.Const (Const.Cint n), Exp.BinOp (Binop.Mult, e21, Sizeof _) + | Exp.BinOp (Binop.Mult, Exp.Sizeof _, e21), Exp.Const (Const.Cint n) + | Exp.BinOp (Binop.Mult, e21, Exp.Sizeof _), Exp.Const (Const.Cint n) -> IntLit.iszero n && not (Exp.is_zero e21) | Exp.Lvar pv0, Exp.Lvar pv1 -> (* Addresses of any two local vars must be different *) @@ -736,7 +742,7 @@ let check_disequal tenv prop e1 e2 = | 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 - | Exp.Lvar _, Exp.Const Const.Cint _ | Exp.Const Const.Cint _, Exp.Lvar _ -> + | 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 *) true @@ -778,7 +784,7 @@ let check_disequal tenv prop e1 e2 = else let sigma_rest' = List.rev_append sigma_irrelevant sigma_rest in f [] e2 sigma_rest' ) - | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _)) :: sigma_rest -> + | Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest -> if is_root tenv prop iF e <> None || is_root tenv prop iB e <> None then let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') @@ -827,7 +833,7 @@ let check_le_normalized tenv prop e1 e2 = (* L.d_str "check_le_normalized "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) let eL, eR, off = match (e1, e2) with - | Exp.BinOp (Binop.MinusA, f1, f2), Exp.Const Const.Cint n -> + | Exp.BinOp (Binop.MinusA, f1, f2), Exp.Const (Const.Cint n) -> if Exp.equal f1 f2 then (Exp.zero, Exp.zero, n) else (f1, f2, n) | _ -> (e1, e2, IntLit.zero) @@ -898,9 +904,9 @@ let check_atom tenv prop a0 = (Prop.pp_prop Pp.text) prop_no_fp ; Out_channel.close outc ) ; match a with - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> check_le_normalized tenv prop e1 e2 - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i -> check_lt_normalized tenv prop e1 e2 | Sil.Aeq (e1, e2) -> check_equal tenv prop e1 e2 @@ -922,8 +928,9 @@ let check_allocatedness tenv prop e = is_root tenv prop e1 n_e <> None else false | Sil.Hdllseg (k, _, iF, oB, oF, iB, _) -> - if Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop iF oF - || check_disequal tenv prop iB oB + if + Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop iF oF + || check_disequal tenv prop iB oB then is_root tenv prop iF n_e <> None || is_root tenv prop iB n_e <> None else false in @@ -941,7 +948,7 @@ let check_inconsistency_two_hpreds tenv prop = if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest -> if Exp.equal iF e || Exp.equal iB e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hlseg (Sil.Lseg_PE, _, e1, Exp.Const Const.Cint i, _) as hpred) :: sigma_rest + | (Sil.Hlseg (Sil.Lseg_PE, _, e1, Exp.Const (Const.Cint i), _) as hpred) :: sigma_rest when IntLit.iszero i -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest | (Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) as hpred) :: sigma_rest -> @@ -952,7 +959,7 @@ let check_inconsistency_two_hpreds tenv prop = let e_new = Prop.exp_normalize_prop ~destructive:true tenv prop_new e in f e_new [] sigma_new else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, Exp.Const Const.Cint i, _, _) as hpred) :: sigma_rest + | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, Exp.Const (Const.Cint i), _, _) as hpred) :: sigma_rest when IntLit.iszero i -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, e3, _, _) as hpred) :: sigma_rest -> @@ -1240,8 +1247,9 @@ end = struct let d_missing sub = (* optional print of missing: if print something, prepend with newline *) - if !missing_pi <> [] || !missing_sigma <> [] || !missing_fld <> [] || !missing_typ <> [] - || not (Sil.is_sub_empty sub) + if + !missing_pi <> [] || !missing_sigma <> [] || !missing_fld <> [] || !missing_typ <> [] + || not (Sil.is_sub_empty sub) then ( L.d_ln () ; L.d_str "[" ; d_missing_ sub ; L.d_str "]" ) @@ -1366,8 +1374,9 @@ let exp_imply tenv calc_missing (subs: subst2) e1_in e2_in : subst2 = | e1, Exp.Var v2 -> let occurs_check v e = (* check whether [v] occurs in normalized [e] *) - if Exp.ident_mem e v - && Exp.ident_mem (Prop.exp_normalize_prop ~destructive:true tenv Prop.prop_emp e) v + if + Exp.ident_mem e v + && Exp.ident_mem (Prop.exp_normalize_prop ~destructive:true tenv Prop.prop_emp e) v then raise (IMPL_EXC ("occurs check", subs, EXC_FALSE_EXPS (e1, e2))) in if Ident.is_primed v2 then @@ -1405,10 +1414,10 @@ let exp_imply tenv calc_missing (subs: subst2) e1_in e2_in : subst2 = | Exp.Const c1, Exp.Const c2 -> if Const.equal c1 c2 then subs else raise (IMPL_EXC ("constants not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Const Const.Cint _, Exp.BinOp (Binop.PlusPI, _, _) -> + | Exp.Const (Const.Cint _), Exp.BinOp (Binop.PlusPI, _, _) -> raise (IMPL_EXC ("pointer+index cannot evaluate to a constant", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Const Const.Cint n1, Exp.BinOp (Binop.PlusA, f1, Exp.Const Const.Cint n2) -> + | Exp.Const (Const.Cint n1), Exp.BinOp (Binop.PlusA, f1, Exp.Const (Const.Cint n2)) -> do_imply subs (Exp.int (n1 -- n2)) f1 | Exp.BinOp (op1, e1, f1), Exp.BinOp (op2, e2, f2) when Binop.equal op1 op2 -> do_imply (do_imply subs e1 e2) f1 f2 @@ -1424,10 +1433,10 @@ let exp_imply tenv calc_missing (subs: subst2) e1_in e2_in : subst2 = , Exp.Sizeof {typ= t2; dynamic_length= Some d2; subtype= st2} ) when Typ.equal t1 t2 && Exp.equal d1 d2 && Subtype.equal_modulo_flag st1 st2 -> subs - | e', Exp.Const Const.Cint n + | e', Exp.Const (Const.Cint n) when IntLit.iszero n && check_disequal tenv Prop.prop_emp e' Exp.zero -> raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Const Const.Cint n, e' + | Exp.Const (Const.Cint n), e' when IntLit.iszero n && check_disequal tenv Prop.prop_emp e' Exp.zero -> raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) | e1, Exp.Const _ -> @@ -1460,9 +1469,9 @@ let path_to_id path = match f e with None -> None | Some s -> Some (s ^ "_" ^ Exp.to_string ind) ) | Exp.Lvar _ -> Some (Exp.to_string path) - | Exp.Const Const.Cstr s -> + | Exp.Const (Const.Cstr s) -> Some ("_const_str_" ^ s) - | Exp.Const Const.Cclass c -> + | Exp.Const (Const.Cclass c) -> Some ("_const_class_" ^ Ident.name_to_string c) | Exp.Const _ -> None @@ -1928,8 +1937,9 @@ let cast_exception tenv texp1 texp2 e1 subs = let _ = match (texp1, texp2) with | Exp.Sizeof {typ= t1}, Exp.Sizeof {typ= t2; subtype= st2} -> - if Config.developer_mode - || Subtype.is_cast st2 && not (Subtyping_check.check_subtype tenv t1 t2) + if + Config.developer_mode + || (Subtype.is_cast st2 && not (Subtyping_check.check_subtype tenv t1 t2)) then ProverState.checks := Class_cast_check (texp1, texp2, e1) :: !ProverState.checks | _ -> () @@ -1957,8 +1967,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 - || Typ.is_objc_class typ1 && Typ.is_objc_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 ) | _ -> @@ -2312,9 +2322,9 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * -> ( let e2 = Sil.exp_sub (`Exp (snd subs)) e2_ in match e2 with - | Exp.Const Const.Cstr s -> + | Exp.Const (Const.Cstr s) -> Some (s, true) - | Exp.Const Const.Cclass c -> + | Exp.Const (Const.Cclass c) -> Some (Ident.name_to_string c, false) | _ -> None ) @@ -2709,7 +2719,7 @@ exception NO_COVER let find_minimum_pure_cover tenv cases = let cases = let compare (pi1, _) (pi2, _) = Int.compare (List.length pi1) (List.length pi2) in - List.sort ~cmp:compare cases + List.sort ~compare cases in let rec grow seen todo = match todo with diff --git a/infer/src/biabduction/Rearrange.ml b/infer/src/biabduction/Rearrange.ml index b8e19fc7d..d0169d605 100644 --- a/infer/src/biabduction/Rearrange.ml +++ b/infer/src/biabduction/Rearrange.ml @@ -47,12 +47,12 @@ let check_bad_index tenv pname p len index loc = let index_nonnegative = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, Exp.zero, index)) in Prover.check_zero tenv index || (* index 0 always in bound, even when we know nothing about len *) - Prover.check_atom tenv p index_not_too_large && Prover.check_atom tenv p index_nonnegative + (Prover.check_atom tenv p index_not_too_large && Prover.check_atom tenv p index_nonnegative) in let index_has_bounds () = match Prover.get_bounds tenv p index with Some _, Some _ -> true | _ -> false in - let get_const_opt = function Exp.Const Const.Cint n -> Some n | _ -> None in + let get_const_opt = function Exp.Const (Const.Cint n) -> Some n | _ -> None in if not (index_provably_in_bound ()) then let len_const_opt = get_const_opt len in let index_const_opt = get_const_opt index in @@ -108,7 +108,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp match (t.desc, off) with | Tstruct _, [] -> ([], Sil.Estruct ([], inst), t) - | Tstruct name, (Off_fld (f, _)) :: off' -> ( + | Tstruct name, Off_fld (f, _) :: off' -> ( match Tenv.lookup tenv name with | Some ({fields; statics} as struct_typ) -> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') (fields @ statics) with @@ -121,7 +121,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp if Typ.Fieldname.equal f f' then (f, res_t', a') else (f', t', a') in let fields' = - List.sort ~cmp:Typ.Struct.compare_field (List.map ~f:replace_typ_of_f fields) + List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_typ_of_f fields) in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; (atoms', se, t) @@ -129,7 +129,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp fail t off __POS__ ) | None -> fail t off __POS__ ) - | Tstruct _, (Off_index e) :: off' -> + | Tstruct _, Off_index e :: off' -> let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t off' inst in @@ -146,7 +146,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp match off with | [] -> ([], Sil.Earray (len, [], inst), t) - | (Sil.Off_index e) :: off' -> + | Sil.Off_index e :: off' -> bounds_check tenv pname orig_prop len e (State.get_loc ()) ; let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst @@ -155,12 +155,12 @@ 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 ~default:t res_t' ?length ?stride in (Sil.Aeq (e, e') :: atoms', se, res_t) - | (Sil.Off_fld _) :: _ -> + | Sil.Off_fld _ :: _ -> assert false ) | Tint _, [] | Tfloat _, [] | Tvoid, [] | Tfun _, [] | Tptr _, [] | TVar _, [] -> let id = new_id () in ([], Sil.Eexp (Exp.Var id, inst), t) - | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), (Off_index e) :: off' -> + | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), Off_index e :: off' -> (* In this case, we lift t to the t array. *) let t', mk_typ_f = match t.Typ.desc with @@ -208,10 +208,10 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp | [], Sil.Earray _, _ -> let off_new = Sil.Off_index Exp.zero :: off in strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst - | (Off_fld _) :: _, Sil.Earray _, Tarray _ -> + | Off_fld _ :: _, Sil.Earray _, Tarray _ -> let off_new = Sil.Off_index Exp.zero :: off in strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst - | (Off_fld (f, _)) :: off', Sil.Estruct (fsel, inst'), Tstruct name -> ( + | Off_fld (f, _) :: off', Sil.Estruct (fsel, inst'), Tstruct name -> ( match Tenv.lookup tenv name with | Some ({fields; statics} as struct_typ) -> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') (fields @ statics) with @@ -228,14 +228,14 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp in let res_fsel' = List.sort - ~cmp:[%compare : Typ.Fieldname.t * Sil.strexp] + ~compare:[%compare : Typ.Fieldname.t * Sil.strexp] (List.map ~f:replace_fse fsel) in let replace_fta ((f1, _, a1) as fta1) = if Typ.Fieldname.equal f f1 then (f1, res_typ', a1) else fta1 in let fields' = - List.sort ~cmp:Typ.Struct.compare_field (List.map ~f:replace_fta fields) + List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields) in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; (res_atoms', Sil.Estruct (res_fsel', inst'), typ) :: acc @@ -247,13 +247,13 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp inst in let res_fsel' = - List.sort ~cmp:[%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') in let fields' = - List.sort ~cmp:Typ.Struct.compare_field (List.map ~f:replace_fta fields) + List.sort ~compare:Typ.Struct.compare_field (List.map ~f:replace_fta fields) in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; [(atoms', Sil.Estruct (res_fsel', inst'), typ)] ) @@ -261,10 +261,10 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp raise (Exceptions.Missing_fld (f, __POS__)) ) | None -> raise (Exceptions.Missing_fld (f, __POS__)) ) - | (Off_fld _) :: _, _, _ -> + | Off_fld _ :: _, _, _ -> raise (Exceptions.Bad_footprint __POS__) - | (Off_index _) :: _, Sil.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _) - | (Off_index _) :: _, Sil.Estruct _, Tstruct _ -> + | Off_index _ :: _, Sil.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _) + | Off_index _ :: _, Sil.Estruct _, Tstruct _ -> (* L.d_strln_color Orange "turn into an array"; *) let len = match se with @@ -278,7 +278,7 @@ let rec strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp let typ_new = Typ.mk_array typ in strexp_extend_values_ pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst - | ( (Off_index e) :: off' + | ( Off_index e :: off' , Sil.Earray (len, esel, inst_arr) , Tarray {elt= typ'; length= len_for_typ'; stride} ) -> ( @@ -318,7 +318,7 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in let array_is_full = match array_len with - | Exp.Const Const.Cint n' -> + | Exp.Const (Const.Cint n') -> IntLit.geq (IntLit.of_int (List.length array_cont)) n' | _ -> false @@ -333,7 +333,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 ~cmp:[%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 @@ -347,7 +347,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 ~cmp:[%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 @@ -457,9 +457,10 @@ 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 (* in angelic mode, purposely ignore dangling pointer warnings during the footprint phase -- we + if + (* in angelic mode, purposely ignore dangling pointer warnings during the footprint phase -- we * will fix them during the re - execution phase *) - not !Config.footprint + not !Config.footprint then ( L.internal_error "!!!! Footprint Error, Bad Root : %a !!!! @\n" Exp.pp lexp ; let deref_str = Localise.deref_str_dangling None in @@ -523,7 +524,7 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp = let rec check_offset se = function | [] -> None - | (Sil.Off_fld (fld, _)) :: off' -> ( + | Sil.Off_fld (fld, _) :: off' -> ( match se with | Sil.Estruct (fsel, _) -> ( match List.find ~f:(fun (fld', _) -> Typ.Fieldname.equal fld fld') fsel with @@ -533,7 +534,7 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp = Some fld ) | _ -> Some fld ) - | (Sil.Off_index _) :: _ -> + | Sil.Off_index _ :: _ -> None in check_offset se offset @@ -563,7 +564,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = atoms_se_te_list | Sil.Hlseg (k, hpara, e1, e2, el) -> ( match hpara.Sil.body with - | (Sil.Hpointsto (e', se', te')) :: body_rest -> + | Sil.Hpointsto (e', se', te') :: body_rest -> let atoms_se_te_list = strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp) se' te' offset inst @@ -651,7 +652,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = [([], footprint_sigma)] in List.map - ~f:(fun (atoms, sigma') -> (atoms, List.stable_sort ~cmp:Sil.compare_hpred sigma')) + ~f:(fun (atoms, sigma') -> (atoms, List.stable_sort ~compare:Sil.compare_hpred sigma')) atoms_sigma_list in let iter_atoms_fp_sigma_list = list_product iter_list atoms_fp_sigma_list in @@ -856,8 +857,8 @@ let add_guarded_by_constraints tenv prop lexp pdesc = List.find_map ~f:(fun hpred -> match[@warning "-57"] (* FIXME: silenced warning may be legit *) 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}) + | 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}) -> ( @@ -1003,10 +1004,11 @@ let add_guarded_by_constraints tenv prop lexp pdesc = (* private method. add locked proof obligation to [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 ) - && should_warn pdesc + if + 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 *) warn accessed_fld guarded_by_str @@ -1309,7 +1311,7 @@ let type_at_offset tenv texp off = match (off, typ.desc) with | [], _ -> Some typ - | (Off_fld (f, _)) :: off', Tstruct name -> ( + | Off_fld (f, _) :: off', Tstruct name -> ( match Tenv.lookup tenv name with | Some {fields} -> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') fields with @@ -1319,7 +1321,7 @@ let type_at_offset tenv texp off = None ) | None -> None ) - | (Off_index _) :: off', Tarray {elt= typ'} -> + | Off_index _ :: off', Tarray {elt= typ'} -> strip_offset off' typ' | _ -> None @@ -1342,8 +1344,9 @@ let check_type_size tenv pname prop texp off typ_from_instr = L.d_str "typ_o: " ; Typ.d_full typ_of_object ; L.d_ln () ; - if Prover.type_size_comparable typ_from_instr typ_of_object - && not (Prover.check_type_size_leq typ_from_instr typ_of_object) + if + Prover.type_size_comparable typ_from_instr typ_of_object + && not (Prover.check_type_size_leq typ_from_instr typ_of_object) then let deref_str = Localise.deref_str_pointer_size_mismatch typ_from_instr typ_of_object in let loc = State.get_loc () in @@ -1368,7 +1371,7 @@ let check_type_size tenv pname prop texp off typ_from_instr = 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)) :: _ -> ( + | Sil.Off_fld (f, fld_typ) :: _ -> ( match fld_typ.desc with | Tstruct _ -> (* access through field: get the struct type from the field *) @@ -1384,7 +1387,7 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst fld_typ | _ -> typ_from_instr ) - | (Sil.Off_index _) :: off -> + | Sil.Off_index _ :: off -> Typ.mk_array (root_typ_of_offsets off) | _ -> typ_from_instr @@ -1507,7 +1510,7 @@ let var_has_annotation ?(check_weak_captured_var= false) pdesc is_annotation pva let is_weak_captured_var = is_weak_captured_var pdesc (Pvar.to_string pvar) in let ann_sig = Models.get_modelled_annotated_signature (Specs.pdesc_resolve_attributes pdesc) in AnnotatedSignature.param_has_annot is_annotation pvar ann_sig - || check_weak_captured_var && is_weak_captured_var + || (check_weak_captured_var && is_weak_captured_var) let attr_has_annot is_annotation tenv prop exp = @@ -1518,7 +1521,9 @@ let attr_has_annot is_annotation tenv prop exp = | _ -> None in - try List.find_map ~f:attr_has_annot (Attribute.get_for_exp tenv prop exp) with Not_found -> None + try List.find_map ~f:attr_has_annot (Attribute.get_for_exp tenv prop exp) with + | Not_found_s _ | Caml.Not_found -> + None let is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp (fld, strexp) = @@ -1638,13 +1643,13 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = raise (Exceptions.Empty_vector_access (err_desc, __POS__)) else raise (Exceptions.Null_dereference (err_desc, __POS__)) ) ; match attribute_opt with - | Some Apred (Adangling dk, _) -> + | Some (Apred (Adangling dk, _)) -> let deref_str = Localise.deref_str_dangling (Some dk) in let err_desc = Errdesc.explain_dereference pname tenv deref_str prop (State.get_loc ()) in raise (Exceptions.Dangling_pointer_dereference (Some dk, err_desc, __POS__)) - | Some Apred (Aundef _, _) -> + | Some (Apred (Aundef _, _)) -> () - | Some Apred (Aresource ({ra_kind= Rrelease} as ra), _) -> + | Some (Apred (Aresource ({ra_kind= Rrelease} as ra), _)) -> let deref_str = Localise.deref_str_freed ra in let err_desc = Errdesc.explain_dereference pname tenv ~use_buckets:true deref_str prop loc in raise (Exceptions.Use_after_free (err_desc, __POS__)) @@ -1692,7 +1697,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = let get_exp_called () = (* Exp called in the block's function call*) match State.get_instr () with - | Some Sil.Call (_, Exp.Var id, _, _, _) -> + | Some (Sil.Call (_, Exp.Var id, _, _, _)) -> Errdesc.find_ident_assignment (State.get_node ()) id | _ -> None diff --git a/infer/src/biabduction/RetainCycles.ml b/infer/src/biabduction/RetainCycles.ml index 372f51ded..7313ab96b 100644 --- a/infer/src/biabduction/RetainCycles.ml +++ b/infer/src/biabduction/RetainCycles.ml @@ -195,7 +195,7 @@ let get_cycles found_cycles root tenv prop = match get_points_to f_exp with | None -> found_cycles - | Some Sil.Hpointsto (_, Sil.Estruct (new_fields, _), Exp.Sizeof {typ= te}) + | Some (Sil.Hpointsto (_, Sil.Estruct (new_fields, _), Exp.Sizeof {typ= te})) when edge_is_strong tenv obj_edge -> let rc_to = {rc_node_exp= f_exp; rc_node_typ= te} in dfs ~found_cycles ~root_node ~from_node:rc_to ~rev_path:(edge :: rev_path) diff --git a/infer/src/biabduction/State.ml b/infer/src/biabduction/State.ml index c08ad91b6..980d587f4 100644 --- a/infer/src/biabduction/State.ml +++ b/infer/src/biabduction/State.ml @@ -19,13 +19,14 @@ module F = Format type failure_stats = { mutable instr_fail: int ; (* number of instruction failures since the current node started *) - mutable instr_ok: int + mutable instr_ok: int ; (* number of instruction successes since the current node started *) - mutable node_fail: int + mutable node_fail: int ; (* number of node failures (i.e. at least one instruction failure) *) - mutable node_ok: int + mutable node_ok: int ; (* number of node successes (i.e. no instruction failures) *) - mutable first_failure: (Location.t * (int * Caml.Digest.t) * int * Errlog.loc_trace * exn) option + mutable first_failure: + (Location.t * (int * Caml.Digest.t) * int * Errlog.loc_trace * exn) option (* exception at the first failure *) } module NodeHash = Procdesc.NodeHash @@ -72,7 +73,7 @@ let reset_diverging_states_node () = !gs.diverging_states_node <- Paths.PathSet. let reset () = gs := initial () let get_failure_stats node = - try NodeHash.find !gs.failure_map node with Not_found -> + try NodeHash.find !gs.failure_map node with Caml.Not_found -> let fs = {instr_fail= 0; instr_ok= 0; node_fail= 0; node_ok= 0; first_failure= None} in NodeHash.add !gs.failure_map node fs ; fs @@ -189,7 +190,7 @@ let mk_find_duplicate_nodes proc_desc : Procdesc.Node.t -> Procdesc.NodeSet.t = let do_node node = let normalized_instrs = instrs_normalize (Procdesc.Node.get_instrs node) in let key = get_key node in - let s = try M.find key !m with Not_found -> S.empty in + let s = try M.find key !m with Caml.Not_found -> S.empty in if S.cardinal s > E.threshold then raise E.Threshold ; let s' = S.add (node, normalized_instrs) s in m := M.add key s' !m @@ -207,7 +208,7 @@ let mk_find_duplicate_nodes proc_desc : Procdesc.Node.t -> Procdesc.NodeSet.t = | [this], others -> (this, others) | _ -> - raise Not_found + raise Caml.Not_found in let duplicates = let equal_normalized_instrs (_, normalized_instrs') = @@ -218,7 +219,7 @@ let mk_find_duplicate_nodes proc_desc : Procdesc.Node.t -> Procdesc.NodeSet.t = List.fold ~f:(fun nset (node', _) -> Procdesc.NodeSet.add node' nset) ~init:Procdesc.NodeSet.empty duplicates - with Not_found -> Procdesc.NodeSet.singleton node + with Caml.Not_found -> Procdesc.NodeSet.singleton node in find_duplicate_nodes diff --git a/infer/src/biabduction/SymExec.ml b/infer/src/biabduction/SymExec.ml index d890446ac..07808decd 100644 --- a/infer/src/biabduction/SymExec.ml +++ b/infer/src/biabduction/SymExec.ml @@ -17,7 +17,7 @@ module F = Format let rec fldlist_assoc fld = function | [] -> - raise Not_found + raise Caml.Not_found | (fld', x, _) :: l -> if Typ.Fieldname.equal fld fld' then x else fldlist_assoc fld l @@ -36,12 +36,13 @@ let unroll_type tenv (typ: Typ.t) (off: Sil.offset) = | Tstruct name, Off_fld (fld, _) -> ( match Tenv.lookup tenv name with | Some {fields; statics} -> ( - try fldlist_assoc fld (fields @ statics) with Not_found -> fail Typ.Fieldname.to_string fld ) + try fldlist_assoc fld (fields @ statics) with Caml.Not_found -> + fail Typ.Fieldname.to_string fld ) | None -> fail Typ.Fieldname.to_string fld ) | Tarray {elt}, Off_index _ -> elt - | _, Off_index Const Cint i when IntLit.iszero i -> + | _, Off_index (Const (Cint i)) when IntLit.iszero i -> typ | _ -> fail Sil.offset_to_string off @@ -104,11 +105,11 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty let offlist' = Sil.Off_index Exp.zero :: offlist in apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst lookup_inst - | (Sil.Off_fld _) :: _, Sil.Earray _, _ -> + | Sil.Off_fld _ :: _, Sil.Earray _, _ -> let offlist_new = Sil.Off_index Exp.zero :: offlist in apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist_new f inst lookup_inst - | (Sil.Off_fld (fld, fld_typ)) :: offlist', Sil.Estruct (fsel, inst'), Typ.Tstruct name -> ( + | 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) -> ( @@ -137,10 +138,10 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty | None -> pp_error () ; assert false ) - | (Sil.Off_fld _) :: _, _, _ -> + | Sil.Off_fld _ :: _, _, _ -> pp_error () ; assert false - | ( (Sil.Off_index idx) :: offlist' + | ( Sil.Off_index idx :: offlist' , Sil.Earray (len, esel, inst1) , Typ.Tarray {elt= t'; length= len'; stride= stride'} ) -> ( @@ -164,7 +165,7 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty L.d_strln " not materialized -- returning nondeterministic value" ; let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in (res_e', strexp, typ, None) ) - | (Sil.Off_index _) :: _, _, _ -> + | Sil.Off_index _ :: _, _, _ -> (* This case should not happen. The rearrangement should have materialized all the accessed cells. *) pp_error () ; @@ -261,7 +262,7 @@ 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 @@ -288,7 +289,7 @@ let rec prune tenv ~positive condition prop = match Prop.exp_normalize_prop ~destructive:true tenv prop condition with | Exp.Var _ | Exp.Lvar _ -> prune_ne tenv ~positive condition Exp.zero prop - | Exp.Const Const.Cint i when IntLit.iszero i -> + | Exp.Const (Const.Cint i) when IntLit.iszero i -> if positive then Propset.empty else Propset.singleton tenv prop | Exp.Const (Const.Cint _ | Const.Cstr _ | Const.Cclass _) | Exp.Sizeof _ -> if positive then Propset.singleton tenv prop else Propset.empty @@ -300,15 +301,15 @@ 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 @@ -373,17 +374,17 @@ 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 + | Exp.Const (Const.Cint n) when IntLit.geq n IntLit.zero && IntLit.leq n (IntLit.of_int (String.length s)) -> string_lookup s n | _ -> Exp.get_undefined false in Some value - | Exp.Const Const.Cstr s -> + | Exp.Const (Const.Cstr s) -> Some (string_lookup s IntLit.zero) | _ -> None @@ -392,12 +393,12 @@ let check_constant_string_dereference lexp = (** Normalize an expression and check for arithmetic problems *) let check_arith_norm_exp tenv pname exp prop = match Attribute.find_arithmetic_problem tenv (State.get_path_pos ()) prop exp with - | Some Attribute.Div0 div, prop' -> + | Some (Attribute.Div0 div), prop' -> let desc = Errdesc.explain_divide_by_zero tenv div (State.get_node ()) (State.get_loc ()) in let exn = Exceptions.Divide_by_zero (desc, __POS__) in Reporting.log_warning_deprecated pname exn ; (Prop.exp_normalize_prop tenv prop exp, prop') - | Some Attribute.UminusUnsigned (e, typ), prop' -> + | Some (Attribute.UminusUnsigned (e, typ)), prop' -> let desc = Errdesc.explain_unary_minus_applied_to_unsigned_expression tenv e typ (State.get_node ()) (State.get_loc ()) @@ -421,19 +422,19 @@ let check_already_dereferenced tenv pname cond prop = Some id | Exp.UnOp (Unop.LNot, e, _) -> is_check_zero e - | Exp.BinOp ((Binop.Eq | Binop.Ne), Exp.Const Const.Cint i, Exp.Var id) - | Exp.BinOp ((Binop.Eq | Binop.Ne), Exp.Var id, Exp.Const Const.Cint i) + | Exp.BinOp ((Binop.Eq | Binop.Ne), Exp.Const (Const.Cint i), Exp.Var id) + | Exp.BinOp ((Binop.Eq | Binop.Ne), Exp.Var id, Exp.Const (Const.Cint i)) when IntLit.iszero i -> Some id (* These two patterns appear frequently in Prune nodes *) | Exp.BinOp ( (Binop.Eq | Binop.Ne) - , Exp.BinOp (Binop.Eq, Exp.Var id, Exp.Const Const.Cint i) - , Exp.Const Const.Cint j ) + , Exp.BinOp (Binop.Eq, Exp.Var id, Exp.Const (Const.Cint i)) + , Exp.Const (Const.Cint j) ) | Exp.BinOp ( (Binop.Eq | Binop.Ne) - , Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, Exp.Var id) - , Exp.Const Const.Cint j ) + , Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), Exp.Var id) + , Exp.Const (Const.Cint j) ) when IntLit.iszero i && IntLit.iszero j -> Some id | _ -> @@ -443,7 +444,7 @@ let check_already_dereferenced tenv pname cond prop = match is_check_zero cond with | Some id -> ( match find_hpred (Prop.exp_normalize_prop tenv prop (Exp.Var id)) with - | Some Sil.Hpointsto (_, se, _) -> ( + | Some (Sil.Hpointsto (_, se, _)) -> ( match Tabulation.find_dereference_without_null_check_in_sexp se with | Some n -> Some (id, n) @@ -470,11 +471,11 @@ let check_already_dereferenced tenv pname cond prop = raising an exception in that case *) let check_deallocate_static_memory prop_after = let check_deallocated_attribute = function - | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [(Lvar pv)]) + | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [Lvar pv]) when Pvar.is_local pv || Pvar.is_global pv -> let freed_desc = Errdesc.explain_deallocate_stack_var pv ra in raise (Exceptions.Deallocate_stack_variable freed_desc) - | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [(Const Cstr s)]) -> + | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [Const (Cstr s)]) -> let freed_desc = Errdesc.explain_deallocate_constant_string s ra in raise (Exceptions.Deallocate_static_memory freed_desc) | _ -> @@ -534,14 +535,14 @@ let resolve_typename prop receiver_exp = let rec loop = function | [] -> None - | (Sil.Hpointsto (e, _, typexp)) :: _ when Exp.equal e receiver_exp -> + | Sil.Hpointsto (e, _, typexp) :: _ when Exp.equal e receiver_exp -> Some typexp | _ :: hpreds -> loop hpreds in loop prop.Prop.sigma in - match typexp_opt with Some Exp.Sizeof {typ= {desc= Tstruct name}} -> Some name | _ -> None + match typexp_opt with Some (Exp.Sizeof {typ= {desc= Tstruct name}}) -> Some name | _ -> None (** If the dynamic type of the receiver actual T_actual is a subtype of the receiver type T_formal @@ -699,13 +700,14 @@ let call_constructor_url_update_args pname actual_params = 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 :: _ -> - if String.equal frst "http" || String.equal frst "ftp" || String.equal frst "https" - || String.equal frst "mailto" || String.equal frst "jar" + if + String.equal frst "http" || String.equal frst "ftp" || String.equal frst "https" + || String.equal frst "mailto" || String.equal frst "jar" then [this; (Exp.Const (Const.Cstr frst), atype)] else actual_params | _ -> @@ -735,8 +737,9 @@ let receiver_self receiver prop = a check for null, which is considered good practice. *) 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 current_pname + if + Typ.Procname.is_constructor callee_pname && receiver_self receiver pre && !Config.footprint + && Typ.Procname.is_constructor current_pname then match ret_id with | Some (ret_id, _) -> @@ -804,8 +807,9 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ else 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) - && not (Rearrange.is_only_pt_by_fld_or_param_nonnull pdesc tenv pre receiver) + if + !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 = (* returns: (objc_null(res) /\ receiver=0) or an empty list of results *) @@ -1113,8 +1117,8 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p | Sil.Prune (cond, loc, true_branch, ik) -> let prop__ = Attribute.nullify_exp_with_objc_null tenv prop_ cond in let check_condition_always_true_false () = - if !Language.curr_language <> Language.Clang - || Config.report_condition_always_true_in_clang + if + !Language.curr_language <> Language.Clang || Config.report_condition_always_true_in_clang then let report_condition_always_true_false i = let skip_loop = @@ -1131,7 +1135,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p true_branch && not skip_loop in match Prop.exp_normalize_prop tenv Prop.prop_emp cond with - | Exp.Const Const.Cint i when report_condition_always_true_false i -> + | Exp.Const (Const.Cint i) when report_condition_always_true_false i -> let node = State.get_node () in let desc = Errdesc.explain_condition_always_true_false tenv i cond node loc in let exn = @@ -1146,7 +1150,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p check_condition_always_true_false () ; let n_cond, prop = check_arith_norm_exp tenv current_pname cond prop__ in ret_old_path (Propset.to_proplist (prune tenv ~positive:true n_cond prop)) - | Sil.Call (ret_id, Exp.Const Const.Cfun callee_pname, actual_params, loc, call_flags) -> ( + | Sil.Call (ret_id, Exp.Const (Const.Cfun callee_pname), actual_params, loc, call_flags) -> ( match Builtin.get callee_pname with | Some exec_builtin -> exec_builtin (call_args prop_ callee_pname actual_params ret_id loc) @@ -1245,9 +1249,10 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p else [(prop_r, path)] in let do_call (prop, path) = - if Option.value_map - ~f:(fun summary -> is_some (reason_to_skip summary)) - ~default:true resolved_summary_opt + if + Option.value_map + ~f:(fun summary -> is_some (reason_to_skip summary)) + ~default:true resolved_summary_opt then let ret_annots = match resolved_summary_opt with @@ -1295,8 +1300,9 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p | Sil.Call (ret_id, 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 - if call_flags.CallFlags.cf_is_objc_block - && not (Rearrange.is_only_pt_by_fld_or_param_nonnull current_pdesc tenv prop_r fun_exp) + if + call_flags.CallFlags.cf_is_objc_block + && not (Rearrange.is_only_pt_by_fld_or_param_nonnull current_pdesc tenv prop_r fun_exp) then Rearrange.check_call_to_objc_block_error tenv current_pdesc prop_r fun_exp loc ; Rearrange.check_dereference_error tenv current_pdesc prop_r fun_exp loc ; if call_flags.CallFlags.cf_noreturn then ( @@ -1331,7 +1337,7 @@ let rec sym_exec exe_env tenv current_pdesc instr_ (prop_: Prop.normal Prop.t) p | Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false) eprop.Prop.sigma with - | [(Sil.Hpointsto (e, se, typ))], sigma' -> + | [Sil.Hpointsto (e, se, typ)], sigma' -> let sigma'' = let se' = execute_nullify_se se in Sil.Hpointsto (e, se', typ) :: sigma' @@ -1520,9 +1526,10 @@ and unknown_or_scan_call ~is_scan ~reason ret_type_option ret_annots | ObjC_Cpp cpp_name -> (* FIXME: we need to work around a frontend hack for std::shared_ptr * to silent some of the uninitialization warnings *) - if String.is_suffix ~suffix:"_std__shared_ptr" (Typ.Procname.to_string callee_pname) - (* Abduced parameters for the empty destructor body cause `Cannot star` *) - || Typ.Procname.ObjC_Cpp.is_destructor cpp_name + if + String.is_suffix ~suffix:"_std__shared_ptr" (Typ.Procname.to_string callee_pname) + (* Abduced parameters for the empty destructor body cause `Cannot star` *) + || Typ.Procname.ObjC_Cpp.is_destructor cpp_name then false else true | _ -> @@ -1849,9 +1856,10 @@ let node handle_exn exe_env tenv proc_cfg (node: ProcCfg.Exceptional.node) (pset 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 pset2 = - if Tabulation.prop_is_exn pname p && not (Sil.instr_is_auxiliary instr) - && ProcCfg.Exceptional.kind node <> Procdesc.Node.exn_handler_kind - (* skip normal instructions if an exception was thrown, + if + Tabulation.prop_is_exn pname p && not (Sil.instr_is_auxiliary instr) + && ProcCfg.Exceptional.kind node <> Procdesc.Node.exn_handler_kind + (* skip normal instructions if an exception was thrown, unless this is an exception handler node *) then ( L.d_str "Skipping instr " ; diff --git a/infer/src/biabduction/Tabulation.ml b/infer/src/biabduction/Tabulation.ml index ccc798eb6..7f690536a 100644 --- a/infer/src/biabduction/Tabulation.ml +++ b/infer/src/biabduction/Tabulation.ml @@ -141,7 +141,7 @@ let spec_find_rename trace_call summary : (int * Prop.exposed Specs.spec) list * (Localise.verbatim_desc (Typ.Procname.to_string proc_name), __POS__)) ) ; let formal_parameters = List.map ~f:(fun (x, _) -> Pvar.mk_callee x proc_name) formals in (List.map ~f specs, formal_parameters) - with Not_found -> + with Caml.Not_found -> L.d_strln ("ERROR: found no entry for procedure " ^ Typ.Procname.to_string proc_name ^ ". Give up...") ; raise @@ -190,8 +190,9 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ let map_var_to_pre_var_or_fresh id = match Sil.exp_sub (`Exp sub1_inverse) (Exp.Var id) with | Exp.Var id' -> - if Ident.HashQueue.mem fav_actual_pre id' || Ident.is_path id' - (* a path id represents a position in the pre *) + if + Ident.HashQueue.mem fav_actual_pre id' || Ident.is_path id' + (* a path id represents a position in the pre *) then Exp.Var id' else Exp.Var (Ident.create_fresh Ident.kprimed) | _ -> @@ -359,19 +360,20 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname))) | None -> assert false - else if (* Check if the dereferenced expr has the dangling uninitialized attribute. *) - (* In that case it raise a dangling pointer dereference *) - Attribute.has_dangling_uninit tenv spec_pre e + else if + (* Check if the dereferenced expr has the dangling uninitialized attribute. *) + (* In that case it raise a dangling pointer dereference *) + Attribute.has_dangling_uninit tenv spec_pre e then Some (Deref_undef_exp, desc false (Localise.deref_str_dangling (Some PredSymb.DAuninit))) else if Exp.equal e_sub Exp.minus_one then Some (Deref_minusone, desc true (Localise.deref_str_dangling None)) else match Attribute.get_resource tenv actual_pre e_sub with - | Some Apred (Aresource ({ra_kind= Rrelease} as ra), _) -> + | 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 (Apred (Aundef (s, _, loc, pos), _)) -> Some (Deref_undef (s, loc, pos), desc false (Localise.deref_str_undef (s, loc))) | _ -> None @@ -446,7 +448,7 @@ let post_process_post tenv caller_pname callee_pname loc actual_pre ((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}, _) -> + | Some (Apred (Aresource {ra_kind= Rrelease}, _)) -> true | _ -> false @@ -598,8 +600,8 @@ 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 sigma1 = List.stable_sort ~cmp:hpred_lhs_compare sigma1 in - let sigma2 = List.stable_sort ~cmp:hpred_lhs_compare sigma2 in + 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; *) let rec star sg1 sg2 : Sil.hpred list = match (sg1, sg2) with @@ -640,8 +642,8 @@ 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 typing_lhs_compare (e1, _) (e2, _) = Exp.compare e1 e2 in - let sigma1 = List.stable_sort ~cmp:hpred_lhs_compare sigma1 in - let typings2 = List.stable_sort ~cmp:typing_lhs_compare typings2 in + let sigma1 = List.stable_sort ~compare:hpred_lhs_compare sigma1 in + let typings2 = List.stable_sort ~compare:typing_lhs_compare typings2 in let rec star sg1 typ2 : Sil.hpred list = match (sg1, typ2) with | [], _ -> @@ -753,7 +755,7 @@ let prop_get_exn_name pname prop = let rec search_exn e = function | [] -> None - | (Sil.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}})) :: _ when Exp.equal e1 e -> + | Sil.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}}) :: _ when Exp.equal e1 e -> Some name | _ :: tl -> search_exn e tl @@ -761,7 +763,7 @@ let prop_get_exn_name pname prop = let rec find_exn_name hpreds = function | [] -> None - | (Sil.Hpointsto (e1, Sil.Eexp (Exp.Exn e2, _), _)) :: _ when Exp.equal e1 ret_pvar -> + | Sil.Hpointsto (e1, Sil.Eexp (Exp.Exn e2, _), _) :: _ when Exp.equal e1 ret_pvar -> search_exn e2 hpreds | _ :: tl -> find_exn_name hpreds tl @@ -775,7 +777,7 @@ let lookup_custom_errors prop = let rec search_error = function | [] -> None - | (Sil.Hpointsto (Exp.Lvar var, Sil.Eexp (Exp.Const Const.Cstr error_str, _), _)) :: _ + | Sil.Hpointsto (Exp.Lvar var, Sil.Eexp (Exp.Const (Const.Cstr error_str), _), _) :: _ when Pvar.equal var Sil.custom_error -> Some error_str | _ :: tl -> @@ -865,7 +867,7 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path let handle_null_case_analysis sigma = let id_assigned_to_null id = let filter = function - | Sil.Aeq (Exp.Var id', Exp.Const Const.Cint i) -> + | Sil.Aeq (Exp.Var id', Exp.Const (Const.Cint i)) -> Ident.equal id id' && IntLit.isnull i | _ -> false @@ -1341,15 +1343,16 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re let desc = if List.exists ~f:(function Cannot_combine -> true | _ -> false) invalid_res then call_desc (Some Localise.Pnm_dangling) - 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) - invalid_res + 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) + invalid_res then call_desc (Some Localise.Pnm_bounds) else call_desc None in @@ -1407,7 +1410,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re | _ -> false in - Config.idempotent_getters && Language.curr_language_is Java && is_likely_getter callee_pname + (Config.idempotent_getters && Language.curr_language_is Java && is_likely_getter callee_pname) || returns_nullable ret_annot in match ret_id with diff --git a/infer/src/biabduction/interproc.ml b/infer/src/biabduction/interproc.ml index 774c2104c..ed66a68a4 100644 --- a/infer/src/biabduction/interproc.ml +++ b/infer/src/biabduction/interproc.ml @@ -77,7 +77,7 @@ end = struct let create () : t = Hashtbl.create 11 - let find table i = try Hashtbl.find table i with Not_found -> Paths.PathSet.empty + let find table i = try Hashtbl.find table i with Caml.Not_found -> Paths.PathSet.empty let add table i dset = Hashtbl.replace table i dset end @@ -104,7 +104,7 @@ module Worklist = struct 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 Not_found -> 0 + try Procdesc.NodeMap.find node wl.visit_map with Caml.Not_found -> 0 in wl.todo_set <- NodeVisitSet.add {node; visits} wl.todo_set @@ -117,7 +117,7 @@ module Worklist = struct wl.visit_map <- Procdesc.NodeMap.add min.node (min.visits + 1) wl.visit_map ; (* increase the visits *) min.node - with Not_found -> + with Caml.Not_found -> L.internal_error "@\n...Work list is empty! Impossible to remove edge...@\n" ; assert false end @@ -133,7 +133,7 @@ let path_set_create_worklist proc_cfg = 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 Not_found -> + try Hashtbl.find htable key with Caml.Not_found -> Hashtbl.replace htable key Paths.PathSet.empty ; Paths.PathSet.empty @@ -164,7 +164,8 @@ let path_set_checkout_todo (wl: Worklist.t) (node: Procdesc.Node.t) : Paths.Path let new_visited = Paths.PathSet.union visited todo in Hashtbl.replace wl.Worklist.path_set_visited node_id new_visited ; todo - with Not_found -> L.die InternalError "could not find todo for node %a" Procdesc.Node.pp node + with Caml.Not_found -> + L.die InternalError "could not find todo for node %a" Procdesc.Node.pp node (* =============== END of the edge_set object =============== *) @@ -559,7 +560,7 @@ let compute_visited vset = let node_loc = Procdesc.Node.get_loc n in let instrs_loc = List.map ~f:Sil.instr_get_loc (ProcCfg.Exceptional.instrs n) in let lines = List.map ~f:(fun loc -> loc.Location.line) (node_loc :: instrs_loc) in - List.remove_consecutive_duplicates ~equal:Int.equal (List.sort ~cmp:Int.compare lines) + List.remove_consecutive_duplicates ~equal:Int.equal (List.sort ~compare:Int.compare lines) in let do_node n = res := Specs.Visitedset.add (Procdesc.Node.get_id n, node_get_all_lines n) !res @@ -604,7 +605,7 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list = let pre_post_map = let add map (pre, post, visited) = let current_posts, current_visited = - try Pmap.find pre map with Not_found -> (Paths.PathSet.empty, Specs.Visitedset.empty) + try Pmap.find pre map with Caml.Not_found -> (Paths.PathSet.empty, Specs.Visitedset.empty) in let new_posts = match post with @@ -1050,11 +1051,12 @@ let update_specs tenv prev_summary phase (new_specs: Specs.NormSpec.t list) in let re_exe_filter old_spec = (* filter out pres which failed re-exe *) - if Specs.equal_phase phase Specs.RE_EXECUTION - && not - (List.exists - ~f:(fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) - new_specs) + if + Specs.equal_phase phase Specs.RE_EXECUTION + && not + (List.exists + ~f:(fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) + new_specs) then ( changed := true ; current_specs := SpecMap.remove old_spec.Specs.pre !current_specs ) @@ -1070,21 +1072,21 @@ let update_specs tenv prev_summary phase (new_specs: Specs.NormSpec.t list) in if not (Paths.PathSet.equal old_post new_post) then ( changed := true ; - current_specs - := SpecMap.add spec.Specs.pre (new_post, new_visited) - (SpecMap.remove spec.Specs.pre !current_specs) ) - with Not_found -> + current_specs := + SpecMap.add spec.Specs.pre (new_post, new_visited) + (SpecMap.remove spec.Specs.pre !current_specs) ) + with Caml.Not_found -> changed := true ; - current_specs - := SpecMap.add spec.Specs.pre - (Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) !current_specs + current_specs := + SpecMap.add spec.Specs.pre + (Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) !current_specs in let res = ref [] in let convert pre (post_set, visited) = - res - := Specs.spec_normalize tenv - {Specs.pre; Specs.posts= Paths.PathSet.elements post_set; Specs.visited} - :: !res + res := + Specs.spec_normalize tenv + {Specs.pre; Specs.posts= Paths.PathSet.elements post_set; Specs.visited} + :: !res in List.iter ~f:re_exe_filter old_specs ; (* filter out pre's which failed re-exe *) diff --git a/infer/src/bufferoverrun/absLoc.ml b/infer/src/bufferoverrun/absLoc.ml index c33805ca5..8b269b5e3 100644 --- a/infer/src/bufferoverrun/absLoc.ml +++ b/infer/src/bufferoverrun/absLoc.ml @@ -24,11 +24,8 @@ module Allocsite = struct end module Loc = struct - type t = - | Var of Var.t - | Allocsite of Allocsite.t - | Field of t * Typ.Fieldname.t - [@@deriving compare] + type t = Var of Var.t | Allocsite of Allocsite.t | Field of t * Typ.Fieldname.t + [@@deriving compare] let equal = [%compare.equal : t] @@ -69,7 +66,7 @@ module Loc = struct let append_field l ~fn = Field (l, fn) let is_return = function - | Var Var.ProgramVar x -> + | Var (Var.ProgramVar x) -> Mangled.equal (Pvar.get_name x) Ident.name_return | _ -> false diff --git a/infer/src/bufferoverrun/arrayBlk.ml b/infer/src/bufferoverrun/arrayBlk.ml index e9a5d263c..7aa3af134 100644 --- a/infer/src/bufferoverrun/arrayBlk.ml +++ b/infer/src/bufferoverrun/arrayBlk.ml @@ -126,7 +126,7 @@ let diff : astate -> astate -> Itv.t = match find k arr1 with | a1 -> Itv.join acc (ArrInfo.diff a1 a2) - | exception Not_found -> + | exception Caml.Not_found -> Itv.top in fold diff_join arr2 Itv.bot diff --git a/infer/src/bufferoverrun/bufferOverrunChecker.ml b/infer/src/bufferoverrun/bufferOverrunChecker.ml index 3b46cd996..2f10471f4 100644 --- a/infer/src/bufferoverrun/bufferOverrunChecker.ml +++ b/infer/src/bufferoverrun/bufferOverrunChecker.ml @@ -248,7 +248,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct mem | Prune (exp, _, _, _) -> Sem.Prune.prune exp mem - | Call (ret, Const Cfun callee_pname, params, location, _) -> ( + | Call (ret, Const (Cfun callee_pname), params, location, _) -> ( match Models.Call.dispatch callee_pname params with | Some {Models.exec} -> let node_hash = CFG.hash node in @@ -358,12 +358,12 @@ module Report = struct | Sil.Prune (_, _, _, (Ik_land_lor | Ik_bexp)) -> () | Sil.Prune (cond, location, true_branch, _) -> - let i = match cond with Exp.Const Const.Cint i -> i | _ -> IntLit.zero in + let i = match cond with Exp.Const (Const.Cint i) -> i | _ -> IntLit.zero in let desc = Errdesc.explain_condition_always_true_false tenv i cond node location in let exn = Exceptions.Condition_always_true_false (desc, not true_branch, __POS__) in Reporting.log_warning summary ~loc:location exn (* special case for `exit` when we're at the end of a block / procedure *) - | Sil.Call (_, Const Cfun pname, _, _, _) + | Sil.Call (_, Const (Cfun pname), _, _, _) when String.equal (Typ.Procname.get_method pname) "exit" && ExitStatement.is_end_of_block_or_procedure node rem_instrs -> () @@ -451,7 +451,7 @@ module Report = struct match instr with | Sil.Load (_, exp, _, location) | Sil.Store (exp, _, _, location) -> check_expr pname exp location mem cond_set - | Sil.Call (_, Const Cfun callee_pname, params, location, _) -> ( + | Sil.Call (_, Const (Cfun callee_pname), params, location, _) -> ( match Models.Call.dispatch callee_pname params with | Some {Models.check} -> let node_hash = CFG.hash node in diff --git a/infer/src/bufferoverrun/bufferOverrunDomain.ml b/infer/src/bufferoverrun/bufferOverrunDomain.ml index 91f72bbef..6ef0e3c5d 100644 --- a/infer/src/bufferoverrun/bufferOverrunDomain.ml +++ b/infer/src/bufferoverrun/bufferOverrunDomain.ml @@ -59,7 +59,7 @@ module Val = struct && ArrayBlk.( <= ) ~lhs:lhs.arrayblk ~rhs:rhs.arrayblk - let equal x y = phys_equal x y || ( <= ) ~lhs:x ~rhs:y && ( <= ) ~lhs:y ~rhs:x + let equal x y = phys_equal x y || (( <= ) ~lhs:x ~rhs:y && ( <= ) ~lhs:y ~rhs:x) let widen ~prev ~next ~num_iters = if phys_equal prev next then prev @@ -222,8 +222,8 @@ module Val = struct let traces_caller = List.fold symbols ~f:(fun traces symbol -> - try TraceSet.join (Itv.SymbolMap.find symbol trace_map) traces with Not_found -> traces - ) + try TraceSet.join (Itv.SymbolMap.find symbol trace_map) traces with Caml.Not_found -> + traces ) ~init:TraceSet.empty in let traces = TraceSet.instantiate ~traces_caller ~traces_callee:x.traces location in @@ -263,7 +263,7 @@ module Stack = struct let bot = empty - let find : Loc.t -> astate -> Val.t = fun l m -> try find l m with Not_found -> Val.bot + let find : Loc.t -> astate -> Val.t = fun l m -> try find l m with Caml.Not_found -> Val.bot let find_set : PowLoc.t -> astate -> Val.t = fun locs mem -> @@ -289,7 +289,9 @@ module Heap = struct let bot = empty - let find : Loc.t -> astate -> Val.t = fun l m -> try find l m with Not_found -> Val.Itv.top + let find : Loc.t -> astate -> Val.t = + fun l m -> try find l m with Caml.Not_found -> Val.Itv.top + let find_set : PowLoc.t -> astate -> Val.t = fun locs mem -> @@ -363,7 +365,7 @@ module AliasMap = struct let ( <= ) : lhs:t -> rhs:t -> bool = fun ~lhs ~rhs -> let is_in_rhs k v = - match M.find k rhs with v' -> AliasTarget.equal v v' | exception Not_found -> false + match M.find k rhs with v' -> AliasTarget.equal v v' | exception Caml.Not_found -> false in M.for_all is_in_rhs lhs @@ -403,9 +405,7 @@ module AliasMap = struct fun l _ m -> M.filter (fun _ y -> not (AliasTarget.use l y)) m - let find : Ident.t -> t -> AliasTarget.t option = - fun k m -> try Some (M.find k m) with Not_found -> None - + let find : Ident.t -> t -> AliasTarget.t option = fun k m -> M.find_opt k m let remove_temps : Ident.t list -> t -> t = fun temps m -> @@ -514,7 +514,7 @@ module PrunePairs = struct type t = Loc.t * Val.t let equal ((l1, v1) as x) ((l2, v2) as y) = - phys_equal x y || Loc.equal l1 l2 && Val.equal v1 v2 + phys_equal x y || (Loc.equal l1 l2 && Val.equal v1 v2) end type t = PrunePair.t list @@ -651,9 +651,9 @@ module MemReach = struct let find_simple_alias : Ident.t -> t -> Loc.t option = fun k m -> match Alias.find k m.alias with - | Some AliasTarget.Simple l -> + | Some (AliasTarget.Simple l) -> Some l - | Some AliasTarget.Empty _ | None -> + | Some (AliasTarget.Empty _) | None -> None @@ -725,7 +725,7 @@ module MemReach = struct | LatestPrune.V (x, prunes, _), Exp.Var r | LatestPrune.V (x, _, prunes), Exp.UnOp (Unop.LNot, Exp.Var r, _) -> ( match find_simple_alias r m with - | Some Loc.Var Var.ProgramVar y when Pvar.equal x y -> + | Some (Loc.Var (Var.ProgramVar y)) when Pvar.equal x y -> List.fold_left prunes ~init:m ~f:(fun acc (l, v) -> update_mem (PowLoc.singleton l) v acc) | _ -> m ) @@ -736,7 +736,7 @@ module MemReach = struct let update_latest_prune : Exp.t -> Exp.t -> t -> t = fun e1 e2 m -> match (e1, e2, m.latest_prune) with - | Lvar x, Const Const.Cint i, LatestPrune.Latest p -> + | Lvar x, Const (Const.Cint i), LatestPrune.Latest p -> if IntLit.isone i then {m with latest_prune= LatestPrune.TrueBranch (x, p)} else if IntLit.iszero i then {m with latest_prune= LatestPrune.FalseBranch (x, p)} else {m with latest_prune= LatestPrune.Top} diff --git a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml index e196190bc..40a0e97ab 100644 --- a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml +++ b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml @@ -176,7 +176,7 @@ 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 = @@ -216,12 +216,14 @@ module ArrayAccessCondition = struct else if Itv.Boolean.is_false not_overrun || Itv.Boolean.is_false not_underrun then {report_issue_type= Some IssueType.buffer_overrun_l1; propagate= false} (* su <= iu < +oo, most probably an error *) - else if Itv.Bound.is_not_infty (ItvPure.ub c.idx) - && Itv.Bound.le (ItvPure.ub c.size) (ItvPure.ub c.idx) + else if + Itv.Bound.is_not_infty (ItvPure.ub c.idx) + && Itv.Bound.le (ItvPure.ub c.size) (ItvPure.ub c.idx) then {report_issue_type= Some IssueType.buffer_overrun_l2; propagate= false} (* symbolic il >= sl, probably an error *) - else if Itv.Bound.is_symbolic (ItvPure.lb c.idx) - && Itv.Bound.le (ItvPure.lb c'.size) (ItvPure.lb c.idx) + else if + Itv.Bound.is_symbolic (ItvPure.lb c.idx) + && Itv.Bound.le (ItvPure.lb c'.size) (ItvPure.lb c.idx) then {report_issue_type= Some IssueType.buffer_overrun_s2; propagate= true} else (* other symbolic bounds are probably too noisy *) @@ -312,14 +314,14 @@ module ConditionTrace = struct type cond_trace = | Intra of Typ.Procname.t | Inter of Typ.Procname.t * Typ.Procname.t * Location.t - [@@deriving compare] + [@@deriving compare] type t = { proc_name: Typ.Procname.t ; location: Location.t ; cond_trace: cond_trace ; val_traces: ValTraceSet.t } - [@@deriving compare] + [@@deriving compare] let pp_location : F.formatter -> t -> unit = fun fmt ct -> Location.pp_file_pos fmt ct.location @@ -453,7 +455,7 @@ module ConditionSet = struct match Itv.SymbolMap.find symbol trace_map with | symbol_trace -> ValTraceSet.join symbol_trace val_traces - | exception Not_found -> + | exception Caml.Not_found -> val_traces ) in let make_call_and_subst trace = @@ -467,10 +469,11 @@ module ConditionSet = struct let set_buffer_overrun_u5 cwt issue_type = - if ( IssueType.equal issue_type IssueType.buffer_overrun_l3 - || IssueType.equal issue_type IssueType.buffer_overrun_l4 - || IssueType.equal issue_type IssueType.buffer_overrun_l5 ) - && Condition.has_infty cwt.cond + if + ( IssueType.equal issue_type IssueType.buffer_overrun_l3 + || IssueType.equal issue_type IssueType.buffer_overrun_l4 + || IssueType.equal issue_type IssueType.buffer_overrun_l5 ) + && Condition.has_infty cwt.cond then Option.value (ConditionTrace.check cwt.trace) ~default:issue_type else issue_type diff --git a/infer/src/bufferoverrun/bufferOverrunSemantics.ml b/infer/src/bufferoverrun/bufferOverrunSemantics.ml index 5ef9b9608..74808a445 100644 --- a/infer/src/bufferoverrun/bufferOverrunSemantics.ml +++ b/infer/src/bufferoverrun/bufferOverrunSemantics.ml @@ -299,9 +299,9 @@ let rec eval_arr : Exp.t -> Mem.astate -> Val.t = match exp with | Exp.Var id -> ( match Mem.find_alias id mem with - | Some AliasTarget.Simple loc -> + | Some (AliasTarget.Simple loc) -> Mem.find_heap loc mem - | Some AliasTarget.Empty _ | None -> + | Some (AliasTarget.Empty _) | None -> Val.bot ) | Exp.Lvar pvar -> Mem.find_set (PowLoc.singleton (Loc.of_pvar pvar)) mem @@ -353,11 +353,11 @@ module Prune = struct match e with | Exp.Var x -> ( match Mem.find_alias x mem with - | Some AliasTarget.Simple lv -> + | Some (AliasTarget.Simple lv) -> let v = Mem.find_heap lv mem in let v' = Val.prune_ne_zero v in update_mem_in_prune lv v' astate - | Some AliasTarget.Empty lv -> + | Some (AliasTarget.Empty lv) -> let v = Mem.find_heap lv mem in let v' = Val.prune_eq_zero v in update_mem_in_prune lv v' astate @@ -365,11 +365,11 @@ module Prune = struct astate ) | Exp.UnOp (Unop.LNot, Exp.Var x, _) -> ( match Mem.find_alias x mem with - | Some AliasTarget.Simple lv -> + | Some (AliasTarget.Simple lv) -> let v = Mem.find_heap lv mem in let v' = Val.prune_eq_zero v in update_mem_in_prune lv v' astate - | Some AliasTarget.Empty lv -> + | Some (AliasTarget.Empty lv) -> let v = Mem.find_heap lv mem in let itv_v = Itv.prune_comp Binop.Ge (Val.get_itv v) Itv.one in let v' = Val.modify_itv itv_v v in @@ -442,9 +442,9 @@ module Prune = struct astate |> prune_unreachable e |> prune_unop e |> prune_binop_left e |> prune_binop_right e in match e with - | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i -> + | Exp.BinOp (Binop.Ne, e, Exp.Const (Const.Cint i)) when IntLit.iszero i -> prune_helper e astate - | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i -> + | Exp.BinOp (Binop.Eq, e, Exp.Const (Const.Cint i)) when IntLit.iszero i -> prune_helper (Exp.UnOp (Unop.LNot, e, None)) astate | Exp.UnOp (Unop.Neg, Exp.Var x, _) -> prune_helper (Exp.Var x) astate @@ -497,8 +497,9 @@ let get_matching_pairs let add_ret_alias v1 v2 = match callee_ret_alias with | Some ret_loc -> - if PowLoc.is_singleton v1 && PowLoc.is_singleton v2 - && AliasTarget.use (PowLoc.min_elt v1) ret_loc + if + PowLoc.is_singleton v1 && PowLoc.is_singleton v2 + && AliasTarget.use (PowLoc.min_elt v1) ret_loc then ret_alias := Some (AliasTarget.replace (PowLoc.min_elt v2) ret_loc) | None -> () diff --git a/infer/src/bufferoverrun/bufferOverrunTrace.ml b/infer/src/bufferoverrun/bufferOverrunTrace.ml index c5359ac2e..8c85d216e 100644 --- a/infer/src/bufferoverrun/bufferOverrunTrace.ml +++ b/infer/src/bufferoverrun/bufferOverrunTrace.ml @@ -20,7 +20,7 @@ module BoTrace = struct | Return of Location.t | SymAssign of Loc.t * Location.t | UnknownFrom of Typ.Procname.t * Location.t - [@@deriving compare] + [@@deriving compare] type t = {length: int; trace: elem list} [@@deriving compare] diff --git a/infer/src/bufferoverrun/itv.ml b/infer/src/bufferoverrun/itv.ml index 83d4e50b2..ce82095ff 100644 --- a/infer/src/bufferoverrun/itv.ml +++ b/infer/src/bufferoverrun/itv.ml @@ -175,7 +175,7 @@ module SymLinear = struct let le_one_pair s (v1_opt: NonZeroInt.t option) (v2_opt: NonZeroInt.t option) = let v1 = Option.value (v1_opt :> int option) ~default:0 in let v2 = Option.value (v2_opt :> int option) ~default:0 in - Int.equal v1 v2 || Symbol.is_unsigned s && v1 <= v2 + Int.equal v1 v2 || (Symbol.is_unsigned s && v1 <= v2) in M.for_all2 le_one_pair x y @@ -237,7 +237,7 @@ module SymLinear = struct | Some v, None -> Some (NonZeroInt.( * ) v c) | Some v1, Some v2 -> - NonZeroInt.of_int ((v1 :> int) * (c :> int) + (v2 :> int)) + NonZeroInt.of_int (((v1 :> int) * (c :> int)) + (v2 :> int)) in M.merge f se1 se2 @@ -321,7 +321,7 @@ module Bound = struct | Linear of int * SymLinear.t | MinMax of int * Sign.t * MinMax.t * int * Symbol.t | PInf - [@@deriving compare] + [@@deriving compare] type astate = t @@ -428,7 +428,7 @@ module Bound = struct let get_default = function SubstLowerBound -> MInf | SubstUpperBound -> PInf in let subst1_linears c1 se1 s c2 se2 = let coeff = SymLinear.find s se1 in - let c' = c1 + (coeff :> int) * c2 in + let c' = c1 + ((coeff :> int) * c2) in let se1 = SymLinear.remove s se1 in let se' = SymLinear.mult_const_plus se2 coeff se1 in Linear (c', se') @@ -571,10 +571,10 @@ module Bound = struct | MinMax (c1, Minus, Max, _, x1), MinMax (c2, Minus, Min, _, x2) -> c1 <= c2 && Symbol.equal x1 x2 | MinMax _, Linear (c, se) -> - SymLinear.is_ge_zero se && le_opt1 Int.( <= ) (int_ub_of_minmax x) c + (SymLinear.is_ge_zero se && le_opt1 Int.( <= ) (int_ub_of_minmax x) c) || le_opt1 le (linear_ub_of_minmax x) y | Linear (c, se), MinMax _ -> - SymLinear.is_le_zero se && le_opt2 Int.( <= ) c (int_lb_of_minmax y) + (SymLinear.is_le_zero se && le_opt2 Int.( <= ) c (int_lb_of_minmax y)) || le_opt2 le x (linear_lb_of_minmax y) | _, _ -> false diff --git a/infer/src/checkers/BoundedCallTree.ml b/infer/src/checkers/BoundedCallTree.ml index e4c70e43f..2883963d1 100644 --- a/infer/src/checkers/BoundedCallTree.ml +++ b/infer/src/checkers/BoundedCallTree.ml @@ -100,7 +100,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 get_proc_desc = proc_data.ProcData.extras.get_proc_desc in let traces = proc_data.ProcData.extras.stacktraces in diff --git a/infer/src/checkers/Litho.ml b/infer/src/checkers/Litho.ml index beb076d93..7f15fcfbf 100644 --- a/infer/src/checkers/Litho.ml +++ b/infer/src/checkers/Litho.ml @@ -204,7 +204,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match Var.get_footprint_index var with | Some footprint_index -> ( match List.nth actuals footprint_index with - | Some HilExp.AccessExpression actual_access_expr -> + | Some (HilExp.AccessExpression actual_access_expr) -> Some (Domain.LocalAccessPath.make (AccessExpression.to_access_path actual_access_expr) @@ -231,28 +231,30 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Call ( (Some return_base as ret_opt) , Direct (Typ.Procname.Java java_callee_procname as callee_procname) - , ((HilExp.AccessExpression receiver_ae) :: _ as actuals) + , (HilExp.AccessExpression receiver_ae :: _ as actuals) , _ , _ ) -> let summary = Summary.read_summary proc_data.pdesc callee_procname in let receiver = Domain.LocalAccessPath.make (AccessExpression.to_access_path receiver_ae) caller_pname in - if ( LithoFramework.is_component_builder callee_procname proc_data.tenv - (* track Builder's in order to check required prop's *) - || GraphQLGetters.is_function callee_procname summary - || (* 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 - ( LithoFramework.is_function callee_procname - && not (LithoFramework.is_function caller_pname) ) - (* don't track Litho client -> Litho framework calls; we want to use the summaries *) + if + ( LithoFramework.is_component_builder callee_procname proc_data.tenv + (* track Builder's in order to check required prop's *) + || GraphQLGetters.is_function callee_procname summary + || (* 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 + ( LithoFramework.is_function callee_procname + && not (LithoFramework.is_function caller_pname) ) + (* don't track Litho client -> Litho framework calls; we want to use the summaries *) then let return_access_path = Domain.LocalAccessPath.make (return_base, []) caller_pname in let return_calls = - (try Domain.find return_access_path astate with Not_found -> Domain.CallSet.empty) + ( try Domain.find return_access_path astate with Caml.Not_found -> Domain.CallSet.empty + ) |> Domain.CallSet.add (Domain.MethodCall.make receiver callee_procname) in Domain.add return_access_path return_calls astate @@ -276,7 +278,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct try let call_set = Domain.find rhs_access_path astate in Domain.remove rhs_access_path astate |> Domain.add lhs_access_path call_set - with Not_found -> astate ) + with Caml.Not_found -> astate ) | _ -> astate diff --git a/infer/src/checkers/LithoDomain.ml b/infer/src/checkers/LithoDomain.ml index 4082c63ba..d64d1b4a7 100644 --- a/infer/src/checkers/LithoDomain.ml +++ b/infer/src/checkers/LithoDomain.ml @@ -82,7 +82,7 @@ let iter_call_chains_with_suffix ~f call_suffix astate = if not (is_cycle call) then unroll_call_ call (acc', visited') else f receiver.access_path acc' ) calls' - with Not_found -> f receiver.access_path acc' + with Caml.Not_found -> f receiver.access_path acc' in unroll_call_ call_suffix ([], Typ.Procname.Set.empty) diff --git a/infer/src/checkers/NullabilityCheck.ml b/infer/src/checkers/NullabilityCheck.ml index 784fc3490..78953ab9d 100644 --- a/infer/src/checkers/NullabilityCheck.ml +++ b/infer/src/checkers/NullabilityCheck.ml @@ -111,7 +111,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let pname = Procdesc.get_proc_name pdesc in let annotation = Localise.nullable_annotation_name pname in let call_site = - try CallSites.min_elt call_sites with Not_found -> + try CallSites.min_elt call_sites with Caml.Not_found -> L.(die InternalError) "Expecting a least one element in the set of call sites when analyzing %a" Typ.Procname.pp pname @@ -209,13 +209,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct CallSites.fold (fun call_site s -> NullCheckedPname.add (CallSite.pname call_site) s) call_sites checked_pnames - with Not_found -> checked_pnames + with Caml.Not_found -> checked_pnames in (remove_call_sites ap aps, updated_pnames) let rec longest_nullable_prefix ap ((nullable_aps, _) as astate) = - try Some (ap, NullableAP.find ap nullable_aps) with Not_found -> + try Some (ap, NullableAP.find ap nullable_aps) with Caml.Not_found -> match ap with | _, [] -> None @@ -238,7 +238,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct astate | [arg] when HilExp.is_null_literal arg -> astate - | (HilExp.AccessExpression access_expr) :: other_args -> + | HilExp.AccessExpression access_expr :: other_args -> let ap = AccessExpression.to_access_path access_expr in check_nil_in_objc_container proc_data loc other_args (check_ap proc_data loc ap astate) | _ :: other_args -> @@ -265,7 +265,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct when NullCheckedPname.mem callee_pname checked_pnames -> (* Do not report nullable when the method has already been checked for null *) remove_nullable_ap (ret_var, []) astate - | Call (_, Direct callee_pname, (HilExp.AccessExpression receiver) :: _, _, _) + | Call (_, Direct callee_pname, HilExp.AccessExpression receiver :: _, _, _) when Models.is_check_not_null callee_pname -> assume_pnames_notnull (AccessExpression.to_access_path receiver) astate | Call (_, Direct callee_pname, _, _, _) when is_blacklisted_method callee_pname -> @@ -275,7 +275,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Annotations.ia_is_nullable -> let call_site = CallSite.make callee_pname loc in add_nullable_ap (ret_var, []) (CallSites.singleton call_site) astate - | Call (_, Direct callee_pname, (HilExp.AccessExpression receiver) :: _, _, loc) + | Call (_, Direct callee_pname, HilExp.AccessExpression receiver :: _, _, loc) when is_non_objc_instance_method callee_pname -> check_ap proc_data loc (AccessExpression.to_access_path receiver) astate | Call (_, Direct callee_pname, args, _, loc) when is_objc_container_add_method callee_pname -> @@ -283,7 +283,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Call ( Some ((_, ret_typ) as ret_var) , Direct callee_pname - , (HilExp.AccessExpression receiver) :: _ + , HilExp.AccessExpression receiver :: _ , _ , _ ) when Typ.is_pointer ret_typ && is_objc_instance_method callee_pname -> ( @@ -311,7 +311,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct (* Add the lhs to the list of nullable values if the rhs is nullable *) let ap = AccessExpression.to_access_path access_expr in add_nullable_ap lhs (find_nullable_ap ap astate) astate - with Not_found -> + with Caml.Not_found -> (* Remove the lhs from the list of nullable values if the rhs is not nullable *) remove_nullable_ap lhs astate ) | _ -> diff --git a/infer/src/checkers/NullabilityPreanalysis.ml b/infer/src/checkers/NullabilityPreanalysis.ml index f0ce2d7e6..39ae0e7b0 100644 --- a/infer/src/checkers/NullabilityPreanalysis.ml +++ b/infer/src/checkers/NullabilityPreanalysis.ml @@ -31,14 +31,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct try let exp = Ident.Hash.find ids_map id in Exp.is_null_literal exp - with Not_found -> false ) + with Caml.Not_found -> false ) | _ -> Exp.is_null_literal exp let is_self ids_map id = try match Ident.Hash.find ids_map id with Exp.Lvar var -> Pvar.is_self var | _ -> false - with Not_found -> false + with Caml.Not_found -> false let exec_instr astate (proc_data: Exp.t Ident.Hash.t ProcData.t) _ instr = diff --git a/infer/src/checkers/NullabilitySuggest.ml b/infer/src/checkers/NullabilitySuggest.ml index dbaa4505a..49b450311 100644 --- a/infer/src/checkers/NullabilitySuggest.ml +++ b/infer/src/checkers/NullabilitySuggest.ml @@ -16,7 +16,7 @@ module UseDefChain = struct | DependsOn of (Location.t * AccessPath.t) | NullDefCompare of (Location.t * AccessPath.t) | NullDefAssign of (Location.t * AccessPath.t) - [@@deriving compare] + [@@deriving compare] let ( <= ) ~lhs ~rhs = compare_astate lhs rhs <= 0 @@ -62,7 +62,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let nullable_usedef_chain_of exp lhs astate loc = match exp with - | HilExp.Constant Cint n when IntLit.isnull n -> + | HilExp.Constant (Cint n) when IntLit.isnull n -> Some (UseDefChain.NullDefAssign (loc, lhs)) | HilExp.AccessExpression access_expr -> ( try @@ -75,7 +75,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct None | _ -> Some (UseDefChain.DependsOn (loc, ap)) - with Not_found -> None ) + with Caml.Not_found -> None ) | _ -> None @@ -119,9 +119,9 @@ module Analyzer = LowerHil.MakeAbstractInterpreter (ProcCfg.Exceptional) (Transf let make_error_trace astate ap ud = let name_of ap = match AccessPath.get_last_access ap with - | Some AccessPath.FieldAccess field_name -> + | Some (AccessPath.FieldAccess field_name) -> "Field " ^ Typ.Fieldname.to_flat_string field_name - | Some AccessPath.ArrayAccess _ -> + | Some (AccessPath.ArrayAccess _) -> "Some array element" | None -> "Variable" @@ -138,7 +138,7 @@ let make_error_trace astate ap ud = Some (loc, ltr) | DependsOn (loc, dep) -> match Domain.find dep astate with - | exception Not_found -> + | exception Caml.Not_found -> None | ud' when Set.mem ud' seen -> None diff --git a/infer/src/checkers/Ownership.ml b/infer/src/checkers/Ownership.ml index 00e0b20b0..c83ac4f63 100644 --- a/infer/src/checkers/Ownership.ml +++ b/infer/src/checkers/Ownership.ml @@ -123,13 +123,13 @@ module Domain = struct (* TODO: can do deeper checking here, but have to worry about borrow cycles *) | Owned -> () - | exception Not_found -> + | exception Caml.Not_found -> () in VarSet.iter report_invalidated borrowed_vars | Owned -> () - | exception Not_found -> + | exception Caml.Not_found -> () @@ -169,7 +169,7 @@ module Domain = struct if Var.is_return (fst lhs_base) then exp_add_reads rhs_exp loc summary astate else match rhs_exp with - | HilExp.AccessExpression (Base rhs_base | AddressOf Base rhs_base) + | HilExp.AccessExpression (Base rhs_base | AddressOf (Base rhs_base)) when not (Var.appears_in_source_code (fst rhs_base)) -> ( try (* assume assignments with non-source vars on the RHS transfer capabilities to the LHS @@ -177,7 +177,7 @@ module Domain = struct (* copy capability from RHS to LHS *) let base_capability = find rhs_base astate in add lhs_base base_capability astate - with Not_found -> + with Caml.Not_found -> (* no existing capability on RHS. don't make any assumptions about LHS capability *) remove lhs_base astate ) | HilExp.Closure (_, captured_vars) -> @@ -237,7 +237,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Some astate' else if Typ.Procname.equal pname BuiltinDecl.__placement_new then match (List.rev actuals, return_opt) with - | (HilExp.AccessExpression Base placement_base) :: other_actuals, Some return_base -> + | HilExp.AccessExpression (Base placement_base) :: other_actuals, Some return_base -> (* placement new creates an alias between return var and placement var. model as return borrowing from placement *) Domain.actuals_add_reads other_actuals loc summary astate @@ -251,7 +251,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Typ.Procname.pp pname Location.pp loc else if Typ.Procname.is_constructor pname then match actuals with - | (HilExp.AccessExpression AccessExpression.AddressOf access_expression) :: other_actuals + | HilExp.AccessExpression (AccessExpression.AddressOf access_expression) :: other_actuals -> ( match get_assigned_base access_expression with | Some constructed_base -> @@ -300,17 +300,17 @@ module TransferFunctions (CFG : ProcCfg.S) = struct |> Domain.access_path_add_read (AccessExpression.to_access_path lhs_access_exp) loc summary ) - | Call (_, Direct callee_pname, [(AccessExpression Base lhs_base)], _, loc) + | Call (_, Direct callee_pname, [AccessExpression (Base lhs_base)], _, loc) when Typ.Procname.equal callee_pname BuiltinDecl.__delete -> (* TODO: support delete[], free, and (in some cases) std::move *) Domain.release_ownership lhs_base loc summary astate - | Call (_, Direct callee_pname, [(AccessExpression AddressOf Base lhs_base)], _, loc) + | Call (_, Direct callee_pname, [AccessExpression (AddressOf (Base lhs_base))], _, loc) when is_destructor callee_pname -> Domain.release_ownership lhs_base loc summary astate | Call ( _ - , Direct Typ.Procname.ObjC_Cpp callee_pname - , [(AccessExpression AddressOf Base lhs_base); rhs_exp] + , Direct (Typ.Procname.ObjC_Cpp callee_pname) + , [AccessExpression (AddressOf (Base lhs_base)); rhs_exp] , _ , loc ) when Typ.Procname.ObjC_Cpp.is_operator_equal callee_pname -> @@ -319,8 +319,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Domain.handle_var_assign lhs_base rhs_exp loc summary astate | Call ( _ - , Direct Typ.Procname.ObjC_Cpp callee_pname - , (AccessExpression AddressOf Base lhs_base) :: _ + , Direct (Typ.Procname.ObjC_Cpp callee_pname) + , AccessExpression (AddressOf (Base lhs_base)) :: _ , _ , loc ) when Typ.Procname.ObjC_Cpp.is_cpp_lambda callee_pname -> diff --git a/infer/src/checkers/Siof.ml b/infer/src/checkers/Siof.ml index 7046de8ee..98da20c57 100644 --- a/infer/src/checkers/Siof.ml +++ b/infer/src/checkers/Siof.ml @@ -127,22 +127,23 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match instr with | Load (_, exp, _, loc) | Store (_, _, exp, loc) | Prune (exp, loc, _, _) -> get_globals pdesc exp |> add_globals astate loc - | Call (_, Const Cfun callee_pname, _, _, _) when is_whitelisted callee_pname -> + | Call (_, Const (Cfun callee_pname), _, _, _) when is_whitelisted callee_pname -> at_least_nonbottom astate - | Call (_, Const Cfun callee_pname, _, _, _) when is_modelled callee_pname -> + | Call (_, Const (Cfun callee_pname), _, _, _) when is_modelled callee_pname -> let init = List.find_map_exn models ~f:(fun {qual_name; initialized_globals} -> - if QualifiedCppName.Match.of_fuzzy_qual_names [qual_name] - |> Fn.flip QualifiedCppName.Match.match_qualifiers - (Typ.Procname.get_qualifiers callee_pname) + if + QualifiedCppName.Match.of_fuzzy_qual_names [qual_name] + |> Fn.flip QualifiedCppName.Match.match_qualifiers + (Typ.Procname.get_qualifiers callee_pname) then Some initialized_globals else None ) 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, _) + | 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 -> add_actuals_globals astate pdesc loc actuals_without_self - | Call (_, Const Cfun callee_pname, actuals, loc, _) -> + | Call (_, Const (Cfun callee_pname), actuals, loc, _) -> let callee_astate = match Summary.read_summary pdesc callee_pname with | Some (NonBottom trace, initialized_by_callee) -> @@ -271,11 +272,12 @@ let checker {Callbacks.proc_desc; tenv; summary; get_procs_in_file} : Specs.summ to figure this out when analyzing the function, but we might as well use the user's specification if it's given to us. This also serves as an optimization as this skips the analysis of the function. *) - if match pname with - | ObjC_Cpp cpp_pname -> - Typ.Procname.ObjC_Cpp.is_constexpr cpp_pname - | _ -> - false + if + match pname with + | ObjC_Cpp cpp_pname -> + Typ.Procname.ObjC_Cpp.is_constexpr cpp_pname + | _ -> + false then Summary.update_summary initial summary else match Analyzer.compute_post proc_data ~initial with diff --git a/infer/src/checkers/Trace.ml b/infer/src/checkers/Trace.ml index 34df7b77d..d63fb2c9b 100644 --- a/infer/src/checkers/Trace.ml +++ b/infer/src/checkers/Trace.ml @@ -422,7 +422,7 @@ module Make (Spec : Spec) = struct (* sort passthroughs by ascending line number to create a coherent trace *) let sorted_passthroughs = List.sort - ~cmp:(fun passthrough1 passthrough2 -> + ~compare:(fun passthrough1 passthrough2 -> let loc1 = CallSite.loc (Passthrough.site passthrough1) in let loc2 = CallSite.loc (Passthrough.site passthrough2) in Int.compare loc1.Location.line loc2.Location.line ) diff --git a/infer/src/checkers/accessTree.ml b/infer/src/checkers/accessTree.ml index 372086a81..ac0bdc231 100644 --- a/infer/src/checkers/accessTree.ml +++ b/infer/src/checkers/accessTree.ml @@ -94,7 +94,8 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct module BaseMap = AccessPath.BaseMap type node = (TraceDomain.astate * tree) - and tree = Subtree of node AccessMap.t | Star + + and tree = Subtree of node AccessMap.t | Star type t = node BaseMap.t @@ -173,7 +174,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct (* input query was [ap]*, and [trace] is the trace associated with [ap]. get the traces associated with the children of [ap] in [tree] and join them with [trace] *) Some (join_all_traces trace subtree, subtree) - | exception Not_found -> + | exception Caml.Not_found -> None @@ -191,7 +192,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct try let rhs_v = AccessMap.find k rhs_subtree in access_tree_lteq lhs_v rhs_v - with Not_found -> false ) + with Caml.Not_found -> false ) lhs_subtree | _, Star -> true @@ -207,7 +208,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct try let rhs_v = BaseMap.find k rhs in access_tree_lteq lhs_v rhs_v - with Not_found -> false ) + with Caml.Not_found -> false ) lhs @@ -298,7 +299,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct access_tree_add_trace_ ~seen_array_access accesses empty_starred_leaf depth' else let access_node = - try AccessMap.find access subtree with Not_found -> empty_normal_leaf + try AccessMap.find access subtree with Caml.Not_found -> empty_normal_leaf in (* once we encounter a subtree rooted in an array access, we have to do weak updates in the entire subtree. the reason: if I do x[i].f.g = , then @@ -327,7 +328,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct let base, accesses = AccessPath.Abs.extract ap in let is_exact = AccessPath.Abs.is_exact ap in let base_node = - try BaseMap.find base tree with Not_found -> + try BaseMap.find base tree with Caml.Not_found -> (* note: we interpret max_depth <= 0 as max_depth = 1 *) if Config.max_depth > 1 then empty_normal_leaf else empty_starred_leaf in diff --git a/infer/src/checkers/annotationReachability.ml b/infer/src/checkers/annotationReachability.ml index 0231b575e..7c3fa6271 100644 --- a/infer/src/checkers/annotationReachability.ml +++ b/infer/src/checkers/annotationReachability.ml @@ -26,7 +26,7 @@ module Domain = struct astate | NonBottom _ -> let sink_map = - try AnnotReachabilityDomain.find annot annot_map with Not_found -> + try AnnotReachabilityDomain.find annot annot_map with Caml.Not_found -> AnnotReachabilityDomain.SinkMap.empty in let sink_map' = @@ -121,7 +121,7 @@ let method_overrides_annot annot tenv pname = method_overrides (method_has_annot let lookup_annotation_calls ~caller_pdesc annot pname = match Ondemand.analyze_proc_name ~caller_pdesc pname with | Some {Specs.payload= {Specs.annot_map= Some annot_map}} -> ( - try AnnotReachabilityDomain.find annot annot_map with Not_found -> + try AnnotReachabilityDomain.find annot annot_map with Caml.Not_found -> AnnotReachabilityDomain.SinkMap.empty ) | _ -> AnnotReachabilityDomain.SinkMap.empty @@ -197,7 +197,7 @@ let report_call_stack summary end_of_stack lookup_next_calls report call_site si let loc = CallSite.loc call_site in if Typ.Procname.Set.mem p visited then accu else ((p, loc) :: unseen, Typ.Procname.Set.add p visited) - with Not_found -> accu ) + with Caml.Not_found -> accu ) next_calls ([], visited_pnames) in List.iter ~f:(loop fst_call_loc updated_callees (new_trace, new_stack_str)) unseen_callees @@ -210,7 +210,7 @@ let report_call_stack summary end_of_stack lookup_next_calls report call_site si let fst_call_loc = CallSite.loc fst_call_site in let start_trace = update_trace (CallSite.loc call_site) [] in loop fst_call_loc Typ.Procname.Set.empty (start_trace, "") (fst_callee_pname, fst_call_loc) - with Not_found -> () ) + with Caml.Not_found -> () ) sink_map @@ -228,7 +228,7 @@ let report_src_snk_paths proc_data annot_map src_annot_list snk_annot = try let sink_map = AnnotReachabilityDomain.find snk_annot annot_map in List.iter ~f:(report_src_snk_path proc_data sink_map snk_annot) src_annot_list - with Not_found -> () + with Caml.Not_found -> () (* New implementation starts here *) @@ -398,8 +398,8 @@ 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) -> - if spec.sink_predicate tenv callee_pname - && not (spec.sanitizer_predicate tenv caller_pname) + 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 else astate ) annot_specs @@ -421,9 +421,9 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let exec_instr astate {ProcData.pdesc; tenv} _ = function - | Sil.Call (Some (id, _), Const Cfun callee_pname, _, _, _) when is_unlikely callee_pname -> + | Sil.Call (Some (id, _), Const (Cfun callee_pname), _, _, _) when is_unlikely callee_pname -> Domain.add_tracking_var (Var.of_id id) astate - | Sil.Call (_, Const Cfun callee_pname, _, call_loc, _) -> + | Sil.Call (_, Const (Cfun callee_pname), _, call_loc, _) -> let caller_pname = Procdesc.get_proc_name pdesc in let call_site = CallSite.make callee_pname call_loc in check_call tenv callee_pname caller_pname call_site astate diff --git a/infer/src/checkers/cost.ml b/infer/src/checkers/cost.ml index 935d19352..22324f84c 100644 --- a/infer/src/checkers/cost.ml +++ b/infer/src/checkers/cost.ml @@ -71,7 +71,7 @@ module TransferFunctionsNodesBasicCost (CFG : ProcCfg.S) = struct let key = (nid_int, ProcCfg.Instr_index instr_idx) in let astate' = match instr with - | Sil.Call (_, Exp.Const Const.Cfun callee_pname, _, _, _) -> ( + | Sil.Call (_, Exp.Const (Const.Cfun callee_pname), _, _, _) -> ( match Summary.read_summary pdesc callee_pname with | Some {post= cost_callee} -> CostDomain.NodeInstructionToCostMap.add key cost_callee astate @@ -134,10 +134,10 @@ module BoundMap = struct BufferOverrunDomain.Heap.fold (fun loc data acc -> match loc with - | AbsLoc.Loc.Var Var.LogicalVar id -> + | AbsLoc.Loc.Var (Var.LogicalVar id) -> let key = Exp.Var id in CostDomain.EnvDomain.add key (BufferOverrunDomain.Val.get_itv data) acc - | AbsLoc.Loc.Var Var.ProgramVar v -> + | AbsLoc.Loc.Var (Var.ProgramVar v) -> let key = Exp.Lvar v in CostDomain.EnvDomain.add key (BufferOverrunDomain.Val.get_itv data) acc | _ -> @@ -459,8 +459,8 @@ module TransferFunctionsWCET (CFG : ProcCfg.S) = struct let mk_message () = F.asprintf "The execution time from the beginning of the function up to this program point is likely \ - above the acceptable threshold of %a (estimated cost %a)" Itv.Bound.pp expensive_threshold - Itv.Bound.pp cost + above the acceptable threshold of %a (estimated cost %a)" + Itv.Bound.pp expensive_threshold Itv.Bound.pp cost in match cost with | b when Itv.Bound.is_not_infty b diff --git a/infer/src/checkers/dataflow.ml b/infer/src/checkers/dataflow.ml index 2c4afee6c..c42cdd42c 100644 --- a/infer/src/checkers/dataflow.ml +++ b/infer/src/checkers/dataflow.ml @@ -57,9 +57,10 @@ let node_throws pdesc node (proc_throws: Typ.Procname.t -> throws) : throws = | Sil.Store (Exp.Lvar pvar, _, Exp.Exn _, _) when is_return pvar -> (* assignment to return variable is an artifact of a throw instruction *) Throws - | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) when BuiltinDecl.is_declared callee_pn -> + | Sil.Call (_, Exp.Const (Const.Cfun callee_pn), _, _, _) + when BuiltinDecl.is_declared callee_pn -> if Typ.Procname.equal callee_pn BuiltinDecl.__cast then DontKnow else DoesNotThrow - | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) -> + | Sil.Call (_, Exp.Const (Const.Cfun callee_pn), _, _, _) -> proc_throws callee_pn | _ -> DoesNotThrow @@ -114,7 +115,7 @@ module MakeDF (St : DFStateType) : DF with type state = St.t = struct let dest_state = H.find t.pre_states dest_node in let dest_joined = St.join dest_state new_state in if not (St.equal dest_state dest_joined) then push_state dest_joined - with Not_found -> push_state new_state + with Caml.Not_found -> push_state new_state in let succ_nodes = Procdesc.Node.get_succs node in let exn_nodes = Procdesc.Node.get_exn node in @@ -149,12 +150,12 @@ module MakeDF (St : DFStateType) : DF with type state = St.t = struct let state = H.find t.pre_states node in let states_succ, states_exn = St.do_node tenv node state in propagate t node states_succ states_exn (node_throws proc_desc node St.proc_throws) - with Not_found -> () + with Caml.Not_found -> () done in let transitions node = try Transition (H.find t.pre_states node, H.find t.post_states node, H.find t.exn_states node) - with Not_found -> Dead_state + with Caml.Not_found -> Dead_state in transitions end diff --git a/infer/src/checkers/idenv.ml b/infer/src/checkers/idenv.ml index 240f024f4..cfeb733ec 100644 --- a/infer/src/checkers/idenv.ml +++ b/infer/src/checkers/idenv.ml @@ -29,7 +29,7 @@ let create proc_desc = let lookup map_ id = let map = Lazy.force map_ in - try Some (Ident.Hash.find map id) with Not_found -> None + Ident.Hash.find_opt map id let expand_expr idenv e = diff --git a/infer/src/checkers/liveness.ml b/infer/src/checkers/liveness.ml index 5a9a3fee1..ee81e4176 100644 --- a/infer/src/checkers/liveness.ml +++ b/infer/src/checkers/liveness.ml @@ -40,7 +40,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct List.fold exps ~f:(fun acc_ (exp, _) -> exp_add_live exp acc_) ~init:acc in match call_exp with - | Exp.Const Cfun (Typ.Procname.ObjC_Cpp _ as pname) when Typ.Procname.is_constructor pname -> ( + | 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 @@ -141,9 +141,9 @@ let checker {Callbacks.tenv; summary; proc_desc} : Specs.summary = that create an intentional dead store as an attempt to imitate default value semantics. use dead stores to a "sentinel" value as a heuristic for ignoring this case *) let is_sentinel_exp = function - | Exp.Const Cint i -> + | Exp.Const (Cint i) -> IntLit.iszero i || IntLit.isnull i - | Exp.Const Cfloat 0.0 -> + | Exp.Const (Cfloat 0.0) -> true | _ -> false @@ -177,7 +177,11 @@ let checker {Callbacks.tenv; summary; proc_desc} : Specs.summary = when should_report pvar typ live_vars captured_by_ref_vars && not (is_sentinel_exp rhs_exp) -> log_report pvar typ loc | Sil.Call - (None, Exp.Const Cfun (Typ.Procname.ObjC_Cpp _ as pname), (Exp.Lvar pvar, typ) :: _, loc, _) + ( None + , Exp.Const (Cfun (Typ.Procname.ObjC_Cpp _ as pname)) + , (Exp.Lvar pvar, typ) :: _ + , loc + , _ ) when Typ.Procname.is_constructor pname && should_report pvar typ live_vars captured_by_ref_vars -> log_report pvar typ loc diff --git a/infer/src/checkers/printfArgs.ml b/infer/src/checkers/printfArgs.ml index c7a6462c5..73d17f04d 100644 --- a/infer/src/checkers/printfArgs.ml +++ b/infer/src/checkers/printfArgs.ml @@ -81,7 +81,7 @@ 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, _ -> + | Exp.Const (Const.Cstr fmt), _ -> Some fmt | _ -> None @@ -102,7 +102,7 @@ let rec format_string_type_names (fmt_string: string) (start: int) : string list let fmt_match = Str.matched_string fmt_string in let fmt_type = String.sub fmt_match ~pos:(String.length fmt_match - 1) ~len:1 in fmt_type :: format_string_type_names fmt_string (Str.match_end ()) - with Not_found -> [] + with Caml.Not_found -> [] let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) @@ -139,30 +139,30 @@ let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) (* Get the array ivar for a given nvar *) let rec array_ivar instrs nvar = match (instrs, nvar) with - | (Sil.Load (id, Exp.Lvar iv, _, _)) :: _, Exp.Var nid when Ident.equal id nid -> + | Sil.Load (id, Exp.Lvar iv, _, _) :: _, Exp.Var nid when Ident.equal id nid -> iv | _ :: is, _ -> array_ivar is nvar | _ -> - raise Not_found + raise Caml.Not_found in let rec fixed_nvar_type_name instrs nvar = match nvar with | Exp.Var nid -> ( match instrs with - | (Sil.Load (id, Exp.Lvar _, t, _)) :: _ when Ident.equal id nid -> + | Sil.Load (id, Exp.Lvar _, t, _) :: _ when Ident.equal id nid -> PatternMatch.get_type_name t | _ :: is -> fixed_nvar_type_name is nvar | _ -> - raise Not_found ) + raise Caml.Not_found ) | Exp.Const c -> PatternMatch.java_get_const_type_name c | _ -> L.(die InternalError) "Could not resolve fixed type name" in match instr with - | Sil.Call (_, Exp.Const Const.Cfun pn, args, cl, _) -> ( + | Sil.Call (_, Exp.Const (Const.Cfun pn), args, cl, _) -> ( match printf_like_function pn with | Some printf -> ( try diff --git a/infer/src/checkers/uninit.ml b/infer/src/checkers/uninit.ml index 33bbb1df7..2c2558c39 100644 --- a/infer/src/checkers/uninit.ml +++ b/infer/src/checkers/uninit.ml @@ -98,8 +98,9 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match e with | HilExp.AccessExpression access_expr -> let (var, t), al = AccessExpression.to_access_path access_expr in - if should_report_var pdesc tenv uninit_vars ((var, t), al) && not (Typ.is_pointer t) - && not (is_struct_field_passed_by_ref call t al idx) + if + should_report_var pdesc tenv uninit_vars ((var, t), al) && not (Typ.is_pointer t) + && not (is_struct_field_passed_by_ref call t al idx) then report_intra ((var, t), al) loc (snd extras) else () | _ -> @@ -174,9 +175,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct None | Some (fparam, t) -> let var_fparam = Var.of_pvar (Pvar.mk fparam callee_pname) in - if D.exists - (fun (base, _) -> AccessPath.equal_base base (var_fparam, t)) - init_formal_params + if + D.exists (fun (base, _) -> AccessPath.equal_base base (var_fparam, t)) init_formal_params then Some var_fparam else None @@ -207,8 +207,9 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let exec_instr (astate: Domain.astate) {ProcData.pdesc; ProcData.extras; ProcData.tenv} _ (instr: HilInstr.t) = let update_prepost (((_, lhs_typ), apl) as lhs_ap) rhs = - if FormalMap.is_formal (fst lhs_ap) (fst extras) && Typ.is_pointer lhs_typ - && (not (is_pointer_assignment tenv lhs_ap rhs) || List.length apl > 0) + if + FormalMap.is_formal (fst lhs_ap) (fst extras) && Typ.is_pointer lhs_typ + && (not (is_pointer_assignment tenv lhs_ap rhs) || List.length apl > 0) then let pre' = D.add lhs_ap (fst astate.prepost) in let post = snd astate.prepost in @@ -241,7 +242,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | Call (_, Direct callee_pname, _, _, _) when Typ.Procname.equal callee_pname BuiltinDecl.objc_cpp_throw -> {astate with uninit_vars= D.empty} - | Call (_, HilInstr.Direct call, [(HilExp.AccessExpression AddressOf Base base)], _, _) + | Call (_, HilInstr.Direct call, [HilExp.AccessExpression (AddressOf (Base base))], _, _) when is_dummy_constructor_of_a_struct call -> (* if it's a default constructor, we use the following heuristic: we assume that it initializes correctly all fields when there is an implementation of the constructor that initilizes at least one diff --git a/infer/src/clang/ALVar.ml b/infer/src/clang/ALVar.ml index d36fcd27e..90c2aa58a 100644 --- a/infer/src/clang/ALVar.ml +++ b/infer/src/clang/ALVar.ml @@ -18,12 +18,8 @@ type cached_regexp = {string: string; regexp: Str.regexp Lazy.t} let compare_cached_regexp {string= s1} {string= s2} = String.compare s1 s2 -type alexp = - | Const of string - | Regexp of cached_regexp - | Var of string - | FId of formula_id - [@@deriving compare] +type alexp = Const of string | Regexp of cached_regexp | Var of string | FId of formula_id +[@@deriving compare] type t = alexp [@@deriving compare] @@ -32,7 +28,7 @@ let equal = [%compare.equal : t] let formula_id_to_string fid = match fid with Formula_id s -> s let alexp_to_string = function - | Const string | Regexp {string} | Var string | FId Formula_id string -> + | Const string | Regexp {string} | Var string | FId (Formula_id string) -> string @@ -70,7 +66,7 @@ let is_name_keyword k = match k with Name -> true | _ -> false (** true if and only if a substring of container matches the regular expression *) let str_match_forward container regexp = - try Str.search_forward regexp container 0 >= 0 with Not_found -> false + try Str.search_forward regexp container 0 >= 0 with Caml.Not_found -> false let compare_str_with_alexp s ae = diff --git a/infer/src/clang/ALVar.mli b/infer/src/clang/ALVar.mli index 7dd57a919..6cb4d501a 100644 --- a/infer/src/clang/ALVar.mli +++ b/infer/src/clang/ALVar.mli @@ -16,12 +16,8 @@ type formula_id = Formula_id of string [@@deriving compare] (** a regexp and its cached compiled version *) type cached_regexp = {string: string; regexp: Str.regexp Lazy.t} [@@deriving compare] -type alexp = - | Const of string - | Regexp of cached_regexp - | Var of string - | FId of formula_id - [@@deriving compare] +type alexp = Const of string | Regexp of cached_regexp | Var of string | FId of formula_id +[@@deriving compare] type t = alexp diff --git a/infer/src/clang/CProcname.ml b/infer/src/clang/CProcname.ml index 3c8113454..aa5e658fe 100644 --- a/infer/src/clang/CProcname.ml +++ b/infer/src/clang/CProcname.ml @@ -104,19 +104,19 @@ let mk_cpp_method ?tenv class_name method_name ?meth_decl mangled = let open Clang_ast_t in let method_kind = match meth_decl with - | Some Clang_ast_t.CXXConstructorDecl (_, _, _, _, {xmdi_is_constexpr}) -> + | Some (Clang_ast_t.CXXConstructorDecl (_, _, _, _, {xmdi_is_constexpr})) -> Typ.Procname.ObjC_Cpp.CPPConstructor {mangled; is_constexpr= xmdi_is_constexpr} - | Some Clang_ast_t.CXXDestructorDecl _ -> + | Some (Clang_ast_t.CXXDestructorDecl _) -> Typ.Procname.ObjC_Cpp.CPPDestructor {mangled} | _ -> Typ.Procname.ObjC_Cpp.CPPMethod {mangled} in let template_info, is_generic_model = match meth_decl with - | Some CXXMethodDecl (di, _, _, fdi, _) - | Some CXXConstructorDecl (di, _, _, fdi, _) - | Some CXXConversionDecl (di, _, _, fdi, _) - | Some CXXDestructorDecl (di, _, _, fdi, _) -> + | Some (CXXMethodDecl (di, _, _, fdi, _)) + | Some (CXXConstructorDecl (di, _, _, fdi, _)) + | Some (CXXConversionDecl (di, _, _, fdi, _)) + | Some (CXXDestructorDecl (di, _, _, fdi, _)) -> let templ_info = match tenv with Some t -> get_template_info t fdi | None -> Typ.NoTemplate in diff --git a/infer/src/clang/CType.ml b/infer/src/clang/CType.ml index 08b6a2f64..412e5cd6f 100644 --- a/infer/src/clang/CType.ml +++ b/infer/src/clang/CType.ml @@ -38,10 +38,10 @@ let is_class typ = 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, _) - | Some FunctionNoProtoType (_, function_type_info) -> + | Some (FunctionProtoType (_, function_type_info, _)) + | Some (FunctionNoProtoType (_, function_type_info)) -> function_type_info.Clang_ast_t.fti_return_type - | Some BlockPointerType (_, in_qual) -> + | Some (BlockPointerType (_, in_qual)) -> return_type_of_function_qual_type in_qual | Some _ -> L.(debug Capture Verbose) @@ -60,7 +60,7 @@ let return_type_of_function_type qual_type = return_type_of_function_qual_type q let is_block_type {Clang_ast_t.qt_type_ptr} = let open Clang_ast_t in match CAst_utils.get_desugared_type qt_type_ptr with - | Some BlockPointerType _ -> + | Some (BlockPointerType _) -> true | _ -> false @@ -68,9 +68,9 @@ let is_block_type {Clang_ast_t.qt_type_ptr} = let is_reference_type {Clang_ast_t.qt_type_ptr} = match CAst_utils.get_desugared_type qt_type_ptr with - | Some Clang_ast_t.LValueReferenceType _ -> + | Some (Clang_ast_t.LValueReferenceType _) -> true - | Some Clang_ast_t.RValueReferenceType _ -> + | Some (Clang_ast_t.RValueReferenceType _) -> true | _ -> false diff --git a/infer/src/clang/CType_decl.ml b/infer/src/clang/CType_decl.ml index 4abd2a6f0..380146016 100644 --- a/infer/src/clang/CType_decl.ml +++ b/infer/src/clang/CType_decl.ml @@ -82,12 +82,12 @@ let get_translate_as_friend_decl decl_list = in match get_friend_decl_opt (List.find_exn ~f:is_translate_as_friend_decl decl_list) with | Some - Clang_ast_t.ClassTemplateSpecializationDecl - (_, _, _, _, _, _, _, _, _, {tsi_specialization_args= [(`Type t_ptr)]}) -> + (Clang_ast_t.ClassTemplateSpecializationDecl + (_, _, _, _, _, _, _, _, _, {tsi_specialization_args= [`Type t_ptr]})) -> Some t_ptr | _ -> None - | exception Not_found -> + | exception Caml.Not_found -> None diff --git a/infer/src/clang/Capture.ml b/infer/src/clang/Capture.ml index 7f7e1be42..4b8614623 100644 --- a/infer/src/clang/Capture.ml +++ b/infer/src/clang/Capture.ml @@ -117,7 +117,7 @@ let run_clang clang_command read = match Utils.with_process_in (ClangCommand.command_to_run clang_command) read with | res, Ok () -> res - | _, Error `Exit_non_zero n -> + | _, Error (`Exit_non_zero n) -> (* exit with the same error code as clang in case of compilation failure *) exit_with_error n | _ -> @@ -152,15 +152,16 @@ let cc1_capture clang_cmd = Utils.filename_to_absolute ~root (List.last_exn orig_argv) in 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 - && CLocation.is_file_blacklisted source_path + if + Config.equal_analyzer Config.analyzer Config.CompileOnly + || 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 ; (* We still need to run clang, but we don't have to attach the plugin. *) run_clang clang_cmd Utils.consume_in ) - else if Config.skip_analysis_in_path_skips_compilation - && CLocation.is_file_blacklisted source_path + else if + Config.skip_analysis_in_path_skips_compilation && CLocation.is_file_blacklisted source_path then ( L.(debug Capture Quiet) "@\n Skip compilation and analysis of source file %s@\n@\n" source_path ; () ) diff --git a/infer/src/clang/CiOSVersionNumbers.ml b/infer/src/clang/CiOSVersionNumbers.ml index b2c395a9e..ee0c0f3d4 100644 --- a/infer/src/clang/CiOSVersionNumbers.ml +++ b/infer/src/clang/CiOSVersionNumbers.ml @@ -50,7 +50,7 @@ let sort_versions versions = let compare (version_float1, _) (version_float2, _) = Float.compare version_float1 version_float2 in - List.sort ~cmp:compare versions + List.sort ~compare versions let version_of number_s : human_readable_version option = diff --git a/infer/src/clang/ClangCommand.ml b/infer/src/clang/ClangCommand.ml index b36e5c0b5..d87f72548 100644 --- a/infer/src/clang/ClangCommand.ml +++ b/infer/src/clang/ClangCommand.ml @@ -153,9 +153,9 @@ let clang_cc1_cmd_sanitizer cmd = (* compilation-database Buck integration produces path to `dep.tmp` file that doesn't exist. Create it *) Unix.mkdir_p (Filename.dirname arg) ; arg ) - else if String.equal option "-dependency-file" - && Option.is_some Config.buck_compilation_database - (* In compilation database mode, dependency files are not assumed to exist *) + else if + String.equal option "-dependency-file" && Option.is_some Config.buck_compilation_database + (* In compilation database mode, dependency files are not assumed to exist *) then "/dev/null" else if String.equal option "-isystem" then match include_override_regex with diff --git a/infer/src/clang/ClangWrapper.ml b/infer/src/clang/ClangWrapper.ml index 7ddc2ae1f..8be2d8f44 100644 --- a/infer/src/clang/ClangWrapper.ml +++ b/infer/src/clang/ClangWrapper.ml @@ -106,8 +106,9 @@ let clang_driver_action_items : ClangCommand.t -> action_item list = while true do let line = In_channel.input_line_exn i in (* keep only commands and errors *) - if Str.string_match commands_or_errors line 0 - && not (Str.string_match ignored_errors line 0) + if + Str.string_match commands_or_errors line 0 + && not (Str.string_match ignored_errors line 0) then normalized_commands := one_line line :: !normalized_commands done with End_of_file -> () @@ -136,14 +137,16 @@ let exec_action_item ~prog ~args = function Error message:@\n\ %s@\n\ @\n\ - *** Infer needs a working compilation command to run." prog Pp.cli_args args error + *** Infer needs a working compilation command to run." + prog Pp.cli_args args error | ClangWarning warning -> L.external_warning "%s@\n" warning | CanonicalCommand clang_cmd -> Capture.capture clang_cmd | DriverCommand clang_cmd -> - if Option.is_none Config.buck_compilation_database - || Config.skip_analysis_in_path_skips_compilation + if + Option.is_none Config.buck_compilation_database + || Config.skip_analysis_in_path_skips_compilation then Capture.run_clang clang_cmd Utils.echo_in else L.debug Capture Quiet "Skipping seemingly uninteresting clang driver command %s@\n" @@ -181,7 +184,6 @@ let exe ~prog ~args = L.(debug Capture Quiet) "WARNING: `clang -### ` returned an empty set of commands to run and no error. Will \ run the original command directly:@\n \ - %s@\n\ - " + %s@\n" (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 ba516857d..798ee5724 100644 --- a/infer/src/clang/ComponentKit.ml +++ b/infer/src/clang/ComponentKit.ml @@ -94,11 +94,11 @@ let mutable_local_vars_advice context an = 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) -> + | Some (ObjCInterfaceType (_, decl_ptr)) | Some (RecordType (_, decl_ptr)) -> CAst_utils.get_decl decl_ptr - | Some PointerType (_, inner_qual_type) - | Some ObjCObjectPointerType (_, inner_qual_type) - | Some LValueReferenceType (_, inner_qual_type) -> + | Some (PointerType (_, inner_qual_type)) + | Some (ObjCObjectPointerType (_, inner_qual_type)) + | Some (LValueReferenceType (_, inner_qual_type)) -> get_referenced_type inner_qual_type | _ -> None @@ -113,9 +113,9 @@ let mutable_local_vars_advice context an = in let objc_whitelist = ["NSError"] in match get_referenced_type qual_type with - | Some CXXRecordDecl (_, ndi, _, _, _, _, _, _) -> + | Some (CXXRecordDecl (_, ndi, _, _, _, _, _, _)) -> List.mem ~equal:String.equal cpp_whitelist ndi.ni_name - | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + | Some (ObjCInterfaceDecl (_, ndi, _, _, _)) -> List.mem ~equal:String.equal objc_whitelist ndi.ni_name | _ -> false @@ -126,7 +126,7 @@ let mutable_local_vars_advice context an = (Clang_ast_t.VarDecl (decl_info, named_decl_info, qual_type, _) as decl) -> let is_const_ref = match CAst_utils.get_type qual_type.qt_type_ptr with - | Some LValueReferenceType (_, {Clang_ast_t.qt_is_const}) -> + | Some (LValueReferenceType (_, {Clang_ast_t.qt_is_const})) -> qt_is_const | _ -> false @@ -174,7 +174,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 @@ -207,7 +207,7 @@ let component_with_unconventional_superclass_advice context an = if is_component_or_controller_if (Some if_decl) then let superclass_name = match CAst_utils.get_super_if (Some if_decl) with - | Some Clang_ast_t.ObjCInterfaceDecl (_, named_decl_info, _, _, _) -> + | Some (Clang_ast_t.ObjCInterfaceDecl (_, named_decl_info, _, _, _)) -> Some named_decl_info.ni_name | _ -> None @@ -246,7 +246,7 @@ let component_with_unconventional_superclass_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 @@ -308,7 +308,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 @@ -327,7 +327,7 @@ let in_ck_class (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) -> + | Some (ObjCImplementationDecl (_, _, _, _, impl_decl_info)) -> CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface | _ -> None @@ -392,7 +392,7 @@ let rec component_initializer_with_side_effects_advice_ (context: CLintersContex let component_initializer_with_side_effects_advice (context: CLintersContext.context) an = match an with - | Ctl_parser_types.Stmt CallExpr (_, called_func_stmt :: _, _) -> + | Ctl_parser_types.Stmt (CallExpr (_, called_func_stmt :: _, _)) -> component_initializer_with_side_effects_advice_ context called_func_stmt | _ -> None @@ -407,7 +407,7 @@ let component_initializer_with_side_effects_advice (context: CLintersContext.con 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 -> + | Ctl_parser_types.Decl (Clang_ast_t.TranslationUnitDecl _) when condition -> let source_file = context.translation_unit_context.CFrontend_config.source_file in let line_count = SourceFile.line_count source_file in List.map diff --git a/infer/src/clang/ast_expressions.ml b/infer/src/clang/ast_expressions.ml index 958d9c241..fbc94e316 100644 --- a/infer/src/clang/ast_expressions.ml +++ b/infer/src/clang/ast_expressions.ml @@ -152,7 +152,7 @@ let make_binary_stmt stmt1 stmt2 stmt_info expr_info boi = let make_next_object_exp stmt_info item items = let var_decl_ref, var_type = match item with - | Clang_ast_t.DeclStmt (_, _, [(Clang_ast_t.VarDecl (di, name_info, var_qual_type, _))]) -> + | Clang_ast_t.DeclStmt (_, _, [Clang_ast_t.VarDecl (di, name_info, var_qual_type, _)]) -> let decl_ptr = di.Clang_ast_t.di_pointer in let decl_ref = make_decl_ref_qt `Var decl_ptr name_info false var_qual_type in let stmt_info_var = diff --git a/infer/src/clang/cArithmetic_trans.ml b/infer/src/clang/cArithmetic_trans.ml index e8ace7764..45cfc7bf2 100644 --- a/infer/src/clang/cArithmetic_trans.ml +++ b/infer/src/clang/cArithmetic_trans.ml @@ -186,8 +186,8 @@ let unary_operation_instruction translation_unit_context uoi e typ loc = L.(debug Capture Medium) "@\n\ WARNING: Missing translation for Unary Operator Kind %s. The construct has been \ - ignored...@\n\ - " uok ; + ignored...@\n" + uok ; (e, []) @@ -263,7 +263,7 @@ let bin_op_to_string boi = let sil_const_plus_one const = match const with - | Exp.Const Const.Cint n -> + | Exp.Const (Const.Cint n) -> Exp.Const (Const.Cint (IntLit.add n IntLit.one)) | _ -> Exp.BinOp (Binop.PlusA, const, Exp.Const (Const.Cint IntLit.one)) diff --git a/infer/src/clang/cAst_utils.ml b/infer/src/clang/cAst_utils.ml index 9ff057bed..0857ec986 100644 --- a/infer/src/clang/cAst_utils.ml +++ b/infer/src/clang/cAst_utils.ml @@ -106,8 +106,8 @@ let get_decl_opt_with_decl_ref decl_ref_opt = let get_property_of_ivar decl_ptr = Int.Table.find ClangPointers.ivar_to_property_table decl_ptr let update_sil_types_map type_ptr sil_type = - CFrontend_config.sil_types_map - := Clang_ast_extend.TypePointerMap.add type_ptr sil_type !CFrontend_config.sil_types_map + CFrontend_config.sil_types_map := + Clang_ast_extend.TypePointerMap.add type_ptr sil_type !CFrontend_config.sil_types_map let update_enum_map enum_constant_pointer sil_exp = @@ -115,16 +115,16 @@ let update_enum_map enum_constant_pointer sil_exp = ClangPointers.Map.find_exn !CFrontend_config.enum_map enum_constant_pointer in let enum_map_value = (predecessor_pointer_opt, Some sil_exp) in - CFrontend_config.enum_map - := ClangPointers.Map.set !CFrontend_config.enum_map ~key:enum_constant_pointer - ~data:enum_map_value + CFrontend_config.enum_map := + ClangPointers.Map.set !CFrontend_config.enum_map ~key:enum_constant_pointer + ~data:enum_map_value let add_enum_constant enum_constant_pointer predecessor_pointer_opt = let enum_map_value = (predecessor_pointer_opt, None) in - CFrontend_config.enum_map - := ClangPointers.Map.set !CFrontend_config.enum_map ~key:enum_constant_pointer - ~data:enum_map_value + CFrontend_config.enum_map := + ClangPointers.Map.set !CFrontend_config.enum_map ~key:enum_constant_pointer + ~data:enum_map_value let get_enum_constant_exp enum_constant_pointer = @@ -180,7 +180,7 @@ let sil_annot_of_type {Clang_ast_t.qt_type_ptr} = in let annot_name_opt = match get_type qt_type_ptr with - | Some AttributedType (_, attr_info) -> + | Some (AttributedType (_, attr_info)) -> if attr_info.ati_attr_kind = `Nullable then Some Annotations.nullable else if attr_info.ati_attr_kind = `Nonnull then Some Annotations.nonnull (* other annotations go here *) @@ -193,7 +193,7 @@ let sil_annot_of_type {Clang_ast_t.qt_type_ptr} = let name_of_typedef_type_info {Clang_ast_t.tti_decl_ptr} = match get_decl tti_decl_ptr with - | Some TypedefDecl (_, name_decl_info, _, _) -> + | Some (TypedefDecl (_, name_decl_info, _, _)) -> get_qualified_name name_decl_info | _ -> QualifiedCppName.empty @@ -201,7 +201,7 @@ let name_of_typedef_type_info {Clang_ast_t.tti_decl_ptr} = let name_opt_of_typedef_qual_type qual_type = match get_type qual_type.Clang_ast_t.qt_type_ptr with - | Some Clang_ast_t.TypedefType (_, typedef_type_info) -> + | Some (Clang_ast_t.TypedefType (_, typedef_type_info)) -> Some (name_of_typedef_type_info typedef_type_info) | _ -> None @@ -245,11 +245,11 @@ let get_function_decl_with_body decl_ptr = let decl_opt = get_decl decl_ptr in let decl_ptr' = match decl_opt with - | Some FunctionDecl (_, _, _, fdecl_info) - | Some CXXMethodDecl (_, _, _, fdecl_info, _) - | Some CXXConstructorDecl (_, _, _, fdecl_info, _) - | Some CXXConversionDecl (_, _, _, fdecl_info, _) - | Some CXXDestructorDecl (_, _, _, fdecl_info, _) -> + | Some (FunctionDecl (_, _, _, fdecl_info)) + | Some (CXXMethodDecl (_, _, _, fdecl_info, _)) + | Some (CXXConstructorDecl (_, _, _, fdecl_info, _)) + | Some (CXXConversionDecl (_, _, _, fdecl_info, _)) + | Some (CXXDestructorDecl (_, _, _, fdecl_info, _)) -> fdecl_info.Clang_ast_t.fdi_decl_ptr_with_body | _ -> Some decl_ptr @@ -331,13 +331,13 @@ let generate_key_decl decl = let rec get_super_if decl = match decl with - | Some Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info) -> + | Some (Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info)) -> (* Try getting the super ref through the impl info, and fall back to getting the if decl first and getting the super ref through it. *) let super_ref = get_decl_opt_with_decl_ref impl_decl_info.oidi_super in if Option.is_some super_ref then super_ref else get_super_if (get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface) - | Some Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, interface_decl_info) -> + | Some (Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, interface_decl_info)) -> get_decl_opt_with_decl_ref interface_decl_info.otdi_super | _ -> None @@ -350,7 +350,7 @@ let get_super_ObjCImplementationDecl impl_decl_info = let objc_interface_decl_super = get_super_if objc_interface_decl_current in let objc_implementation_decl_super = match objc_interface_decl_super with - | Some ObjCInterfaceDecl (_, _, _, _, interface_decl_info) -> + | Some (ObjCInterfaceDecl (_, _, _, _, interface_decl_info)) -> get_decl_opt_with_decl_ref interface_decl_info.otdi_implementation | _ -> None @@ -362,7 +362,7 @@ let get_impl_decl_info dec = match dec with Clang_ast_t.ObjCImplementationDecl (_, _, _, _, idi) -> Some idi | _ -> None -let default_blacklist = CFrontend_config.([nsobject_cl; nsproxy_cl]) +let default_blacklist = CFrontend_config.[nsobject_cl; nsproxy_cl] 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 @@ -371,7 +371,7 @@ let rec is_objc_if_descendant ?(blacklist= default_blacklist) if_decl ancestors L.(die InternalError) "Blacklist and ancestors must be mutually exclusive." else match if_decl with - | Some Clang_ast_t.ObjCInterfaceDecl (_, ndi, _, _, _) -> + | 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) && (in_list ancestors || is_objc_if_descendant ~blacklist (get_super_if if_decl) ancestors) @@ -386,12 +386,12 @@ let rec qual_type_to_objc_interface qual_type = and ctype_to_objc_interface typ_opt = match (typ_opt : Clang_ast_t.c_type option) with - | Some ObjCInterfaceType (_, decl_ptr) -> + | 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) -> + | Some (FunctionProtoType (_, function_type_info, _)) + | Some (FunctionNoProtoType (_, function_type_info)) -> qual_type_to_objc_interface function_type_info.Clang_ast_t.fti_return_type | _ -> None @@ -399,7 +399,7 @@ and ctype_to_objc_interface typ_opt = let if_decl_to_di_pointer_opt if_decl = match if_decl with - | Some Clang_ast_t.ObjCInterfaceDecl (if_decl_info, _, _, _, _) -> + | Some (Clang_ast_t.ObjCInterfaceDecl (if_decl_info, _, _, _, _)) -> Some if_decl_info.di_pointer | _ -> None @@ -425,7 +425,7 @@ let return_type_matches_class_type result_type interface_decl = 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) -> + | Some (ObjCMethodDecl (_, _, omdi)) -> not omdi.omdi_is_instance_method && return_type_matches_class_type omdi.omdi_result_type interface_decl | _ -> @@ -554,12 +554,13 @@ let get_superclass_curr_class_objc_from_decl (decl: Clang_ast_t.decl) = |> Option.map ~f:(fun dr -> dr.Clang_ast_t.dr_decl_pointer) |> Option.value_map ~f:get_decl ~default:None with - | Some ObjCInterfaceDecl (_, _, _, _, otdi) -> + | Some (ObjCInterfaceDecl (_, _, _, _, otdi)) -> otdi.otdi_super | _ -> Logging.die InternalError "Expected that ObjCImplementationDecl always has a pointer to it's interface, but \ - wasn't the case with %s" ni.Clang_ast_t.ni_name ) + wasn't the case with %s" + ni.Clang_ast_t.ni_name ) | ObjCCategoryDecl (_, _, _, _, ocdi) -> ocdi.odi_class_interface | ObjCCategoryImplDecl (_, _, _, _, ocidi) -> diff --git a/infer/src/clang/cContext.ml b/infer/src/clang/cContext.ml index d8371ddfa..6b2c6c235 100644 --- a/infer/src/clang/cContext.ml +++ b/infer/src/clang/cContext.ml @@ -102,9 +102,9 @@ let get_curr_class_ptr stmt_info curr_class = in (* Resolve categories to their class names *) match CAst_utils.get_decl decl_ptr with - | Some ObjCCategoryDecl (_, _, _, _, ocdi) -> + | Some (ObjCCategoryDecl (_, _, _, _, ocdi)) -> get_ptr_from_decl_ref ocdi.odi_class_interface - | Some ObjCCategoryImplDecl (_, _, _, _, ocidi) -> + | Some (ObjCCategoryImplDecl (_, _, _, _, ocidi)) -> get_ptr_from_decl_ref ocidi.ocidi_class_interface | _ -> decl_ptr @@ -126,12 +126,13 @@ let add_block_static_var context block_name static_var_typ = let new_static_vars, duplicate = try let static_vars = Typ.Procname.Map.find block_name outer_context.blocks_static_vars in - if List.mem - ~equal:(fun (var1, _) (var2, _) -> Pvar.equal var1 var2) - static_vars static_var_typ + if + List.mem + ~equal:(fun (var1, _) (var2, _) -> Pvar.equal var1 var2) + static_vars static_var_typ then (static_vars, true) else (static_var_typ :: static_vars, false) - with Not_found -> ([static_var_typ], false) + with Caml.Not_found -> ([static_var_typ], false) in if not duplicate then let blocks_static_vars = diff --git a/infer/src/clang/cEnum_decl.ml b/infer/src/clang/cEnum_decl.ml index 8448c4661..0d241a399 100644 --- a/infer/src/clang/cEnum_decl.ml +++ b/infer/src/clang/cEnum_decl.ml @@ -20,7 +20,7 @@ let add_enum_constant_to_map_if_needed decl_pointer pred_decl_opt = try ignore (CAst_utils.get_enum_constant_exp decl_pointer) ; true - with Not_found -> + with Caml.Not_found -> CAst_utils.add_enum_constant decl_pointer pred_decl_opt ; false diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index 9257c2808..ae4d63e4c 100644 --- a/infer/src/clang/cField_decl.ml +++ b/infer/src/clang/cField_decl.ml @@ -78,7 +78,7 @@ let get_fields qual_type_to_sil_type tenv class_tname decl_list = 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 - | Some ObjCIvarDecl (_, name_info, qual_type, _, _) -> + | Some (ObjCIvarDecl (_, name_info, qual_type, _, _)) -> let field = get_sil_field name_info qual_type property_attributes in CGeneral_utils.add_no_duplicates_fields field fields | _ -> diff --git a/infer/src/clang/cFrontend.ml b/infer/src/clang/cFrontend.ml index 844826b56..a4876a35d 100644 --- a/infer/src/clang/cFrontend.ml +++ b/infer/src/clang/cFrontend.ml @@ -53,8 +53,9 @@ let do_source_file (translation_unit_context: CFrontend_config.translation_unit_ NullabilityPreanalysis.analysis cfg tenv ; SourceFiles.add source_file cfg (FileLocal tenv) ; if Config.debug_mode then Tenv.store_debug_file_for_source source_file tenv ; - if Config.debug_mode || Config.testing_mode || Config.frontend_tests - || Option.is_some Config.icfg_dotty_outfile + if + Config.debug_mode || Config.testing_mode || Config.frontend_tests + || Option.is_some Config.icfg_dotty_outfile then Dotty.print_icfg_dotty source_file cfg ; L.(debug Capture Verbose) "%a" Cfg.pp_proc_signatures cfg ; let procedures_translated_summary = diff --git a/infer/src/clang/cFrontend_checkers.ml b/infer/src/clang/cFrontend_checkers.ml index 0518995d2..c2092447c 100644 --- a/infer/src/clang/cFrontend_checkers.ml +++ b/infer/src/clang/cFrontend_checkers.ml @@ -46,14 +46,15 @@ let tag_name_of_node an = let decl_ref_or_selector_name an = match CTL.next_state_via_transition an CTL.PointerToDecl with - | [(Ctl_parser_types.Decl ObjCMethodDecl _ as decl_an)] -> + | [(Ctl_parser_types.Decl (ObjCMethodDecl _) as decl_an)] -> "The selector " ^ Ctl_parser_types.ast_node_name decl_an | [(Ctl_parser_types.Decl _ as decl_an)] -> "The reference " ^ Ctl_parser_types.ast_node_name decl_an | _ -> L.(die ExternalError) "decl_ref_or_selector_name must be called with a DeclRefExpr or an ObjCMessageExpr, but \ - got %s" (tag_name_of_node an) + got %s" + (tag_name_of_node an) let iphoneos_target_sdk_version context _ = @@ -63,7 +64,7 @@ let iphoneos_target_sdk_version context _ = let available_ios_sdk an = let open Ctl_parser_types in match CTL.next_state_via_transition an CTL.PointerToDecl with - | [(Decl decl)] -> ( + | [Decl decl] -> ( match CPredicates.get_available_attr_ios_sdk (Decl decl) with | Some version -> version @@ -102,12 +103,12 @@ 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 - | Some ObjCIvarDecl (_, named_decl_info, _, _, _) -> + | Some (ObjCIvarDecl (_, named_decl_info, _, _, _)) -> named_decl_info.Clang_ast_t.ni_name | _ -> "" ) @@ -122,7 +123,7 @@ let cxx_ref_captured_in_block an = match an with | Decl _ -> CPredicates.captured_variables_cxx_ref an - | Stmt BlockExpr (_, _, _, d) -> + | Stmt (BlockExpr (_, _, _, d)) -> CPredicates.captured_variables_cxx_ref (Decl d) | _ -> [] @@ -135,9 +136,9 @@ let class_name node = let open Clang_ast_t in let class_name_of_interface_type typ = match typ with - | Some ObjCInterfaceType (_, ptr) -> ( + | Some (ObjCInterfaceType (_, ptr)) -> ( match CAst_utils.get_decl ptr with - | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + | Some (ObjCInterfaceDecl (_, ndi, _, _, _)) -> ndi.ni_name | _ -> "" ) @@ -149,9 +150,9 @@ let class_name node = -> ( let typ = CAst_utils.get_desugared_type type_ptr in match typ with - | Some ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr}) -> + | Some (ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr})) -> class_name_of_interface_type (CAst_utils.get_desugared_type qt_type_ptr) - | Some ObjCInterfaceType _ -> + | Some (ObjCInterfaceType _) -> class_name_of_interface_type typ | _ -> "" ) diff --git a/infer/src/clang/cFrontend_checkers_main.ml b/infer/src/clang/cFrontend_checkers_main.ml index 4d5cfbc2d..63dd28a74 100644 --- a/infer/src/clang/cFrontend_checkers_main.ml +++ b/infer/src/clang/cFrontend_checkers_main.ml @@ -98,8 +98,8 @@ let rec get_responds_to_selector stmt = let open Clang_ast_t in let responToSelectorMethods = ["respondsToSelector:"; "instancesRespondToSelector:"] in match stmt with - | ObjCMessageExpr (_, [_; (ObjCSelectorExpr (_, _, _, method_name))], _, mdi) - | ObjCMessageExpr (_, [(ObjCSelectorExpr (_, _, _, method_name))], _, mdi) + | ObjCMessageExpr (_, [_; ObjCSelectorExpr (_, _, _, method_name)], _, mdi) + | ObjCMessageExpr (_, [ObjCSelectorExpr (_, _, _, method_name)], _, mdi) when List.mem ~equal:String.equal responToSelectorMethods mdi.Clang_ast_t.omei_selector -> [method_name] | BinaryOperator (_, [stmt1; stmt2], _, bo_info) diff --git a/infer/src/clang/cFrontend_decl.ml b/infer/src/clang/cFrontend_decl.ml index a108442ac..81be5c356 100644 --- a/infer/src/clang/cFrontend_decl.ml +++ b/infer/src/clang/cFrontend_decl.ml @@ -92,7 +92,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron ClangLogging.log_broken_cfg procdesc __POS__ ~lang | _ -> () - | exception Not_found -> + | exception Caml.Not_found -> () in protect ~f ~recover ~pp_context trans_unit_ctx @@ -141,8 +141,9 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron (* For a destructor we create two procedures: a destructor wrapper and an inner destructor *) (* A destructor wrapper is called from the outside, i.e. for destructing local variables and fields *) (* The destructor wrapper calls the inner destructor which has the actual body *) - if CMethod_trans.create_local_procdesc ~set_objc_accessor_attr trans_unit_ctx cfg - tenv ms [body] [] + if + CMethod_trans.create_local_procdesc ~set_objc_accessor_attr trans_unit_ctx cfg tenv + ms [body] [] then add_method trans_unit_ctx tenv cfg curr_class procname body ms return_param_typ_opt is_objc None extra_instrs ~is_destructor_wrapper:true ; @@ -156,8 +157,9 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron (ms', procname') ) else (ms, procname) in - if CMethod_trans.create_local_procdesc ~set_objc_accessor_attr trans_unit_ctx cfg tenv - ms' [body] [] + if + CMethod_trans.create_local_procdesc ~set_objc_accessor_attr trans_unit_ctx cfg tenv ms' + [body] [] then add_method trans_unit_ctx tenv cfg curr_class procname' body ms' return_param_typ_opt is_objc None extra_instrs ~is_destructor_wrapper:false @@ -175,7 +177,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron 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 ObjCPropertyDecl (_, _, obj_c_property_decl_info) -> + | Some (ObjCPropertyDecl (_, _, obj_c_property_decl_info)) -> let process_accessor pointer = match CAst_utils.get_decl_opt_with_decl_ref pointer with | Some (ObjCMethodDecl _ as dec) -> @@ -320,7 +322,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron 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 -> + | (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 -> @@ -331,7 +333,7 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron () ) | 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 -> + || (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 = diff --git a/infer/src/clang/cFrontend_errors.ml b/infer/src/clang/cFrontend_errors.ml index 31ce8fad6..89dfebfb5 100644 --- a/infer/src/clang/cFrontend_errors.ml +++ b/infer/src/clang/cFrontend_errors.ml @@ -152,7 +152,7 @@ let rec expand_message_string context message an = L.(debug Linters Medium) "Replacing %s in message: @\n %s @\n" ms message ; L.(debug Linters Medium) "Resulting message: @\n %s @\n" message' ; expand_message_string context message' an - with Not_found -> message + with Caml.Not_found -> message let remove_new_lines_and_whitespace message = @@ -253,7 +253,9 @@ let create_parsed_linters linters_def_file checkers : linter list = let rec apply_substitution f sub = let sub_param p = - try snd (List.find_exn sub ~f:(fun (a, _) -> ALVar.equal p a)) with Not_found -> p + try snd (List.find_exn sub ~f:(fun (a, _) -> ALVar.equal p a)) with + | Not_found_s _ | Caml.Not_found -> + p in let sub_list_param ps = List.map ps ~f:sub_param in let open CTL in @@ -321,7 +323,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 Not_found -> acc + with Caml.Not_found -> acc (* in this case it should be a predicate *) ) | Not f1 -> Not (expand f1 map error_msg) @@ -361,11 +363,11 @@ let rec expand_path paths path_map = match paths with | [] -> [] - | (ALVar.Var path_var) :: rest -> ( + | ALVar.Var path_var :: rest -> ( try let paths = ALVar.VarMap.find path_var path_map in List.append paths (expand_path rest path_map) - with Not_found -> L.(die ExternalError) "Path variable %s not found. " path_var ) + with Caml.Not_found -> L.(die ExternalError) "Path variable %s not found. " path_var ) | path :: rest -> path :: expand_path rest path_map @@ -509,7 +511,7 @@ let invoke_set_of_parsed_checkers_an parsed_linters context (an: Ctl_parser_type (* We decouple the hardcoded checkers from the parsed ones *) let invoke_set_of_checkers_on_node context an = ( match an with - | Ctl_parser_types.Decl Clang_ast_t.TranslationUnitDecl _ -> + | Ctl_parser_types.Decl (Clang_ast_t.TranslationUnitDecl _) -> (* Don't run parsed linters on TranslationUnitDecl node. Because depending on the formula it may give an error at line -1 *) () diff --git a/infer/src/clang/cIssue.ml b/infer/src/clang/cIssue.ml index 51123e1c8..5532e9157 100644 --- a/infer/src/clang/cIssue.ml +++ b/infer/src/clang/cIssue.ml @@ -14,16 +14,16 @@ type mode = On | Off type issue_desc = { id: string ; (* issue id *) - description: string + description: string ; (* Description in the error message *) - doc_url: string option + doc_url: string option ; mode: mode ; name: string option ; (* issue name, if no name is given name will be a readable version of id, by removing underscores and capitalizing first letters of words *) - loc: Location.t + loc: Location.t ; (* location in the code *) - severity: Exceptions.err_kind + severity: Exceptions.err_kind ; suggestion: string option (* an optional suggestion or correction *) } diff --git a/infer/src/clang/cIssue.mli b/infer/src/clang/cIssue.mli index e65a9b653..748d75afc 100644 --- a/infer/src/clang/cIssue.mli +++ b/infer/src/clang/cIssue.mli @@ -14,16 +14,16 @@ type mode = On | Off type issue_desc = { id: string ; (* issue id *) - description: string + description: string ; (* Description in the error message *) - doc_url: string option + doc_url: string option ; mode: mode ; name: string option ; (* issue name, if no name is given name will be a readable version of id, by removing underscores and capitalizing first letters of words *) - loc: Location.t + loc: Location.t ; (* location in the code *) - severity: Exceptions.err_kind + severity: Exceptions.err_kind ; suggestion: string option (* an optional suggestion or correction *) } diff --git a/infer/src/clang/cLocation.ml b/infer/src/clang/cLocation.ml index 770f6a1d3..da568c243 100644 --- a/infer/src/clang/cLocation.ml +++ b/infer/src/clang/cLocation.ml @@ -37,7 +37,7 @@ let should_do_frontend_check trans_unit_ctx (loc_start, _) = match Option.map ~f:SourceFile.from_abs_path loc_start.Clang_ast_t.sl_file with | Some source_file -> SourceFile.equal source_file trans_unit_ctx.CFrontend_config.source_file - || source_file_in_project source_file && not Config.testing_mode + || (source_file_in_project source_file && not Config.testing_mode) | None -> false @@ -71,7 +71,7 @@ let should_translate trans_unit_ctx (loc_start, loc_end) decl_trans_context ~tra 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 + || 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 diff --git a/infer/src/clang/cMethodSignature.ml b/infer/src/clang/cMethodSignature.ml index 93c2ba844..33897b0fa 100644 --- a/infer/src/clang/cMethodSignature.ml +++ b/infer/src/clang/cMethodSignature.ml @@ -28,7 +28,7 @@ type t = ; pointer_to_parent: Clang_ast_t.pointer option ; pointer_to_property_opt: Clang_ast_t.pointer option ; (* If set then method is a getter/setter *) - return_param_typ: Typ.t option } + return_param_typ: Typ.t option } (* A method is a getter if it has a link to a property and *) (* it has 1 argument (this includes self) *) diff --git a/infer/src/clang/cMethodSignature.mli b/infer/src/clang/cMethodSignature.mli index c7fb4ad0a..b6404d2f4 100644 --- a/infer/src/clang/cMethodSignature.mli +++ b/infer/src/clang/cMethodSignature.mli @@ -26,7 +26,7 @@ type t = ; pointer_to_parent: Clang_ast_t.pointer option ; pointer_to_property_opt: Clang_ast_t.pointer option ; (* If set then method is a getter/setter *) - return_param_typ: Typ.t option } + return_param_typ: Typ.t option } val is_getter : t -> bool diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index 3b3cd40e6..4322d6a3b 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -274,7 +274,8 @@ let get_superclass_curr_class_objc context = | None -> Logging.die InternalError "Expected that the current class ptr in the context is a valid pointer to class decl, \ - but didn't find declaration, ptr is %d " ptr ) + but didn't find declaration, ptr is %d " + ptr ) | CContext.ContextNoCls -> Logging.die InternalError "This should only be called in the context of a class, but got CContext.ContextNoCls" @@ -374,7 +375,7 @@ let sil_func_attributes_of_attributes attrs = match al with | [] -> List.rev acc - | (Clang_ast_t.SentinelAttr attribute_info) :: tl -> + | Clang_ast_t.SentinelAttr attribute_info :: tl -> let sentinel, null_pos = match attribute_info.Clang_ast_t.ai_parameters with | [a; b] -> @@ -397,7 +398,7 @@ let should_create_procdesc cfg procname defined set_objc_accessor_attr = Typ.Procname.Hash.remove cfg procname ; true ) else false - | exception Not_found -> + | exception Caml.Not_found -> true @@ -410,10 +411,10 @@ let sil_method_annotation_of_args args method_type : Annot.Method.t = let is_pointer_to_const {Clang_ast_t.qt_type_ptr} = match CAst_utils.get_type qt_type_ptr with - | Some PointerType (_, {Clang_ast_t.qt_is_const}) - | Some ObjCObjectPointerType (_, {Clang_ast_t.qt_is_const}) - | Some RValueReferenceType (_, {Clang_ast_t.qt_is_const}) - | Some LValueReferenceType (_, {Clang_ast_t.qt_is_const}) -> + | Some (PointerType (_, {Clang_ast_t.qt_is_const})) + | Some (ObjCObjectPointerType (_, {Clang_ast_t.qt_is_const})) + | Some (RValueReferenceType (_, {Clang_ast_t.qt_is_const})) + | Some (LValueReferenceType (_, {Clang_ast_t.qt_is_const})) -> qt_is_const | _ -> false @@ -429,60 +430,60 @@ let is_value {Clang_ast_t.qt_type_ptr} = | Clang_ast_types.TypePtr.Ptr _ -> let rec is_value_raw qt_type_ptr = match CAst_utils.get_type qt_type_ptr with - | Some BuiltinType _ - | Some ComplexType _ - | Some DependentSizedExtVectorType _ - | Some VectorType _ - | Some ExtVectorType _ - | Some RecordType _ - | Some EnumType _ - | Some InjectedClassNameType _ - | Some ObjCObjectType _ - | Some ObjCInterfaceType _ -> + | Some (BuiltinType _) + | Some (ComplexType _) + | Some (DependentSizedExtVectorType _) + | Some (VectorType _) + | Some (ExtVectorType _) + | Some (RecordType _) + | Some (EnumType _) + | Some (InjectedClassNameType _) + | Some (ObjCObjectType _) + | Some (ObjCInterfaceType _) -> true - | Some AdjustedType (_, {Clang_ast_t.qt_type_ptr}) - | Some DecayedType (_, {Clang_ast_t.qt_type_ptr}) - | Some ParenType (_, {Clang_ast_t.qt_type_ptr}) - | Some DecltypeType (_, {Clang_ast_t.qt_type_ptr}) - | Some AtomicType (_, {Clang_ast_t.qt_type_ptr}) -> + | Some (AdjustedType (_, {Clang_ast_t.qt_type_ptr})) + | Some (DecayedType (_, {Clang_ast_t.qt_type_ptr})) + | Some (ParenType (_, {Clang_ast_t.qt_type_ptr})) + | Some (DecltypeType (_, {Clang_ast_t.qt_type_ptr})) + | Some (AtomicType (_, {Clang_ast_t.qt_type_ptr})) -> is_value_raw qt_type_ptr - | Some TypedefType (_, {Clang_ast_t.tti_child_type}) -> + | Some (TypedefType (_, {Clang_ast_t.tti_child_type})) -> is_value_raw tti_child_type.Clang_ast_t.qt_type_ptr (* These types could be value types, and we try our best to resolve them *) - | Some AttributedType ({Clang_ast_t.ti_desugared_type}, _) - | Some TypeOfExprType {Clang_ast_t.ti_desugared_type} - | Some TypeOfType {Clang_ast_t.ti_desugared_type} - | Some UnaryTransformType {Clang_ast_t.ti_desugared_type} - | Some ElaboratedType {Clang_ast_t.ti_desugared_type} - | Some AutoType {Clang_ast_t.ti_desugared_type} - | Some DependentNameType {Clang_ast_t.ti_desugared_type} - | Some DeducedTemplateSpecializationType {Clang_ast_t.ti_desugared_type} - | Some TemplateSpecializationType {Clang_ast_t.ti_desugared_type} - | Some DependentTemplateSpecializationType {Clang_ast_t.ti_desugared_type} - | Some TemplateTypeParmType {Clang_ast_t.ti_desugared_type} - | Some SubstTemplateTypeParmType {Clang_ast_t.ti_desugared_type} - | Some SubstTemplateTypeParmPackType {Clang_ast_t.ti_desugared_type} - | Some PackExpansionType {Clang_ast_t.ti_desugared_type} - | Some UnresolvedUsingType {Clang_ast_t.ti_desugared_type} -> ( + | Some (AttributedType ({Clang_ast_t.ti_desugared_type}, _)) + | Some (TypeOfExprType {Clang_ast_t.ti_desugared_type}) + | Some (TypeOfType {Clang_ast_t.ti_desugared_type}) + | Some (UnaryTransformType {Clang_ast_t.ti_desugared_type}) + | Some (ElaboratedType {Clang_ast_t.ti_desugared_type}) + | Some (AutoType {Clang_ast_t.ti_desugared_type}) + | Some (DependentNameType {Clang_ast_t.ti_desugared_type}) + | Some (DeducedTemplateSpecializationType {Clang_ast_t.ti_desugared_type}) + | Some (TemplateSpecializationType {Clang_ast_t.ti_desugared_type}) + | Some (DependentTemplateSpecializationType {Clang_ast_t.ti_desugared_type}) + | Some (TemplateTypeParmType {Clang_ast_t.ti_desugared_type}) + | Some (SubstTemplateTypeParmType {Clang_ast_t.ti_desugared_type}) + | Some (SubstTemplateTypeParmPackType {Clang_ast_t.ti_desugared_type}) + | Some (PackExpansionType {Clang_ast_t.ti_desugared_type}) + | Some (UnresolvedUsingType {Clang_ast_t.ti_desugared_type}) -> ( match ti_desugared_type with Some ptr -> is_value_raw ptr | None -> false ) (* These types are known to be non-value types *) - | Some PointerType _ - | Some BlockPointerType _ - | Some LValueReferenceType _ - | Some RValueReferenceType _ - | Some MemberPointerType _ - | Some ConstantArrayType _ - | Some IncompleteArrayType _ - | Some VariableArrayType _ - | Some DependentSizedArrayType _ - | Some FunctionProtoType _ - | Some FunctionNoProtoType _ - | Some ObjCObjectPointerType _ - | Some NoneType _ - | Some DependentAddressSpaceType _ + | Some (PointerType _) + | Some (BlockPointerType _) + | Some (LValueReferenceType _) + | Some (RValueReferenceType _) + | Some (MemberPointerType _) + | Some (ConstantArrayType _) + | Some (IncompleteArrayType _) + | Some (VariableArrayType _) + | Some (DependentSizedArrayType _) + | Some (FunctionProtoType _) + | Some (FunctionNoProtoType _) + | Some (ObjCObjectPointerType _) + | Some (NoneType _) + | Some (DependentAddressSpaceType _) (* These types I don't know what they are. Be conservative and treat them as non value types *) - | Some ObjCTypeParamType _ - | Some PipeType _ + | Some (ObjCTypeParamType _) + | Some (PipeType _) | None -> false in @@ -514,11 +515,11 @@ let get_byval_args_indices ~shift args = 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 diff --git a/infer/src/clang/cPredicates.ml b/infer/src/clang/cPredicates.ml index db3157eec..23ab700dc 100644 --- a/infer/src/clang/cPredicates.ml +++ b/infer/src/clang/cPredicates.ml @@ -15,11 +15,11 @@ let parsed_type_map : Ctl_parser_types.abs_ctype String.Map.t ref = ref String.M let rec objc_class_of_pointer_type type_ptr = match CAst_utils.get_type type_ptr with - | Some ObjCInterfaceType (_, decl_ptr) -> + | Some (ObjCInterfaceType (_, decl_ptr)) -> CAst_utils.get_decl decl_ptr - | Some ObjCObjectPointerType (_, inner_qual_type) -> + | Some (ObjCObjectPointerType (_, inner_qual_type)) -> objc_class_of_pointer_type inner_qual_type.qt_type_ptr - | Some AttributedType (type_info, _) -> ( + | Some (AttributedType (type_info, _)) -> ( match type_info.ti_desugared_type with | Some type_ptr -> objc_class_of_pointer_type type_ptr @@ -31,7 +31,7 @@ let rec objc_class_of_pointer_type type_ptr = let receiver_class_method_call an = match an with - | Ctl_parser_types.Stmt ObjCMessageExpr (_, _, _, obj_c_message_expr_info) -> ( + | Ctl_parser_types.Stmt (ObjCMessageExpr (_, _, _, obj_c_message_expr_info)) -> ( match obj_c_message_expr_info.omei_receiver_kind with | `Class qt -> CAst_utils.get_decl_from_typ_ptr qt.qt_type_ptr @@ -43,7 +43,7 @@ let receiver_class_method_call an = let receiver_instance_method_call an = match an with - | Ctl_parser_types.Stmt ObjCMessageExpr (_, args, _, obj_c_message_expr_info) -> ( + | Ctl_parser_types.Stmt (ObjCMessageExpr (_, args, _, obj_c_message_expr_info)) -> ( match obj_c_message_expr_info.omei_receiver_kind with | `Instance -> ( match args with @@ -83,7 +83,7 @@ let get_available_attr_ios_sdk an = match attrs with | [] -> None - | (AvailabilityAttr attr_info) :: rest -> ( + | AvailabilityAttr attr_info :: rest -> ( match attr_info.ai_parameters with | "ios" :: version :: _ -> Some @@ -108,7 +108,7 @@ let get_ivar_attributes ivar_decl = match ivar_decl with | ObjCIvarDecl (ivar_decl_info, _, _, _, _) -> ( match CAst_utils.get_property_of_ivar ivar_decl_info.Clang_ast_t.di_pointer with - | Some ObjCPropertyDecl (_, _, obj_c_property_decl_info) -> + | Some (ObjCPropertyDecl (_, _, obj_c_property_decl_info)) -> obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes | _ -> [] ) @@ -122,11 +122,11 @@ let captured_variables_cxx_ref an = let capture_var_is_cxx_ref reference_captured_vars captured_var = let decl_ref_opt = captured_var.Clang_ast_t.bcv_variable in match CAst_utils.get_decl_opt_with_decl_ref decl_ref_opt with - | Some VarDecl (_, named_decl_info, qual_type, _) - | Some ParmVarDecl (_, named_decl_info, qual_type, _) - | Some ImplicitParamDecl (_, named_decl_info, qual_type, _) -> ( + | Some (VarDecl (_, named_decl_info, qual_type, _)) + | Some (ParmVarDecl (_, named_decl_info, qual_type, _)) + | Some (ImplicitParamDecl (_, named_decl_info, qual_type, _)) -> ( match CAst_utils.get_desugared_type qual_type.Clang_ast_t.qt_type_ptr with - | Some RValueReferenceType _ | Some LValueReferenceType _ -> + | Some (RValueReferenceType _) | Some (LValueReferenceType _) -> named_decl_info :: reference_captured_vars | _ -> reference_captured_vars ) @@ -134,7 +134,7 @@ let captured_variables_cxx_ref an = reference_captured_vars in match an with - | Ctl_parser_types.Decl BlockDecl (_, bdi) -> + | Ctl_parser_types.Decl (BlockDecl (_, bdi)) -> List.fold ~f:capture_var_is_cxx_ref ~init:[] bdi.bdi_captured_variables | _ -> [] @@ -151,7 +151,7 @@ let pp_predicate fmt (name_, arglist_) = (* is an objc interface with name expected_name *) let is_objc_interface_named an expected_name = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCInterfaceDecl (_, ni, _, _, _) -> + | Ctl_parser_types.Decl (Clang_ast_t.ObjCInterfaceDecl (_, ni, _, _, _)) -> ALVar.compare_str_with_alexp ni.ni_name expected_name | _ -> false @@ -173,7 +173,7 @@ let is_object_of_class_named receiver cname = let get_selector an = match an with - | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, _, _, omei) -> + | Ctl_parser_types.Stmt (Clang_ast_t.ObjCMessageExpr (_, _, _, omei)) -> Some omei.omei_selector | _ -> None @@ -193,9 +193,9 @@ let is_receiver_kind_class omei cname = match omei.omei_receiver_kind with | `Class ptr -> ( match CAst_utils.get_desugared_type ptr.Clang_ast_t.qt_type_ptr with - | Some ObjCInterfaceType (_, ptr) -> ( + | Some (ObjCInterfaceType (_, ptr)) -> ( match CAst_utils.get_decl ptr with - | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + | Some (ObjCInterfaceDecl (_, ndi, _, _, _)) -> ALVar.compare_str_with_alexp ndi.ni_name cname | _ -> false ) @@ -207,7 +207,7 @@ let is_receiver_kind_class omei cname = let call_class_method an cname mname = match an with - | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, _, _, omei) -> + | Ctl_parser_types.Stmt (Clang_ast_t.ObjCMessageExpr (_, _, _, omei)) -> is_receiver_kind_class omei cname && ALVar.compare_str_with_alexp omei.omei_selector mname | _ -> false @@ -218,7 +218,7 @@ let call_class_method an cname mname = *) let call_instance_method an cname mname = match an with - | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, receiver :: _, _, omei) -> + | Ctl_parser_types.Stmt (Clang_ast_t.ObjCMessageExpr (_, receiver :: _, _, omei)) -> is_object_of_class_named receiver cname && ALVar.compare_str_with_alexp omei.omei_selector mname | _ -> @@ -278,7 +278,7 @@ let is_enum_constant an name = let is_enum_constant_of_enum an name = match an with - | Ctl_parser_types.Stmt Clang_ast_t.DeclRefExpr (_, _, _, drti) -> ( + | Ctl_parser_types.Stmt (Clang_ast_t.DeclRefExpr (_, _, _, drti)) -> ( match drti.drti_decl_ref with | Some dr -> ( @@ -302,7 +302,7 @@ let is_enum_constant_of_enum an name = let is_strong_property an = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCPropertyDecl (_, _, pdi) -> + | Ctl_parser_types.Decl (Clang_ast_t.ObjCPropertyDecl (_, _, pdi)) -> ObjcProperty_decl.is_strong_property pdi | _ -> false @@ -310,7 +310,7 @@ let is_strong_property an = let is_weak_property an = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCPropertyDecl (_, _, pdi) -> + | Ctl_parser_types.Decl (Clang_ast_t.ObjCPropertyDecl (_, _, pdi)) -> ObjcProperty_decl.is_weak_property pdi | _ -> false @@ -318,7 +318,7 @@ let is_weak_property an = let is_assign_property an = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCPropertyDecl (_, _, pdi) -> + | Ctl_parser_types.Decl (Clang_ast_t.ObjCPropertyDecl (_, _, pdi)) -> ObjcProperty_decl.is_assign_property pdi | _ -> false @@ -327,16 +327,16 @@ let is_assign_property an = let is_property_pointer_type an = let open Clang_ast_t in match an with - | Ctl_parser_types.Decl ObjCPropertyDecl (_, _, pdi) -> ( + | Ctl_parser_types.Decl (ObjCPropertyDecl (_, _, pdi)) -> ( match CAst_utils.get_desugared_type pdi.opdi_qual_type.Clang_ast_t.qt_type_ptr with - | Some MemberPointerType _ | Some ObjCObjectPointerType _ | Some BlockPointerType _ -> + | Some (MemberPointerType _) | Some (ObjCObjectPointerType _) | Some (BlockPointerType _) -> true - | Some TypedefType (_, tti) -> + | Some (TypedefType (_, tti)) -> let typedef_str = CAst_utils.name_of_typedef_type_info tti |> QualifiedCppName.to_qual_string in String.equal typedef_str CFrontend_config.id_cl - | exception Not_found -> + | exception Caml.Not_found -> false | _ -> false ) @@ -349,7 +349,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 @@ -366,16 +366,16 @@ 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 - | Some ObjCMethodDecl (_, _, mdi) -> + | Some (ObjCMethodDecl (_, _, mdi)) -> if mdi.omdi_is_property_accessor then let property_opt = mdi.omdi_property_decl in match CAst_utils.get_decl_opt_with_decl_ref property_opt with - | Some ObjCPropertyDecl (_, _, pdi) -> ( + | Some (ObjCPropertyDecl (_, _, pdi)) -> ( match pdi.opdi_ivar_decl with | Some decl_ref -> Int.equal decl_ref.dr_decl_pointer ivar_pointer @@ -417,7 +417,7 @@ let is_in_method context name = let is_in_objc_method context name = match context.CLintersContext.current_method with - | Some ObjCMethodDecl _ -> + | Some (ObjCMethodDecl _) -> is_in_method context name | _ -> false @@ -425,7 +425,7 @@ let is_in_objc_method context name = let is_in_function context name = match context.CLintersContext.current_method with - | Some FunctionDecl _ -> + | Some (FunctionDecl _) -> is_in_method context name | _ -> false @@ -433,7 +433,7 @@ let is_in_function context name = let is_in_cxx_method context name = match context.CLintersContext.current_method with - | Some CXXMethodDecl _ -> + | Some (CXXMethodDecl _) -> is_in_method context name | _ -> false @@ -441,7 +441,7 @@ let is_in_cxx_method context name = let is_in_cxx_constructor context name = match context.CLintersContext.current_method with - | Some CXXConstructorDecl _ -> + | Some (CXXConstructorDecl _) -> is_in_method context name | _ -> false @@ -449,14 +449,14 @@ let is_in_cxx_constructor context name = let is_in_cxx_destructor context name = match context.CLintersContext.current_method with - | Some CXXDestructorDecl _ -> + | Some (CXXDestructorDecl _) -> is_in_method context name | _ -> false let is_in_block context = - match context.CLintersContext.current_method with Some BlockDecl _ -> true | _ -> false + match context.CLintersContext.current_method with Some (BlockDecl _) -> true | _ -> false let rec is_subclass_of decl name = @@ -498,7 +498,7 @@ let is_binop_with_kind an alexp_kind = if not (Clang_ast_proj.is_valid_binop_kind_name str_kind) then L.(die ExternalError) "Binary operator kind '%s' is not valid" str_kind ; match an with - | Ctl_parser_types.Stmt Clang_ast_t.BinaryOperator (_, _, _, boi) -> + | Ctl_parser_types.Stmt (Clang_ast_t.BinaryOperator (_, _, _, boi)) -> ALVar.compare_str_with_alexp (Clang_ast_proj.string_of_binop_kind boi.boi_kind) alexp_kind | _ -> false @@ -509,7 +509,7 @@ let is_unop_with_kind an alexp_kind = if not (Clang_ast_proj.is_valid_unop_kind_name str_kind) then L.(die ExternalError) "Unary operator kind '%s' is not valid" str_kind ; match an with - | Ctl_parser_types.Stmt Clang_ast_t.UnaryOperator (_, _, _, uoi) -> + | Ctl_parser_types.Stmt (Clang_ast_t.UnaryOperator (_, _, _, uoi)) -> ALVar.compare_str_with_alexp (Clang_ast_proj.string_of_unop_kind uoi.uoi_kind) alexp_kind | _ -> false @@ -545,11 +545,11 @@ let is_node an nodename = let is_ptr_to_objc_class typ class_name = match typ with - | Some Clang_ast_t.ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr}) -> ( + | Some (Clang_ast_t.ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr})) -> ( match CAst_utils.get_desugared_type qt_type_ptr with - | Some ObjCInterfaceType (_, ptr) -> ( + | Some (ObjCInterfaceType (_, ptr)) -> ( match CAst_utils.get_decl ptr with - | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + | Some (ObjCInterfaceDecl (_, ndi, _, _, _)) -> ALVar.compare_str_with_alexp ndi.ni_name class_name | _ -> false ) @@ -589,7 +589,7 @@ let declaration_has_name an name = (* an is an expression @selector with whose name in the language of re *) let is_at_selector_with_name an re = match an with - | Ctl_parser_types.Stmt ObjCSelectorExpr (_, _, _, s) -> + | Ctl_parser_types.Stmt (ObjCSelectorExpr (_, _, _, s)) -> ALVar.compare_str_with_alexp s re | _ -> false @@ -597,8 +597,8 @@ let is_at_selector_with_name an re = let is_class an re = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCInterfaceDecl _ - | Ctl_parser_types.Decl Clang_ast_t.ObjCImplementationDecl _ -> + | Ctl_parser_types.Decl (Clang_ast_t.ObjCInterfaceDecl _) + | Ctl_parser_types.Decl (Clang_ast_t.ObjCImplementationDecl _) -> declaration_has_name an re | _ -> false @@ -639,7 +639,7 @@ let decl_unavailable_in_supported_ios_sdk (cxt: CLintersContext.context) an = | _ -> [] in - let max_allowed_version_opt = List.max_elt allowed_os_versions ~cmp:Utils.compare_versions in + let max_allowed_version_opt = List.max_elt allowed_os_versions ~compare:Utils.compare_versions in let available_attr_ios_sdk = get_available_attr_ios_sdk an in match (available_attr_ios_sdk, max_allowed_version_opt) with | Some available_attr_ios_sdk, Some max_allowed_version -> @@ -715,7 +715,7 @@ let has_type_const_ptr_to_objc_class node = ~source_range:(Ctl_parser_types.ast_node_source_range node) type_ptr with - | Some ObjCObjectPointerType (_, qt) -> + | Some (ObjCObjectPointerType (_, qt)) -> qt.qt_is_const | _ -> false ) @@ -765,7 +765,7 @@ let is_decl node = let method_return_type an typ_ = L.(debug Linters Verbose) "@\n Executing method_return_type..." ; match (an, typ_) with - | Ctl_parser_types.Decl Clang_ast_t.ObjCMethodDecl (_, _, mdi), ALVar.Const typ -> + | Ctl_parser_types.Decl (Clang_ast_t.ObjCMethodDecl (_, _, mdi)), ALVar.Const typ -> L.(debug Linters Verbose) "@\n with parameter `%s`...." typ ; let qual_type = mdi.Clang_ast_t.omdi_result_type in type_ptr_equal_type qual_type.Clang_ast_t.qt_type_ptr typ @@ -784,7 +784,7 @@ let rec check_protocol_hiearachy decls_ptr prot_name_ = | pt :: decls' -> let di, protocols = match CAst_utils.get_decl pt with - | Some ObjCProtocolDecl (_, di, _, _, opcdi) -> + | Some (ObjCProtocolDecl (_, di, _, _, opcdi)) -> (Some di, opcdi.opcdi_protocols) | _ -> (None, []) @@ -800,16 +800,16 @@ let has_type_subprotocol_of an prot_name_ = let open Clang_ast_t in let rec check_subprotocol t = match t with - | Some ObjCObjectPointerType (_, qt) -> + | Some (ObjCObjectPointerType (_, qt)) -> check_subprotocol (CAst_utils.get_type qt.qt_type_ptr) - | Some ObjCObjectType (_, ooti) -> + | Some (ObjCObjectType (_, ooti)) -> if List.length ooti.ooti_protocol_decls_ptr > 0 then check_protocol_hiearachy ooti.ooti_protocol_decls_ptr prot_name_ else List.exists ~f:(fun qt -> check_subprotocol (CAst_utils.get_type qt.qt_type_ptr)) ooti.ooti_type_args - | Some ObjCInterfaceType (_, pt) -> + | Some (ObjCInterfaceType (_, pt)) -> check_protocol_hiearachy [pt] prot_name_ | _ -> false @@ -824,7 +824,7 @@ let has_type_subprotocol_of an prot_name_ = 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, _) -> ( + | Ctl_parser_types.Decl (ObjCMethodDecl (_, named_decl_info, _)) -> ( match cxt.if_context with | Some if_context -> let in_selector_block = if_context.within_responds_to_selector_block in @@ -852,7 +852,7 @@ let within_available_class_block (cxt: CLintersContext.context) an = let using_namespace an namespace = let open Clang_ast_t in match an with - | Ctl_parser_types.Decl UsingDirectiveDecl (_, _, uddi) -> ( + | Ctl_parser_types.Decl (UsingDirectiveDecl (_, _, uddi)) -> ( match uddi.uddi_nominated_namespace with | Some dr -> ( match (dr.dr_kind, dr.dr_name) with @@ -870,11 +870,11 @@ let rec get_decl_attributes_for_callexpr an = let open Clang_ast_t in let open Ctl_parser_types in match an with - | Stmt CallExpr (_, func :: _, _) -> + | Stmt (CallExpr (_, func :: _, _)) -> get_decl_attributes_for_callexpr (Stmt func) - | Stmt ImplicitCastExpr (_, [stmt], _, _) -> + | Stmt (ImplicitCastExpr (_, [stmt], _, _)) -> get_decl_attributes_for_callexpr (Stmt stmt) - | Stmt DeclRefExpr (_, _, _, drti) -> ( + | Stmt (DeclRefExpr (_, _, _, drti)) -> ( match CAst_utils.get_decl_opt_with_decl_ref drti.drti_decl_ref with | Some decl -> let decl_info = Clang_ast_proj.get_decl_tuple decl in @@ -891,7 +891,7 @@ let has_visibility_attribute an visibility = match attrs with | [] -> false - | (VisibilityAttr attr_info) :: rest -> + | VisibilityAttr attr_info :: rest -> if List.exists ~f:(fun s -> String.equal param (String.strip s)) attr_info.ai_parameters then true else has_visibility_attr rest param @@ -912,10 +912,10 @@ let has_value an al_exp = let open Clang_ast_t in let open Ctl_parser_types in match an with - | Stmt IntegerLiteral (_, _, _, integer_literal_info) -> + | Stmt (IntegerLiteral (_, _, _, integer_literal_info)) -> let value = integer_literal_info.Clang_ast_t.ili_value in ALVar.compare_str_with_alexp value al_exp - | Stmt StringLiteral (_, _, _, l) -> + | Stmt (StringLiteral (_, _, _, l)) -> ALVar.compare_str_with_alexp (String.concat ~sep:"" l) al_exp | _ -> false @@ -926,7 +926,7 @@ let is_method_called_by_superclass an = let open Clang_ast_t in let open Ctl_parser_types in match an with - | Stmt ObjCMessageExpr (_, _, _, obj_c_message_expr_info) -> ( + | Stmt (ObjCMessageExpr (_, _, _, obj_c_message_expr_info)) -> ( match obj_c_message_expr_info.omei_receiver_kind with `SuperInstance -> true | _ -> false ) | _ -> false diff --git a/infer/src/clang/cTL.ml b/infer/src/clang/cTL.ml index 287503023..fc69ed080 100644 --- a/infer/src/clang/cTL.ml +++ b/infer/src/clang/cTL.ml @@ -30,7 +30,7 @@ type transitions = | Cond | PointerToDecl (** stmt to decl *) | Protocol (** decl to decl *) - [@@deriving compare] +[@@deriving compare] let is_transition_to_successor trans = match trans with @@ -65,7 +65,7 @@ type t = | EU of transitions option * t * t | EH of ALVar.alexp list * t | ET of ALVar.alexp list * transitions option * t - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] @@ -120,8 +120,7 @@ type clause = | CPath of [`WhitelistPath | `BlacklistPath] * ALVar.t list type ctl_checker = - {id: string; (* Checker's id *) - definitions: clause list (* A list of let/set definitions *)} + {id: string; (* Checker's id *) definitions: clause list (* A list of let/set definitions *)} type al_file = { import_files: string list @@ -256,7 +255,7 @@ module Debug = struct let next_level = level + 1 in Format.fprintf fmt "%s%s%s %a@\n" spaces prefix node_name pp_node_info root ; match root with - | Stmt DeclStmt (_, stmts, ([(VarDecl _)] as var_decl)) -> + | Stmt (DeclStmt (_, stmts, ([VarDecl _] as var_decl))) -> (* handling special case of DeclStmt with VarDecl: emit the VarDecl node then emit the statements in DeclStmt as children of VarDecl. This is because despite being equal, the statements inside VarDecl and those @@ -339,11 +338,11 @@ module Debug = struct let highlight_style = match eval_node.content.eval_result with | Eval_undefined -> - ANSITerminal.([Bold]) + ANSITerminal.[Bold] | Eval_true -> - ANSITerminal.([Bold; green]) + ANSITerminal.[Bold; green] | Eval_false -> - ANSITerminal.([Bold; red]) + ANSITerminal.[Bold; red] in let ast_node_to_highlight = eval_node.content.ast_node in let ast_root, is_last_occurrence = @@ -656,25 +655,25 @@ let transition_decl_to_decl_via_accessor_for_property d desired_kind = match decl with ObjCPropertyDecl (_, _, opdi) -> predicate opdi | _ -> false in match decl_opt with - | Some ObjCCategoryImplDecl (_, _, _, _, ocidi) -> + | Some (ObjCCategoryImplDecl (_, _, _, _, ocidi)) -> let category_decls = match CAst_utils.get_decl_opt_with_decl_ref ocidi.ocidi_category_decl with - | Some ObjCCategoryDecl (_, _, decls, _, _) -> + | Some (ObjCCategoryDecl (_, _, decls, _, _)) -> List.filter ~f:decl_matches decls | _ -> [] in let class_decls = match CAst_utils.get_decl_opt_with_decl_ref ocidi.ocidi_class_interface with - | Some ObjCInterfaceDecl (_, _, decls, _, _) -> + | Some (ObjCInterfaceDecl (_, _, decls, _, _)) -> List.filter ~f:decl_matches decls | _ -> [] in category_decls @ class_decls - | Some ObjCImplementationDecl (_, _, _, _, oidi) -> ( + | Some (ObjCImplementationDecl (_, _, _, _, oidi)) -> ( match CAst_utils.get_decl_opt_with_decl_ref oidi.oidi_class_interface with - | Some ObjCInterfaceDecl (_, _, decls, _, _) -> + | Some (ObjCInterfaceDecl (_, _, decls, _, _)) -> List.filter ~f:decl_matches decls | _ -> [] ) @@ -787,9 +786,9 @@ let transition_stmt_to_decl_via_pointer stmt = let transition_via_parameters an = let open Clang_ast_t in match an with - | Decl ObjCMethodDecl (_, _, omdi) -> + | Decl (ObjCMethodDecl (_, _, omdi)) -> List.map ~f:(fun d -> Decl d) omdi.omdi_parameters - | Stmt ObjCMessageExpr (_, stmt_list, _, _) -> + | Stmt (ObjCMessageExpr (_, stmt_list, _, _)) -> List.map ~f:(fun stmt -> Stmt stmt) stmt_list | _ -> [] @@ -827,29 +826,29 @@ let transition_via_specified_parameter ~pos an key = let apply_decl arg = Decl arg in let apply_stmt arg = Stmt arg in match an with - | Stmt ObjCMessageExpr (_, stmt_list, _, omei) -> + | Stmt (ObjCMessageExpr (_, stmt_list, _, omei)) -> let method_name = omei.omei_selector in let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else parameter_of_corresp_name method_name in let arg_stmt_opt = parameter_of_corresp_key stmt_list key in node_opt_to_ast_node_list apply_stmt arg_stmt_opt - | Stmt CallExpr (_, _ :: args, _) -> + | Stmt (CallExpr (_, _ :: args, _)) -> let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else invalid_param_name_use () in let arg_stmt_opt = parameter_of_corresp_key args key in node_opt_to_ast_node_list apply_stmt arg_stmt_opt - | Decl ObjCMethodDecl (_, named_decl_info, omdi) -> + | Decl (ObjCMethodDecl (_, named_decl_info, omdi)) -> let method_name = named_decl_info.ni_name in let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else parameter_of_corresp_name method_name in let arg_decl_opt = parameter_of_corresp_key omdi.omdi_parameters key in node_opt_to_ast_node_list apply_decl arg_decl_opt - | Decl FunctionDecl (_, _, _, fdi) - | Decl CXXMethodDecl (_, _, _, fdi, _) - | Decl CXXConstructorDecl (_, _, _, fdi, _) -> + | Decl (FunctionDecl (_, _, _, fdi)) + | Decl (CXXMethodDecl (_, _, _, fdi, _)) + | Decl (CXXConstructorDecl (_, _, _, fdi, _)) -> let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else invalid_param_name_use () in @@ -866,9 +865,9 @@ 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, _) -> + | Stmt (InitListExpr (_, stmts, _)) -> List.map ~f:(fun stmt -> Stmt stmt) stmts | _ -> [] @@ -876,7 +875,7 @@ let transition_via_fields an = let field_has_name name node = match node with - | Decl FieldDecl (_, name_info, _, _) -> + | Decl (FieldDecl (_, name_info, _, _)) -> ALVar.compare_str_with_alexp name_info.Clang_ast_t.ni_name name | _ -> false @@ -902,10 +901,10 @@ let field_of_corresp_name_from_init_list_expr name init_nodes (expr_info: Clang_ let transition_via_field_name node name = let open Clang_ast_t in match node with - | Decl RecordDecl _ | Decl CXXRecordDecl _ -> + | Decl (RecordDecl _) | Decl (CXXRecordDecl _) -> let fields = transition_via_fields node in field_of_name name fields - | Stmt InitListExpr (_, stmts, expr_info) -> + | Stmt (InitListExpr (_, stmts, expr_info)) -> let nodes = List.map ~f:(fun stmt -> Stmt stmt) stmts in field_of_corresp_name_from_init_list_expr name nodes expr_info | _ -> diff --git a/infer/src/clang/cTL.mli b/infer/src/clang/cTL.mli index ebf264b3f..0436055c9 100644 --- a/infer/src/clang/cTL.mli +++ b/infer/src/clang/cTL.mli @@ -28,7 +28,7 @@ type transitions = | Cond | PointerToDecl (** stmt to decl *) | Protocol (** decl to decl *) - [@@deriving compare] +[@@deriving compare] (* In formulas below prefix "E" means "exists a path" "A" means "for all path" *) @@ -67,7 +67,7 @@ type t = | ET of ALVar.alexp list * transitions option * t (** ET[T][l] phi <=> there exists a descentant an of the current node such that an is of type in set T making a transition to a node an' via label l, such that in an phi holds. *) - [@@deriving compare] +[@@deriving compare] (* "set" clauses are used for defining mandatory variables that will be used by when reporting issues: eg for defining the condition. @@ -98,8 +98,7 @@ type clause = | CPath of [`WhitelistPath | `BlacklistPath] * ALVar.t list type ctl_checker = - {id: string; (* Checker's id *) - definitions: clause list (* A list of let/set definitions *)} + {id: string; (* Checker's id *) definitions: clause list (* A list of let/set definitions *)} type al_file = { import_files: string list diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index fb514544f..3f744676b 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -446,8 +446,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s L.(debug Capture Medium) "@\n\ WARNING: Missing translation of Uniry_Expression_Or_Trait of kind: %s . Expression \ - ignored, returned -1... @\n\ - " + ignored, returned -1... @\n" (Clang_ast_j.string_of_unary_expr_or_type_trait_kind k) ; {empty_res_trans with exps= [(Exp.minus_one, typ)]} @@ -528,8 +527,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s L.(debug Capture Verbose) "Type is '%s' @." (Typ.to_string class_typ) ; let class_tname = match CAst_utils.get_decl decl_ptr with - | Some FieldDecl ({di_parent_pointer}, _, _, _) - | Some ObjCIvarDecl ({di_parent_pointer}, _, _, _, _) -> ( + | Some (FieldDecl ({di_parent_pointer}, _, _, _)) + | Some (ObjCIvarDecl ({di_parent_pointer}, _, _, _, _)) -> ( match CAst_utils.get_decl_opt di_parent_pointer with | Some decl -> CType_decl.get_record_typename ~tenv:context.tenv decl @@ -552,7 +551,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 @@ -667,8 +666,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let open Clang_ast_t in let destruct_decl_ref_opt = match CAst_utils.get_decl_from_typ_ptr class_type_ptr with - | Some CXXRecordDecl (_, _, _, _, _, _, _, cxx_record_info) - | Some ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _) -> + | Some (CXXRecordDecl (_, _, _, _, _, _, _, cxx_record_info)) + | Some (ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _)) -> cxx_record_info.xrdi_destructor | _ -> None @@ -676,7 +675,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match destruct_decl_ref_opt with | Some decl_ref -> ( match CAst_utils.get_decl decl_ref.Clang_ast_t.dr_decl_pointer with - | Some CXXDestructorDecl _ -> + | Some (CXXDestructorDecl _) -> method_deref_trans ~is_inner_destructor trans_state pvar_trans_result decl_ref si `CXXDestructor | _ -> @@ -822,7 +821,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* evaluates an enum constant *) and enum_const_eval context enum_constant_pointer prev_enum_constant_opt zero = match CAst_utils.get_decl enum_constant_pointer with - | Some Clang_ast_t.EnumConstantDecl (_, _, _, enum_constant_decl_info) -> ( + | Some (Clang_ast_t.EnumConstantDecl (_, _, _, enum_constant_decl_info)) -> ( match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with | Some stmt -> expression_trans context stmt "WARNING: Expression in Enumeration constant not found@\n" @@ -851,7 +850,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let exp = enum_const_eval context enum_constant_pointer prev_enum_constant_opt zero in CAst_utils.update_enum_map enum_constant_pointer exp ; exp - with Not_found -> zero + with Caml.Not_found -> zero and enum_constant_trans trans_state decl_ref = @@ -958,11 +957,12 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s && List.length instr_bin > 0 in let extra_instrs, exp_to_parent = - if 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) + if + 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) then (* We are in this case when an assignment is inside *) (* another operator that creates a node. Eg. another *) @@ -1007,7 +1007,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s BE FIXED" in let callee_pname_opt = - match sil_fe with Exp.Const Const.Cfun pn -> Some pn | _ -> None + match sil_fe with Exp.Const (Const.Cfun pn) -> Some pn | _ -> None (* function pointer *) in (* we cannot translate the arguments of __builtin_object_size because preprocessing copies @@ -1041,8 +1041,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s CFrontend_config.incorrect_assumption __POS__ si.Clang_ast_t.si_source_range "In call to %a: stmt_list and res_trans_par.exps must have same size but they don't:@\n\ stmt_list(%d)=[%a]@\n\ - res_trans_par.exps(%d)=[%a]@\n\ - " Typ.Procname.pp procname (List.length params) (Pp.seq Exp.pp) + res_trans_par.exps(%d)=[%a]@\n" + Typ.Procname.pp procname (List.length params) (Pp.seq Exp.pp) (List.map ~f:fst params) (List.length params_stmt) (Pp.seq (Pp.to_string ~f:Clang_ast_j.string_of_stmt)) params_stmt @@ -1070,7 +1070,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let sil_method, _ = List.hd_exn result_trans_callee.exps in let callee_pname = match sil_method with - | Exp.Const Const.Cfun pn -> + | Exp.Const (Const.Cfun pn) -> pn | _ -> (* method pointer not implemented, this shouldn't happen but it does (t21762295) *) @@ -1215,8 +1215,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s raise (Self.SelfClassException {class_name; position= __POS__; source_range= si.Clang_ast_t.si_source_range}) - else if String.equal selector CFrontend_config.alloc - || String.equal selector CFrontend_config.new_str + else if + String.equal selector CFrontend_config.alloc + || String.equal selector CFrontend_config.new_str then match receiver_kind with | `Class qual_type -> @@ -1435,7 +1436,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s | _ -> assert false) vars_to_destroy - with Not_found -> + with Caml.Not_found -> L.(debug Capture Verbose) "@\n Variables that go out of scope are not found...@\n@." ; [] in @@ -1449,7 +1450,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s except if the statement ends with Return statemenent *) let destr_trans_result = match List.last stmt_list with - | Some Clang_ast_t.ReturnStmt _ -> + | Some (Clang_ast_t.ReturnStmt _) -> empty_res_trans | _ -> inject_destructors trans_state stmt_info @@ -1729,7 +1730,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let sil_loc = CLocation.get_sil_location stmt_info context in let open Clang_ast_t in match switch_stmt_list with - | [_; decl_stmt; cond; (CompoundStmt (stmt_info, stmt_list))] -> + | [_; decl_stmt; cond; CompoundStmt (stmt_info, stmt_list)] -> let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let trans_state' = {trans_state_pri with succ_nodes= []} in let res_trans_cond_tmp = instruction trans_state' cond in @@ -1771,30 +1772,30 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* returns list_of_cases * before_any_case_instrs *) let rec aux rev_stmt_list acc cases = match rev_stmt_list with - | (CaseStmt (info, a :: b :: (CaseStmt x) :: c)) :: rest -> + | CaseStmt (info, a :: b :: CaseStmt x :: c) :: rest -> (* case x: case y: ... *) if c <> [] (* empty case with nested case, then followed by some instructions *) then assert false ; let rest' = CaseStmt (info, [a; b]) :: rest in let rev_stmt_list' = CaseStmt x :: rest' in aux rev_stmt_list' acc cases - | (CaseStmt (info, a :: b :: (DefaultStmt x) :: c)) :: rest -> + | CaseStmt (info, a :: b :: DefaultStmt x :: c) :: rest -> (* case x: default: ... *) if c <> [] (* empty case with nested case, then followed by some instructions *) then assert false ; let rest' = CaseStmt (info, [a; b]) :: rest in let rev_stmt_list' = DefaultStmt x :: rest' in aux rev_stmt_list' acc cases - | (DefaultStmt (info, (CaseStmt x) :: c)) :: rest -> + | DefaultStmt (info, CaseStmt x :: c) :: rest -> (* default: case x: ... *) if c <> [] (* empty case with nested case, then followed by some instructions *) then assert false ; let rest' = DefaultStmt (info, []) :: rest in let rev_stmt_list' = CaseStmt x :: rest' in aux rev_stmt_list' acc cases - | (CaseStmt (info, a :: b :: c)) :: rest -> + | CaseStmt (info, a :: b :: c) :: rest -> aux rest [] (CaseStmt (info, a :: b :: c @ acc) :: cases) - | (DefaultStmt (info, c)) :: rest -> + | DefaultStmt (info, c) :: rest -> (* default is always the last in the list *) aux rest [] (DefaultStmt (info, c @ acc) :: cases) | x :: rest -> @@ -1856,7 +1857,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Procdesc.node_set_succs_exn context.procdesc prune_node_t case_entry_point [] ; Procdesc.node_set_succs_exn context.procdesc prune_node_f last_prune_nodes [] ; (case_entry_point, [prune_node_t; prune_node_f]) - | (DefaultStmt (stmt_info, default_content)) :: rest -> + | DefaultStmt (stmt_info, default_content) :: rest -> let sil_loc = CLocation.get_sil_location stmt_info context in let placeholder_entry_point = create_node (Procdesc.Node.Stmt_node "DefaultStmt_placeholder") [] sil_loc context @@ -2193,7 +2194,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Option.map ~f:(fun qt -> qt.Clang_ast_t.qt_type_ptr) qual_type |> Option.find_map ~f:CAst_utils.get_type with - | Some Clang_ast_t.VariableArrayType (_, _, stmt_pointer) -> + | Some (Clang_ast_t.VariableArrayType (_, _, stmt_pointer)) -> (* Set the dynamic length of the variable length array. Variable length array cannot have an initialization expression. *) init_dynamic_array trans_state var_exp_typ var_stmt_info stmt_pointer @@ -2252,7 +2253,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match var_decls with | [] -> {empty_res_trans with root_nodes= next_nodes} - | (VarDecl (di, n, qt, vdi)) :: var_decls' -> + | VarDecl (di, n, qt, vdi) :: var_decls' -> (* Var are defined when procdesc is created, here we only take care of initialization*) let res_trans_vd = collect_all_decl trans_state var_decls' next_nodes stmt_info in let res_trans_tmp = do_var_dec (di, n, qt, vdi) res_trans_vd.root_nodes in @@ -2262,9 +2263,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s ; instrs= res_trans_tmp.instrs @ res_trans_vd.instrs ; exps= [] ; initd_exps= res_trans_tmp.initd_exps @ res_trans_vd.initd_exps } - | (CXXRecordDecl _) :: var_decls' + | CXXRecordDecl _ :: var_decls' (*C++/C record decl treated in the same way *) - | (RecordDecl _) :: var_decls' -> + | RecordDecl _ :: var_decls' -> (* Record declaration is done in the beginning when procdesc is defined.*) collect_all_decl trans_state var_decls' next_nodes stmt_info | decl :: _ -> @@ -2282,11 +2283,11 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let res_trans = let open Clang_ast_t in match decl_list with - | (VarDecl _) :: _ + | VarDecl _ :: _ (* Case for simple variable declarations*) - | (CXXRecordDecl _) :: _ + | CXXRecordDecl _ :: _ (*C++/C record decl treated in the same way *) - | (RecordDecl _) :: _ -> + | RecordDecl _ :: _ -> (* Case for struct *) collect_all_decl trans_state decl_list succ_nodes stmt_info | (TypedefDecl _ | TypeAliasDecl _ | UsingDecl _ | UsingDirectiveDecl _) :: _ -> @@ -2346,7 +2347,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let rec do_semantic_elements el = let open Clang_ast_t in match el with - | (OpaqueValueExpr _) :: el' -> + | OpaqueValueExpr _ :: el' -> do_semantic_elements el' | stmt :: _ -> instruction trans_state stmt @@ -2414,8 +2415,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let stmt = extract_stmt_from_singleton stmt_list "WARNING: We expect only one element in stmt list defining the operand in UnaryOperator. \ - NEED FIXING@\n\ - " + NEED FIXING@\n" in let trans_state' = {trans_state_pri with succ_nodes= []} in let res_trans_stmt = instruction trans_state' stmt in @@ -2528,8 +2528,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s L.(debug Capture Verbose) "@\n\ WARNING: Missing translation of Return Expression. Return Statement ignored. Need \ - fixing!@\n\ - " ; + fixing!@\n" ; {empty_res_trans with root_nodes= succ_nodes} in (* We expect a return with only one expression *) @@ -2777,14 +2776,14 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let res_trans_init = match stmt_opt with - | Some InitListExpr _ -> + | Some (InitListExpr _) -> [init_expr_trans trans_state_init var_exp_typ init_stmt_info stmt_opt] | _ when is_dyn_array && Typ.is_pointer_to_cpp_class typ -> (* NOTE: this is heuristic to initialize C++ objects when the size of dynamic array is constant, it doesn't do anything for non-const lengths, it should be translated as a loop *) let rec create_stmts stmt_opt size_exp_opt = match (stmt_opt, size_exp_opt) with - | Some stmt, Some Exp.Const Const.Cint n when not (IntLit.iszero n) -> + | Some stmt, Some (Exp.Const (Const.Cint n)) when not (IntLit.iszero n) -> let n_minus_1 = Some (Exp.Const (Const.Cint (IntLit.sub n IntLit.one))) in stmt :: create_stmts stmt_opt n_minus_1 | _ -> @@ -3188,8 +3187,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s | MemberExpr (stmt_info, stmt_list, _, member_expr_info) -> memberExpr_trans trans_state stmt_info stmt_list member_expr_info | UnaryOperator (stmt_info, stmt_list, expr_info, unary_operator_info) -> - if is_logical_negation_of_int trans_state.context.CContext.tenv expr_info - unary_operator_info + if + is_logical_negation_of_int trans_state.context.CContext.tenv expr_info + unary_operator_info then let conditional = Ast_expressions.trans_negation_with_conditional stmt_info expr_info stmt_list diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index 32e93f3f3..4e3878646 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -102,7 +102,7 @@ end module GotoLabel = struct let find_goto_label context label sil_loc = - try Hashtbl.find context.CContext.label_map label with Not_found -> + try Hashtbl.find context.CContext.label_map label with Caml.Not_found -> let node_name = Format.sprintf "GotoLabel_%s" label in let new_node = Nodes.create_node (Procdesc.Node.Skip_node node_name) [] sil_loc context in Hashtbl.add context.CContext.label_map label new_node ; @@ -134,11 +134,11 @@ type priority_node = Free | Busy of Clang_ast_t.pointer type trans_state = { context: CContext.t ; (* current context of the translation *) - succ_nodes: Procdesc.Node.t list + succ_nodes: Procdesc.Node.t list ; (* successor nodes in the cfg *) - continuation: continuation option + continuation: continuation option ; (* current continuation *) - priority: priority_node + priority: priority_node ; var_exp_typ: (Exp.t * Typ.t) option ; opaque_exp: (Exp.t * Typ.t) option } @@ -146,13 +146,13 @@ type trans_state = type trans_result = { root_nodes: Procdesc.Node.t list ; (* Top cfg nodes (root) created by the translation *) - leaf_nodes: Procdesc.Node.t list + leaf_nodes: Procdesc.Node.t list ; (* Bottom cfg nodes (leaf) created by the translate *) - instrs: Sil.instr list + instrs: Sil.instr list ; (* list of SIL instruction that need to be placed in cfg nodes of the parent*) - exps: (Exp.t * Typ.t) list + exps: (Exp.t * Typ.t) list ; (* SIL expressions resulting from translation of clang stmt *) - initd_exps: Exp.t list + initd_exps: Exp.t list ; is_cpp_call_virtual: bool } (* Empty result translation *) @@ -584,10 +584,11 @@ let extract_stmt_from_singleton stmt_list warning_string = module Self = struct - exception SelfClassException of - { class_name: Typ.Name.t - ; position: Logging.ocaml_pos - ; source_range: Clang_ast_t.source_range } + exception + SelfClassException of + { class_name: Typ.Name.t + ; position: Logging.ocaml_pos + ; source_range: Clang_ast_t.source_range } let add_self_parameter_for_super_instance stmt_info context procname loc mei = if is_superinstance mei then diff --git a/infer/src/clang/cTrans_utils.mli b/infer/src/clang/cTrans_utils.mli index fb9349f70..8b733bb71 100644 --- a/infer/src/clang/cTrans_utils.mli +++ b/infer/src/clang/cTrans_utils.mli @@ -155,10 +155,11 @@ end (** This module handles the translation of the variable self which is challenging because self is used both as a variable in instance method calls and also as a type in class method calls. *) module Self : sig - exception SelfClassException of - { class_name: Typ.Name.t - ; position: Logging.ocaml_pos - ; source_range: Clang_ast_t.source_range } + exception + SelfClassException of + { class_name: Typ.Name.t + ; position: Logging.ocaml_pos + ; 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 diff --git a/infer/src/clang/cType_to_sil_type.ml b/infer/src/clang/cType_to_sil_type.ml index 70b90bd45..504951ef8 100644 --- a/infer/src/clang/cType_to_sil_type.ml +++ b/infer/src/clang/cType_to_sil_type.ml @@ -98,7 +98,7 @@ and type_desc_of_attr_type translate_decl tenv type_info attr_info = match type_info.Clang_ast_t.ti_desugared_type with | Some type_ptr -> ( match CAst_utils.get_type type_ptr with - | Some Clang_ast_t.ObjCObjectPointerType (_, qual_type) -> + | Some (Clang_ast_t.ObjCObjectPointerType (_, qual_type)) -> let typ = qual_type_to_sil_type translate_decl tenv qual_type in Typ.Tptr (typ, pointer_attribute_of_objc_attribute attr_info) | _ -> @@ -166,7 +166,8 @@ and type_desc_of_c_type translate_decl tenv c_type : Typ.desc = 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 Not_found -> + try Clang_ast_extend.TypePointerMap.find typ !CFrontend_config.sil_types_map + with Caml.Not_found -> match CAst_utils.get_decl decl_ptr with | Some (CXXRecordDecl _ as d) | Some (RecordDecl _ as d) @@ -191,7 +192,7 @@ and decl_ptr_to_type_desc translate_decl tenv decl_ptr : Typ.desc = 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 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 diff --git a/infer/src/clang/ctl_parser_types.ml b/infer/src/clang/ctl_parser_types.ml index 26e20f974..f0512d7bd 100644 --- a/infer/src/clang/ctl_parser_types.ml +++ b/infer/src/clang/ctl_parser_types.ml @@ -23,38 +23,38 @@ let rec ast_node_name an = n.Clang_ast_t.ni_name | None -> "" ) - | Stmt DeclRefExpr (_, _, _, drti) -> ( + | Stmt (DeclRefExpr (_, _, _, drti)) -> ( match drti.drti_decl_ref with | Some dr -> let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in ndi.ni_name | _ -> "" ) - | Stmt ObjCIvarRefExpr (_, _, _, obj_c_ivar_ref_expr_info) -> + | Stmt (ObjCIvarRefExpr (_, _, _, obj_c_ivar_ref_expr_info)) -> let ndi, _, _ = CAst_utils.get_info_from_decl_ref obj_c_ivar_ref_expr_info.ovrei_decl_ref in ndi.ni_name - | Stmt ObjCMessageExpr (_, _, _, {omei_selector}) -> + | Stmt (ObjCMessageExpr (_, _, _, {omei_selector})) -> omei_selector - | Stmt IntegerLiteral (_, _, _, integer_literal_info) -> + | Stmt (IntegerLiteral (_, _, _, integer_literal_info)) -> integer_literal_info.ili_value - | Stmt CStyleCastExpr (_, _, _, cast_expr_info, _) -> ( + | Stmt (CStyleCastExpr (_, _, _, cast_expr_info, _)) -> ( match cast_expr_info.cei_cast_kind with `NullToPointer -> "nil" | _ -> "" ) - | Stmt ObjCSubscriptRefExpr (_, [stmt; stmt_index], _, _) -> + | Stmt (ObjCSubscriptRefExpr (_, [stmt; stmt_index], _, _)) -> ast_node_name (Stmt stmt) ^ "[" ^ ast_node_name (Stmt stmt_index) ^ "]" - | Stmt OpaqueValueExpr (_, _, _, opaque_value_expr_info) -> ( + | Stmt (OpaqueValueExpr (_, _, _, opaque_value_expr_info)) -> ( match opaque_value_expr_info.ovei_source_expr with | Some stmt -> ast_node_name (Stmt stmt) | None -> "" ) - | Stmt ImplicitCastExpr (_, [stmt], _, _) - | Stmt PseudoObjectExpr (_, stmt :: _, _) - | Stmt ParenExpr (_, [stmt], _) -> + | Stmt (ImplicitCastExpr (_, [stmt], _, _)) + | Stmt (PseudoObjectExpr (_, stmt :: _, _)) + | Stmt (ParenExpr (_, [stmt], _)) -> ast_node_name (Stmt stmt) - | Stmt CallExpr (_, func :: _, _) -> + | Stmt (CallExpr (_, func :: _, _)) -> let func_str = ast_node_name (Stmt func) in func_str ^ "(...)" - | Stmt ObjCPropertyRefExpr (_, [stmt], _, obj_c_property_ref_expr_info) -> + | Stmt (ObjCPropertyRefExpr (_, [stmt], _, obj_c_property_ref_expr_info)) -> let property_str = match obj_c_property_ref_expr_info.oprei_kind with | `MethodRef obj_c_method_ref_info -> ( @@ -69,11 +69,11 @@ let rec ast_node_name an = match decl_ref.dr_name with Some name -> name.ni_name | None -> "" in ast_node_name (Stmt stmt) ^ "." ^ property_str - | Stmt StringLiteral (_, _, _, l) -> + | Stmt (StringLiteral (_, _, _, l)) -> String.concat ~sep:"" l - | Stmt ObjCStringLiteral (_, [stmt], _) -> + | Stmt (ObjCStringLiteral (_, [stmt], _)) -> "@" ^ ast_node_name (Stmt stmt) - | Stmt ObjCBoxedExpr (_, [stmt], _, objc_boxed_expr_info) -> + | Stmt (ObjCBoxedExpr (_, [stmt], _, objc_boxed_expr_info)) -> let selector = match objc_boxed_expr_info.obei_boxing_method with Some sel -> sel | None -> "" in @@ -280,7 +280,7 @@ type builtin_kind = | ObjCId (** id *) | ObjCClass (** Class *) | ObjCSel (** SEL *) - [@@deriving compare] +[@@deriving compare] (* | OCLSampler | OCLEvent | OCLClkEvent | OCLQueue | OCLNDRange | OCLReserveID | Dependent | Overload | BoundMember | PseudoObject @@ -358,8 +358,7 @@ type abs_ctype = let display_equality_warning () = L.(debug Linters Medium) "[WARNING:] Type Comparison failed... This might indicate that the types are different or the \ - specified type is internally represented in a different way and therefore not recognized.@\n\ - " + specified type is internally represented in a different way and therefore not recognized.@\n" let rec abs_ctype_to_string t = @@ -488,8 +487,7 @@ and c_type_equal c_type abs_ctype = "@\n\ Comparing c_type/abs_ctype for equality... Type compared: @\n\ c_type = `%s` @\n\ - abs_ctype =`%s`@\n\ - " + abs_ctype =`%s`@\n" (Clang_ast_j.string_of_c_type c_type) (abs_ctype_to_string abs_ctype) ; let open Clang_ast_t in @@ -524,17 +522,17 @@ and c_type_equal c_type abs_ctype = let rec typ_string_of_type_ptr type_ptr = let open Clang_ast_t in match CAst_utils.get_type type_ptr with - | Some BuiltinType (_, bt) -> ( + | Some (BuiltinType (_, bt)) -> ( match List.Assoc.find ~equal:Poly.equal builtin_type_kind_assoc bt with | Some abt -> builtin_kind_to_string abt | None -> "" ) - | Some PointerType (_, qt) | Some ObjCObjectPointerType (_, qt) -> + | Some (PointerType (_, qt)) | Some (ObjCObjectPointerType (_, qt)) -> typ_string_of_type_ptr qt.qt_type_ptr ^ "*" - | Some ObjCInterfaceType (_, pointer) -> + | Some (ObjCInterfaceType (_, pointer)) -> Option.value ~default:"" (typename_to_string pointer) - | Some TypedefType (_, tdi) -> + | Some (TypedefType (_, tdi)) -> Option.value ~default:"" (typename_to_string tdi.tti_decl_ptr) | _ -> "" diff --git a/infer/src/clang/objcCategory_decl.ml b/infer/src/clang/objcCategory_decl.ml index b97fb5940..ea19d7262 100644 --- a/infer/src/clang/objcCategory_decl.ml +++ b/infer/src/clang/objcCategory_decl.ml @@ -55,7 +55,7 @@ let get_base_class_name_from_category decl = match base_class_pointer_opt with | Some decl_ref -> ( match CAst_utils.get_decl decl_ref.Clang_ast_t.dr_decl_pointer with - | Some ObjCInterfaceDecl (_, name_info, _, _, _) -> + | Some (ObjCInterfaceDecl (_, name_info, _, _, _)) -> Some (Typ.Name.Objc.from_qual_name (CAst_utils.get_qualified_name name_info)) | _ -> None ) diff --git a/infer/src/clang/tableaux.ml b/infer/src/clang/tableaux.ml index 62ab431ae..088e24791 100644 --- a/infer/src/clang/tableaux.ml +++ b/infer/src/clang/tableaux.ml @@ -50,7 +50,8 @@ let add_formula_to_valuation k s = let get_node_valuation k = - try NodesValuationHashtbl.find k !global_nodes_valuation with Not_found -> CTLFormulaSet.empty + try NodesValuationHashtbl.find k !global_nodes_valuation with Caml.Not_found -> + CTLFormulaSet.empty let is_decl_allowed lcxt decl = @@ -88,7 +89,7 @@ let update_linter_context_map an linter_context_map = (*L.(debug Linters Medium) "@\n Updating linter map for node %i with '%b'" (Ctl_parser_types.ast_node_pointer an) res; *) ClosureHashtbl.add phi res acc_map - with Not_found -> + with Caml.Not_found -> Logging.die InternalError "Every linter condition should have an entry in the map." ) | _ -> acc_map @@ -253,15 +254,15 @@ let add_valid_formulae an checker lcxt cl = add_in_set phi acc_set | EU (trans, phi1, phi2) when is_valid phi2 acc_set - || is_valid phi1 acc_set && exists_formula_in_successor_nodes an checker trans phi -> + || (is_valid phi1 acc_set && exists_formula_in_successor_nodes an checker trans phi) -> add_in_set phi acc_set | AG _ | AX _ | AF _ | AU _ | EH _ | ET _ | Implies _ -> Logging.die InternalError "@\n \ We should not have operators AG, AX, AF, AU, EH, ET.\n \ Failing with formula @\n \ - %a@\n\ - " CTL.Debug.pp_formula phi + %a@\n" + CTL.Debug.pp_formula phi | _ -> acc_set in @@ -301,7 +302,7 @@ let report_issue an lcxt linter (*npo_condition*) = let check_linter_map linter_map_contex phi = - try ClosureHashtbl.find phi linter_map_contex with Not_found -> + try ClosureHashtbl.find phi linter_map_contex with Caml.Not_found -> Logging.die InternalError "@\n ERROR: linter_map must have an entry for each formula" @@ -325,7 +326,7 @@ let build_valuation an lcxt linter_map_context = build_transition_set npo_condition ; *) let normalized_condition = normalize linter.condition in let is_state_only, cl = - try ClosureHashtbl.find normalized_condition !closure_map with Not_found -> + try ClosureHashtbl.find normalized_condition !closure_map with Caml.Not_found -> let cl' = formula_closure normalized_condition in let is_state_only = is_state_only_formula normalized_condition in (*print_closure cl' ; *) @@ -340,7 +341,8 @@ let build_valuation an lcxt linter_map_context = in List.iter ~f:(fun (linter: linter) -> - if CIssue.should_run_check linter.issue_desc.CIssue.mode - && check_linter_map linter_map_context linter.condition + if + CIssue.should_run_check linter.issue_desc.CIssue.mode + && check_linter_map linter_map_context linter.condition then do_one_check linter ) !parsed_linters diff --git a/infer/src/concurrency/RacerD.ml b/infer/src/concurrency/RacerD.ml index 03290d64b..482697bd5 100644 --- a/infer/src/concurrency/RacerD.ml +++ b/infer/src/concurrency/RacerD.ml @@ -67,10 +67,10 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let ret_access_path = (ret, []) in let get_ownership formal_index acc = match List.nth actuals formal_index with - | Some HilExp.AccessExpression access_expr -> + | Some (HilExp.AccessExpression access_expr) -> let actual_ap = AccessExpression.to_access_path access_expr in OwnershipDomain.get_owned actual_ap ownership |> OwnershipAbstractValue.join acc - | Some HilExp.Constant _ -> + | Some (HilExp.Constant _) -> acc | _ -> OwnershipAbstractValue.unowned @@ -113,7 +113,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct 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 @@ -124,13 +124,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | _ -> false in - if call_flags.cf_interface && Typ.Procname.is_java 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 + if + call_flags.cf_interface && Typ.Procname.is_java 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 (is_receiver_safe actuals) + && 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 let pre = AccessData.make locks threads False proc_data.pdesc in @@ -198,13 +199,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct false in match List.rev accesses with - | (AccessPath.FieldAccess base_field) :: (AccessPath.FieldAccess container_field) :: _ + | AccessPath.FieldAccess base_field :: AccessPath.FieldAccess container_field :: _ when Typ.Procname.is_java callee_pname -> let base_typename = Typ.Name.Java.from_string (Typ.Fieldname.Java.get_class base_field) in is_annotated_synchronized base_typename container_field tenv - | [(AccessPath.FieldAccess container_field)] -> ( + | [AccessPath.FieldAccess container_field] -> ( match base_typ.desc with | Typ.Tstruct base_typename | Tptr ({Typ.desc= Tstruct base_typename}, _) -> is_annotated_synchronized base_typename container_field tenv @@ -251,7 +252,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let open RacerDConfig in let get_receiver_ap actuals = match List.hd actuals with - | Some HilExp.AccessExpression receiver_expr -> + | Some (HilExp.AccessExpression receiver_expr) -> AccessExpression.to_access_path receiver_expr | _ -> L.(die InternalError) @@ -547,10 +548,11 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in if Models.is_box callee_pname then match (ret_opt, actuals) with - | Some ret, (HilExp.AccessExpression actual_access_expr) :: _ -> + | Some ret, HilExp.AccessExpression actual_access_expr :: _ -> let actual_ap = AccessExpression.to_access_path actual_access_expr in - if AttributeMapDomain.has_attribute actual_ap Functional - astate.attribute_map + if + AttributeMapDomain.has_attribute actual_ap Functional + astate.attribute_map then (* TODO: check for constants, which are functional? *) let attribute_map = @@ -584,9 +586,10 @@ module TransferFunctions (CFG : ProcCfg.S) = struct add_if_annotated Models.is_functional Functional astate_callee.attribute_map in let ownership = - if PatternMatch.override_exists - (Models.has_return_annot Annotations.ia_is_returns_ownership) - tenv callee_pname + if + PatternMatch.override_exists + (Models.has_return_annot Annotations.ia_is_returns_ownership) + tenv callee_pname then OwnershipDomain.add (ret, []) OwnershipAbstractValue.owned astate_callee.ownership else astate_callee.ownership @@ -742,8 +745,8 @@ let analyze_procedure {Callbacks.proc_desc; get_proc_desc; tenv; summary} = let threads = if Models.runs_on_ui_thread proc_desc || Models.is_thread_confined_method tenv proc_desc then ThreadsDomain.AnyThreadButSelf - else if Procdesc.is_java_synchronized proc_desc - || Models.is_marked_thread_safe proc_desc tenv + else if + Procdesc.is_java_synchronized proc_desc || Models.is_marked_thread_safe proc_desc tenv then ThreadsDomain.AnyThread else ThreadsDomain.NoThread in @@ -817,7 +820,7 @@ let analyze_procedure {Callbacks.proc_desc; get_proc_desc; tenv; summary} = in let return_ownership = OwnershipDomain.get_owned return_var_ap ownership in let return_attributes = - try AttributeMapDomain.find return_var_ap attribute_map with Not_found -> + try AttributeMapDomain.find return_var_ap attribute_map with Caml.Not_found -> AttributeSetDomain.empty in let post = {threads; locks; accesses; return_ownership; return_attributes; wobbly_paths} in @@ -875,12 +878,14 @@ let get_reporting_explanation_java report_kind tenv pname thread = ( IssueType.thread_safety_violation , F.asprintf "%s, so we assume that this method can run in parallel with other non-private methods \ - in the class (including itself)." threadsafe_explanation ) + in the class (including itself)." + threadsafe_explanation ) | _, Some threadsafe_explanation -> ( IssueType.thread_safety_violation , F.asprintf "%s. Although this access is not known to run on a background thread, it may happen in \ - parallel with another access that does." threadsafe_explanation ) + parallel with another access that does." + threadsafe_explanation ) | _, None -> (* failed to explain based on @ThreadSafe annotation; have to justify using background thread *) if RacerDDomain.ThreadsDomain.is_any thread then @@ -986,7 +991,7 @@ let make_trace ~report_kind original_path pdesc = | ReadWriteRace conflict_sink -> make_with_conflicts conflict_sink original_trace ~label1:"" ~label2:"" - | WriteWriteRace Some conflict_sink -> + | WriteWriteRace (Some conflict_sink) -> make_with_conflicts conflict_sink original_trace ~label1:"" ~label2:"" | WriteWriteRace None | UnannotatedInterface -> @@ -1026,12 +1031,10 @@ let get_contaminated_race_message access wobbly_paths = in Option.map wobbly_path_opt ~f:(fun (wobbly_path, access_path) -> F.asprintf - "@\n\ - \n\ + "@\n\n\ Note that the prefix path %a has been contaminated during the execution, so the reported \ - race on %a might be a false positive.@\n\ - \n\ - " AccessPath.pp wobbly_path AccessPath.pp access_path ) + race on %a might be a false positive.@\n\n" + AccessPath.pp wobbly_path AccessPath.pp access_path ) let report_thread_safety_violation tenv pdesc ~make_description ~report_kind access thread @@ -1052,8 +1055,9 @@ let report_thread_safety_violation tenv pdesc ~make_description ~report_kind acc For C++ it is difficult to understand error messages when access path starts with a logical variable or a temporary variable. We want to skip the reports for now until we find a solution *) - if not Config.filtering - || if Typ.Procname.is_java pname then is_full_trace else is_pvar_base initial_sink + if + not Config.filtering + || if Typ.Procname.is_java pname then is_full_trace else is_pvar_base initial_sink then let final_sink_site = PathDomain.Sink.call_site final_sink in let initial_sink_site = PathDomain.Sink.call_site initial_sink in @@ -1226,8 +1230,9 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi else match TraceElem.kind access with | Access.InterfaceCall unannoted_call_pname -> - if AccessData.is_unprotected precondition && ThreadsDomain.is_any threads - && Models.is_marked_thread_safe procdesc tenv + if + AccessData.is_unprotected precondition && ThreadsDomain.is_any threads + && Models.is_marked_thread_safe procdesc tenv then ( (* un-annotated interface call + no lock in method marked thread-safe. warn *) report_unannotated_interface_violation tenv procdesc access threads @@ -1252,8 +1257,9 @@ let report_unsafe_accesses (aggregated_access_map: reported_access list AccessLi else None ) accesses in - if AccessData.is_unprotected precondition - && (not (List.is_empty writes_on_background_thread) || ThreadsDomain.is_any threads) + if + AccessData.is_unprotected precondition + && (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 @@ -1409,7 +1415,7 @@ module SyntacticQuotientedAccessListMap : QuotientedAccessListMap = struct let empty = M.empty let add k d m = - let ds = try M.find k m with Not_found -> [] in + let ds = try M.find k m with Caml.Not_found -> [] in M.add k (d :: ds) m @@ -1424,7 +1430,7 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct let add = AccessListMap.add let add k d m = - let ds = try AccessListMap.find k m with Not_found -> [] in + let ds = try AccessListMap.find k m with Caml.Not_found -> [] in add k (d :: ds) m @@ -1572,7 +1578,9 @@ let aggregate_by_class file_env = | _ -> "unknown" in - let bucket = try String.Map.find_exn acc classname with Not_found -> [] in + let bucket = + try String.Map.find_exn acc classname with Not_found_s _ | Caml.Not_found -> [] + in String.Map.set ~key:classname ~data:(proc :: bucket) acc ) ~init:String.Map.empty diff --git a/infer/src/concurrency/RacerDDomain.ml b/infer/src/concurrency/RacerDDomain.ml index f63f8f3be..cecb98f1e 100644 --- a/infer/src/concurrency/RacerDDomain.ml +++ b/infer/src/concurrency/RacerDDomain.ml @@ -17,7 +17,7 @@ module Access = struct | ContainerRead of AccessPath.t * Typ.Procname.t | ContainerWrite of AccessPath.t * Typ.Procname.t | InterfaceCall of Typ.Procname.t - [@@deriving compare] + [@@deriving compare] let suffix_matches (_, accesses1) (_, accesses2) = match (List.rev accesses1, List.rev accesses2) with @@ -169,7 +169,7 @@ module LocksDomain = struct not (is_empty astate) - let lookup_count lock astate = try find lock astate with Not_found -> LockCount.empty + let lookup_count lock astate = try find lock astate with Caml.Not_found -> LockCount.empty let add_lock astate = let count = lookup_count the_only_lock astate in @@ -182,7 +182,7 @@ module LocksDomain = struct let count' = LockCount.decrement count in if LockCount.is_empty count' then remove the_only_lock astate else add the_only_lock count' astate - with Not_found -> astate + with Caml.Not_found -> astate let integrate_summary ~caller_astate ~callee_astate = @@ -330,7 +330,7 @@ module OwnershipDomain = struct (* Helper function used by both is_owned and get_owned. Not exported.*) let get_owned_shallow access_path astate = - try find access_path astate with Not_found -> OwnershipAbstractValue.Unowned + try find access_path astate with Caml.Not_found -> OwnershipAbstractValue.Unowned (*deep ownership model where only a prefix needs to be owned in the astate*) @@ -359,7 +359,7 @@ OwnedIf in the astate, else UnOwned *) let get_owned access_path astate = if is_owned access_path astate then OwnershipAbstractValue.Owned - else try find access_path astate with Not_found -> OwnershipAbstractValue.Unowned + else try find access_path astate with Caml.Not_found -> OwnershipAbstractValue.Unowned let find = `Use_get_owned_instead @@ -373,7 +373,7 @@ module AttributeMapDomain = struct let has_attribute access_path attribute t = - try find access_path t |> AttributeSetDomain.mem attribute with Not_found -> false + try find access_path t |> AttributeSetDomain.mem attribute with Caml.Not_found -> false let get_choices access_path t = @@ -382,12 +382,12 @@ module AttributeMapDomain = struct List.filter_map ~f:(function Attribute.Choice c -> Some c | _ -> None) (AttributeSetDomain.elements attributes) - with Not_found -> [] + with Caml.Not_found -> [] let add_attribute access_path attribute t = let attribute_set = - (try find access_path t with Not_found -> AttributeSetDomain.empty) + (try find access_path t with Caml.Not_found -> AttributeSetDomain.empty) |> AttributeSetDomain.add attribute in add access_path attribute_set t @@ -432,12 +432,15 @@ module AccessDomain = struct include AbstractDomain.Map (AccessData) (PathDomain) let add_access precondition access_path t = - let precondition_accesses = try find precondition t with Not_found -> PathDomain.empty in + let precondition_accesses = + try find precondition t with Caml.Not_found -> PathDomain.empty + in let precondition_accesses' = PathDomain.add_sink access_path precondition_accesses in add precondition precondition_accesses' t - let get_accesses precondition t = try find precondition t with Not_found -> PathDomain.empty + let get_accesses precondition t = + try find precondition t with Caml.Not_found -> PathDomain.empty end module StabilityDomain = struct @@ -620,8 +623,8 @@ let pp_summary fmt {threads; locks; accesses; return_ownership; return_attribute Accesses %a @\n\ Ownership: %a @\n\ Return Attributes: %a @\n\ - Wobbly Paths: %a@\n\ - " ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses + Wobbly Paths: %a@\n" + ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipAbstractValue.pp return_ownership AttributeSetDomain.pp return_attributes StabilityDomain.pp wobbly_paths @@ -632,8 +635,8 @@ let pp fmt {threads; locks; accesses; ownership; attribute_map; wobbly_paths} = Accesses %a @\n \ Ownership: %a @\n\ Attributes: %a @\n\ - Non-stable Paths: %a@\n\ - " ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipDomain.pp + Non-stable Paths: %a@\n" + ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipDomain.pp ownership AttributeMapDomain.pp attribute_map StabilityDomain.pp wobbly_paths @@ -642,7 +645,7 @@ let rec attributes_of_expr attribute_map e = match e with | HilExp.AccessExpression access_expr -> ( try AttributeMapDomain.find (AccessExpression.to_access_path access_expr) attribute_map - with Not_found -> AttributeSetDomain.empty ) + with Caml.Not_found -> AttributeSetDomain.empty ) | Constant _ -> AttributeSetDomain.of_list [Attribute.Functional] | Exception expr (* treat exceptions as transparent wrt attributes *) | Cast (_, expr) -> diff --git a/infer/src/concurrency/RacerDDomain.mli b/infer/src/concurrency/RacerDDomain.mli index d660512f9..bedc465d2 100644 --- a/infer/src/concurrency/RacerDDomain.mli +++ b/infer/src/concurrency/RacerDDomain.mli @@ -18,7 +18,7 @@ module Access : sig | ContainerWrite of AccessPath.t * Typ.Procname.t (** Write to container object *) | InterfaceCall of Typ.Procname.t (** Call to method of interface not annotated with @ThreadSafe *) - [@@deriving compare] + [@@deriving compare] val matches : caller:t -> callee:t -> bool (** returns true if the caller access matches the callee access after accounting for mismatch @@ -97,7 +97,7 @@ module OwnershipAbstractValue : sig | Owned (** Owned value; bottom of the lattice *) | OwnedIf of IntSet.t (** Owned if the formals at the given indexes are owned in the caller *) | Unowned (** Unowned value; top of the lattice *) - [@@deriving compare] + [@@deriving compare] val owned : astate @@ -123,14 +123,14 @@ module Choice : sig type t = | OnMainThread (** the current procedure is running on the main thread *) | LockHeld (** a lock is currently held *) - [@@deriving compare] + [@@deriving compare] end module Attribute : sig type t = | Functional (** holds a value returned from a callee marked @Functional *) | Choice of Choice.t (** holds a boolean choice variable *) - [@@deriving compare] + [@@deriving compare] val pp : F.formatter -> t -> unit @@ -161,7 +161,7 @@ module AccessData : sig (** Conjunction of "formal index must be owned" predicates. true if empty *) | False - [@@deriving compare] + [@@deriving compare] val is_true : t -> bool (** return [true] if the precondition evaluates to true *) @@ -169,9 +169,8 @@ module AccessData : sig val pp : F.formatter -> t -> unit [@@warning "-32"] end - type t = private - {thread: bool; lock: bool; ownership_precondition: Precondition.t} - [@@deriving compare] + type t = private {thread: bool; lock: bool; ownership_precondition: Precondition.t} + [@@deriving compare] val make : LocksDomain.astate -> ThreadsDomain.astate -> Precondition.t -> Procdesc.t -> t diff --git a/infer/src/concurrency/starvation.ml b/infer/src/concurrency/starvation.ml index 06658ad1d..f2a44c5e7 100644 --- a/infer/src/concurrency/starvation.ml +++ b/infer/src/concurrency/starvation.ml @@ -55,7 +55,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let is_formal base = FormalMap.is_formal base extras in let get_path actuals = match actuals with - | (HilExp.AccessExpression access_exp) :: _ -> ( + | HilExp.AccessExpression access_exp :: _ -> ( match AccessExpression.to_access_path access_exp with | (((Var.ProgramVar pvar, _) as base), _) as path when is_formal base || Pvar.is_global pvar -> @@ -63,7 +63,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | _ -> (* ignore paths on local or logical variables *) None ) - | (HilExp.Constant Const.Cclass class_id) :: _ -> + | HilExp.Constant (Const.Cclass class_id) :: _ -> (* this is a synchronized/lock(CLASSNAME.class) construct *) Some (lock_of_class class_id) | _ -> diff --git a/infer/src/concurrency/starvationDomain.ml b/infer/src/concurrency/starvationDomain.ml index 80aa60601..1039129a8 100644 --- a/infer/src/concurrency/starvationDomain.ml +++ b/infer/src/concurrency/starvationDomain.ml @@ -183,19 +183,19 @@ module LockState = struct let is_taken lock_event map = match lock_event.LockEvent.event with | LockEvent.LockAcquire lock -> ( - try not (find lock map |> LockStack.is_empty) with Not_found -> false ) + try not (find lock map |> LockStack.is_empty) with Caml.Not_found -> false ) | _ -> false let acquire lock_id lock_event map = - let current_value = try find lock_id map with Not_found -> LockStack.empty in + let current_value = try find lock_id map with Caml.Not_found -> LockStack.empty in let new_value = LockStack.push lock_event current_value in add lock_id new_value map let release lock_id map = - let current_value = try find lock_id map with Not_found -> LockStack.empty in + let current_value = try find lock_id map with Caml.Not_found -> LockStack.empty in if LockStack.is_empty current_value then map else let new_value = LockStack.pop current_value in diff --git a/infer/src/eradicate/AnnotatedSignature.ml b/infer/src/eradicate/AnnotatedSignature.ml index f6fdcf50f..422437bd3 100644 --- a/infer/src/eradicate/AnnotatedSignature.ml +++ b/infer/src/eradicate/AnnotatedSignature.ml @@ -10,9 +10,8 @@ open! IStd module F = Format module L = Logging -type t = - {ret: Annot.Item.t * Typ.t; params: (Mangled.t * Annot.Item.t * Typ.t) list} - [@@deriving compare] +type t = {ret: Annot.Item.t * Typ.t; params: (Mangled.t * Annot.Item.t * Typ.t) list} +[@@deriving compare] type annotation = Nullable | Present [@@deriving compare] diff --git a/infer/src/eradicate/AnnotatedSignature.mli b/infer/src/eradicate/AnnotatedSignature.mli index 8ef9ecfb7..ac3b3fd82 100644 --- a/infer/src/eradicate/AnnotatedSignature.mli +++ b/infer/src/eradicate/AnnotatedSignature.mli @@ -14,7 +14,7 @@ open! IStd type t = { ret: Annot.Item.t * Typ.t (** Annotated return type. *) ; params: (Mangled.t * Annot.Item.t * Typ.t) list (** Annotated parameters. *) } - [@@deriving compare] +[@@deriving compare] type annotation = Nullable | Present [@@deriving compare] diff --git a/infer/src/eradicate/eradicate.ml b/infer/src/eradicate/eradicate.ml index 8d112d89a..02cafeca2 100644 --- a/infer/src/eradicate/eradicate.ml +++ b/infer/src/eradicate/eradicate.ml @@ -144,7 +144,7 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let find_duplicate_nodes = State.mk_find_duplicate_nodes curr_pdesc in let find_canonical_duplicate node = let duplicate_nodes = find_duplicate_nodes node in - try Procdesc.NodeSet.min_elt duplicate_nodes with Not_found -> node + try Procdesc.NodeSet.min_elt duplicate_nodes with Caml.Not_found -> node in let typecheck_proc do_checks pname pdesc proc_details_opt = let ann_sig, loc, idenv_pn = @@ -300,9 +300,10 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let do_final_typestate typestate_opt calls_this = let do_typestate typestate = let start_node = Procdesc.get_start_node curr_pdesc in - if not calls_this - (* if 'this(...)' is called, no need to check initialization *) - && check_field_initialization && checks.TypeCheck.eradicate + if + not calls_this + (* if 'this(...)' is called, no need to check initialization *) + && check_field_initialization && checks.TypeCheck.eradicate then EradicateChecks.check_constructor_initialization tenv find_canonical_duplicate curr_pname curr_pdesc start_node Initializers.final_initializer_typestates_lazy @@ -329,12 +330,13 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let proc_name = Procdesc.get_proc_name proc_desc in let calls_this = ref false in let filter_special_cases () = - if ( match proc_name with - | Typ.Procname.Java java_pname -> - Typ.Procname.Java.is_access_method java_pname - | _ -> - false ) - || (Specs.pdesc_resolve_attributes proc_desc).ProcAttributes.is_bridge_method + if + ( match proc_name with + | Typ.Procname.Java java_pname -> + Typ.Procname.Java.is_access_method java_pname + | _ -> + false ) + || (Specs.pdesc_resolve_attributes proc_desc).ProcAttributes.is_bridge_method then None else let annotated_signature = diff --git a/infer/src/eradicate/eradicateChecks.ml b/infer/src/eradicate/eradicateChecks.ml index 7590b9b5a..35d9b00df 100644 --- a/infer/src/eradicate/eradicateChecks.ml +++ b/infer/src/eradicate/eradicateChecks.ml @@ -24,8 +24,8 @@ let get_field_annotation tenv fn typ = let ia' = (* TODO (t4968422) eliminate not !Config.eradicate check by marking fields as nullified *) (* outside of Eradicate in some other way *) - if (Models.Inference.enabled || not Config.eradicate) - && Models.Inference.field_is_marked fn + if + (Models.Inference.enabled || not Config.eradicate) && Models.Inference.field_is_marked fn then AnnotatedSignature.mk_ia AnnotatedSignature.Nullable ia else ia in @@ -91,7 +91,7 @@ type from_call = | From_is_true_on_null (** returns true on null *) | From_optional_isPresent (** x.isPresent *) | From_containsKey (** x.containsKey *) - [@@deriving compare] +[@@deriving compare] let equal_from_call = [%compare.equal : from_call] @@ -119,7 +119,7 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc node e ty false in let do_instr = function - | Sil.Call (_, Exp.Const Const.Cfun pn, [_; (Exp.Sizeof {typ}, _)], _, _) + | Sil.Call (_, Exp.Const (Const.Cfun pn), [_; (Exp.Sizeof {typ}, _)], _, _) when Typ.Procname.equal pn BuiltinDecl.__instanceof && typ_is_throwable typ -> throwable_found := true | _ -> @@ -278,14 +278,16 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu 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 may_be_assigned_in_final_typestate + if + 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 ; (* Check if field is over-annotated. *) - if Config.eradicate_field_over_annotated && nullable_annotated - && not (may_be_nullable_in_final_typestate ()) + 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 ) diff --git a/infer/src/eradicate/models.ml b/infer/src/eradicate/models.ml index 3befd261c..cbdb4f13a 100644 --- a/infer/src/eradicate/models.ml +++ b/infer/src/eradicate/models.ml @@ -120,7 +120,7 @@ let table_has_procedure table proc_name = try ignore (Hashtbl.find table proc_id) ; true - with Not_found -> false + with Caml.Not_found -> false (** Return the annotated signature of the procedure, taking into account models. *) @@ -148,7 +148,7 @@ let get_modelled_annotated_signature proc_attributes = try let mark = Hashtbl.find annotated_table_nullable proc_id in AnnotatedSignature.mark proc_name AnnotatedSignature.Nullable ann_sig mark - with Not_found -> ann_sig + with Caml.Not_found -> ann_sig else ann_sig in let lookup_models_present ann_sig = @@ -156,7 +156,7 @@ let get_modelled_annotated_signature proc_attributes = try let mark = Hashtbl.find annotated_table_present proc_id in AnnotatedSignature.mark proc_name AnnotatedSignature.Present ann_sig mark - with Not_found -> ann_sig + with Caml.Not_found -> ann_sig else ann_sig in annotated_signature |> lookup_models_nullable |> lookup_models_present |> infer_return @@ -170,7 +170,7 @@ let is_modelled_nullable proc_name = try ignore (Hashtbl.find annotated_table_nullable proc_id) ; true - with Not_found -> false + with Caml.Not_found -> false else false @@ -182,7 +182,7 @@ let is_check_not_null proc_name = (** Parameter number for a procedure known to be a checkNotNull *) let get_check_not_null_parameter proc_name = let proc_id = Typ.Procname.to_unique_id proc_name in - try Hashtbl.find check_not_null_parameter_table proc_id with Not_found -> + try Hashtbl.find check_not_null_parameter_table proc_id with Caml.Not_found -> (* Assume the check is on the first parameter unless modeled otherwise *) 1 diff --git a/infer/src/eradicate/typeAnnotation.ml b/infer/src/eradicate/typeAnnotation.ml index b47c252c2..1f8d4120b 100644 --- a/infer/src/eradicate/typeAnnotation.ml +++ b/infer/src/eradicate/typeAnnotation.ml @@ -22,7 +22,7 @@ type t = {map: bool AnnotationsMap.t; origin: TypeOrigin.t} [@@deriving compare] let equal = [%compare.equal : t] -let get_value ann ta = try AnnotationsMap.find ann ta.map with Not_found -> false +let get_value ann ta = try AnnotationsMap.find ann ta.map with Caml.Not_found -> false let set_value ann b ta = if Bool.equal (get_value ann ta) b then ta else {ta with map= AnnotationsMap.add ann b ta.map} diff --git a/infer/src/eradicate/typeCheck.ml b/infer/src/eradicate/typeCheck.ml index d6f4b465d..39091923d 100644 --- a/infer/src/eradicate/typeCheck.ml +++ b/infer/src/eradicate/typeCheck.ml @@ -91,7 +91,7 @@ module ComplexExpressions = struct dexp_to_string de ^ "." ^ Typ.Fieldname.to_string f | DExp.Dbinop (op, de1, de2) -> "(" ^ dexp_to_string de1 ^ Binop.str Pp.text op ^ dexp_to_string de2 ^ ")" - | DExp.Dconst Const.Cfun pn -> + | DExp.Dconst (Const.Cfun pn) -> Typ.Procname.to_unique_id pn | DExp.Dconst c -> F.asprintf "%a" (Const.pp Pp.text) c @@ -236,7 +236,7 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get match Idenv.expand_expr idenv e with | Exp.Lvar pvar when name_is_temporary (Pvar.to_string pvar) -> ( match pvar_get_origin pvar with - | Some TypeOrigin.Formal s -> + | Some (TypeOrigin.Formal s) -> let pvar' = Pvar.mk s curr_pname in Some (Exp.Lvar pvar') | _ -> @@ -278,7 +278,7 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get (* Convert a function call to a pvar. *) let handle_function_call call_node id = match Errdesc.find_normal_variable_funcall call_node id with - | Some (Exp.Const Const.Cfun pn, _, _, _) + | Some (Exp.Const (Const.Cfun pn), _, _, _) when not (ComplexExpressions.procname_used_in_condition pn) -> ( match ComplexExpressions.exp_to_string tenv node' exp with | None -> @@ -374,9 +374,10 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let constructor_check_calls_this calls_this pn = match (curr_pname, pn) with | Typ.Procname.Java curr_pname_java, Typ.Procname.Java pn_java -> - if String.equal - (Typ.Procname.Java.get_class_name curr_pname_java) - (Typ.Procname.Java.get_class_name pn_java) + if + String.equal + (Typ.Procname.Java.get_class_name curr_pname_java) + (Typ.Procname.Java.get_class_name pn_java) then calls_this := true | _ -> () @@ -412,8 +413,9 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get in (* Drop parameters from the signature which we do not check in a call. *) let drop_unchecked_signature_params proc_attributes annotated_signature = - if Typ.Procname.is_constructor proc_attributes.ProcAttributes.proc_name - && proc_attributes.ProcAttributes.is_synthetic_method + if + Typ.Procname.is_constructor proc_attributes.ProcAttributes.proc_name + && proc_attributes.ProcAttributes.is_synthetic_method then List.take annotated_signature.AnnotatedSignature.params (List.length annotated_signature.AnnotatedSignature.params - 1) @@ -492,19 +494,19 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get typestate1 in check_field_assign () ; typestate2 - | Sil.Call (Some (id, _), Exp.Const Const.Cfun pn, [(_, typ)], loc, _) + | Sil.Call (Some (id, _), Exp.Const (Const.Cfun pn), [(_, typ)], loc, _) 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 (* new never returns null *) - | Sil.Call (Some (id, _), Exp.Const Const.Cfun pn, (e, typ) :: _, loc, _) + | Sil.Call (Some (id, _), Exp.Const (Const.Cfun pn), (e, typ) :: _, loc, _) when Typ.Procname.equal pn BuiltinDecl.__cast -> typecheck_expr_for_errors typestate e loc ; let e', typestate' = convert_complex_exp_to_pvar node false e typestate loc in (* cast copies the type of the first argument *) TypeState.add_id id (typecheck_expr_simple typestate' e' typ TypeOrigin.ONone loc) typestate' - | Sil.Call (Some (id, _), Exp.Const Const.Cfun pn, [(array_exp, t)], loc, _) + | Sil.Call (Some (id, _), Exp.Const (Const.Cfun pn), [(array_exp, t)], loc, _) when Typ.Procname.equal pn BuiltinDecl.__get_array_length -> let _, ta, _ = typecheck_expr find_canonical_duplicate calls_this checks tenv node instr_ref curr_pdesc @@ -520,11 +522,11 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get ( Typ.mk (Tint Typ.IInt) , TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.New , [loc] ) typestate - | Sil.Call (_, Exp.Const Const.Cfun pn, _, _, _) when BuiltinDecl.is_declared pn -> + | Sil.Call (_, Exp.Const (Const.Cfun pn), _, _, _) when BuiltinDecl.is_declared pn -> typestate (* skip othe builtins *) | Sil.Call ( ret_id - , Exp.Const Const.Cfun (Typ.Procname.Java callee_pname_java as callee_pname) + , Exp.Const (Const.Cfun (Typ.Procname.Java callee_pname_java as callee_pname)) , etl_ , loc , cflags ) -> @@ -647,8 +649,8 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get in let handle_negated_condition cond_node = let do_instr = function[@warning "-57"] - | Sil.Prune (Exp.BinOp (Binop.Eq, cond_e_, Exp.Const Const.Cint i), _, _, _) - | Sil.Prune (Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, cond_e_), _, _, _) + | Sil.Prune (Exp.BinOp (Binop.Eq, cond_e_, Exp.Const (Const.Cint i)), _, _, _) + | Sil.Prune (Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), cond_e_), _, _, _) when IntLit.iszero i -> ( let cond_e = Idenv.expand_expr_temps idenv cond_node cond_e_ in @@ -690,7 +692,7 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get | Some (node', id) -> let () = match Errdesc.find_normal_variable_funcall node' id with - | Some (Exp.Const Const.Cfun pn, [e], _, _) + | Some (Exp.Const (Const.Cfun pn), [e], _, _) when ComplexExpressions.procname_optional_isPresent pn -> handle_optional_isPresent node' e | _ -> @@ -869,7 +871,7 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get match e with | Exp.Var id -> ( match Errdesc.find_normal_variable_funcall node' id with - | Some (Exp.Const Const.Cfun pn, e1 :: _, _, _) when filter_callee pn -> + | Some (Exp.Const (Const.Cfun pn), e1 :: _, _, _) when filter_callee pn -> Some e1 | _ -> None ) @@ -901,8 +903,8 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let handle_containsKey e = let map_dexp = function | Some - DExp.Dretcall - (DExp.Dconst Const.Cfun Typ.Procname.Java pname_java, args, loc, call_flags) -> + (DExp.Dretcall + (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" @@ -945,8 +947,8 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get typestate2 in 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) + | Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), e) + | Exp.BinOp (Binop.Eq, e, Exp.Const (Const.Cint i)) when IntLit.iszero i -> ( typecheck_expr_for_errors typestate e loc ; @@ -972,8 +974,8 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get else typestate2 | _ -> typestate2 ) - | Exp.BinOp (Binop.Ne, Exp.Const Const.Cint i, e) - | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) + | Exp.BinOp (Binop.Ne, Exp.Const (Const.Cint i), e) + | Exp.BinOp (Binop.Ne, e, Exp.Const (Const.Cint i)) when IntLit.iszero i -> ( typecheck_expr_for_errors typestate e loc ; @@ -1083,9 +1085,10 @@ let typecheck_node tenv ext calls_this checks idenv get_proc_desc curr_pname cur let noreturn = ref false in let handle_exceptions typestate instr = match instr with - | Sil.Call (_, Exp.Const Const.Cfun callee_pname, _, _, _) when Models.is_noreturn callee_pname -> + | Sil.Call (_, Exp.Const (Const.Cfun callee_pname), _, _, _) + when Models.is_noreturn callee_pname -> noreturn := true - | Sil.Call (_, Exp.Const Const.Cfun callee_pname, _, _, _) -> + | Sil.Call (_, Exp.Const (Const.Cfun callee_pname), _, _, _) -> let callee_attributes_opt = Specs.proc_resolve_attributes callee_pname in (* check if the call might throw an exception *) let has_exceptions = diff --git a/infer/src/eradicate/typeErr.ml b/infer/src/eradicate/typeErr.ml index 74d0184d7..d9fcbd47e 100644 --- a/infer/src/eradicate/typeErr.ml +++ b/infer/src/eradicate/typeErr.ml @@ -75,7 +75,7 @@ type parameter_not_nullable = * Location.t * (* callee location *) origin_descr - [@@deriving compare] +[@@deriving compare] (** Instance of an error *) type err_instance = @@ -92,7 +92,7 @@ type err_instance = | Parameter_annotation_inconsistent of parameter_not_nullable | Return_annotation_inconsistent of AnnotatedSignature.annotation * Typ.Procname.t * origin_descr | Return_over_annotated of Typ.Procname.t - [@@deriving compare] +[@@deriving compare] module H = Hashtbl.Make (struct type t = err_instance * InstrRef.t option [@@deriving compare] @@ -441,7 +441,8 @@ let report_error_now tenv (st_report_error: st_report_error) err_instance loc pd ( IssueType.eradicate_inconsistent_subclass_parameter_annotation , Format.asprintf "%s parameter %a of method %a is not %a but is declared %ain the parent class method \ - %a." (translate_position pos) MF.pp_monospaced param_name MF.pp_monospaced + %a." + (translate_position pos) MF.pp_monospaced param_name MF.pp_monospaced (Typ.Procname.to_simplified_string ~withclass:true pn) MF.pp_monospaced nullable_annotation MF.pp_monospaced nullable_annotation MF.pp_monospaced diff --git a/infer/src/eradicate/typeOrigin.ml b/infer/src/eradicate/typeOrigin.ml index 3b8b23103..97535fcc9 100644 --- a/infer/src/eradicate/typeOrigin.ml +++ b/infer/src/eradicate/typeOrigin.ml @@ -18,7 +18,7 @@ type proc_origin = ; loc: Location.t ; annotated_signature: AnnotatedSignature.t ; is_library: bool } - [@@deriving compare] +[@@deriving compare] type t = | Const of Location.t @@ -28,7 +28,7 @@ type t = | New | ONone | Undef - [@@deriving compare] +[@@deriving compare] let equal = [%compare.equal : t] diff --git a/infer/src/eradicate/typeOrigin.mli b/infer/src/eradicate/typeOrigin.mli index 197d36e92..13baa22b8 100644 --- a/infer/src/eradicate/typeOrigin.mli +++ b/infer/src/eradicate/typeOrigin.mli @@ -15,7 +15,7 @@ type proc_origin = ; loc: Location.t ; annotated_signature: AnnotatedSignature.t ; is_library: bool } - [@@deriving compare] +[@@deriving compare] type t = | Const of Location.t (** A constant in the source *) @@ -25,7 +25,7 @@ type t = | New (** A new object creation *) | ONone (** No origin is known *) | Undef (** Undefined value before initialization *) - [@@deriving compare] +[@@deriving compare] val equal : t -> t -> bool diff --git a/infer/src/eradicate/typeState.ml b/infer/src/eradicate/typeState.ml index c2a52fd71..8c14f6420 100644 --- a/infer/src/eradicate/typeState.ml +++ b/infer/src/eradicate/typeState.ml @@ -100,11 +100,11 @@ let map_join m1 m2 = if only_keep_intersection then tjoined := M.add exp2 range1 !tjoined | Some range' -> tjoined := M.add exp2 range' !tjoined - with Not_found -> if not only_keep_intersection then tjoined := M.add exp2 range2 !tjoined + with Caml.Not_found -> if not only_keep_intersection then tjoined := M.add exp2 range2 !tjoined in let missing_rhs exp1 range1 = (* handle elements missing in the rhs *) - try ignore (M.find exp1 m2) with Not_found -> + try ignore (M.find exp1 m2) with Caml.Not_found -> let t1, ta1, locs1 = range1 in let range1' = let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in @@ -126,11 +126,9 @@ let join ext t1 t2 = tjoin -let lookup_id id typestate = try Some (M.find (Exp.Var id) typestate.map) with Not_found -> None - -let lookup_pvar pvar typestate = - try Some (M.find (Exp.Lvar pvar) typestate.map) with Not_found -> None +let lookup_id id typestate = M.find_opt (Exp.Var id) typestate.map +let lookup_pvar pvar typestate = M.find_opt (Exp.Lvar pvar) typestate.map let add_id id range typestate = let map' = M.add (Exp.Var id) range typestate.map in diff --git a/infer/src/infer.ml b/infer/src/infer.ml index 9b6f366cf..97aa62a48 100644 --- a/infer/src/infer.ml +++ b/infer/src/infer.ml @@ -35,18 +35,20 @@ let setup () = ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir () | Capture | Compile | Run -> let driver_mode = Lazy.force Driver.mode_from_command_line in - if Config.( - (* In Buck mode, delete infer-out directories inside buck-out to start fresh and to + if + Config.( + (* In Buck mode, delete infer-out directories inside buck-out to start fresh and to avoid getting errors because some of their contents is missing (removed by [Driver.clean_results_dir ()]). *) - buck && flavors) - || not - ( Driver.(equal_mode driver_mode Analyze) - || Config.(continue_capture || infer_is_clang || infer_is_javac || reactive_mode) ) + buck && flavors) + || not + ( Driver.(equal_mode driver_mode Analyze) + || Config.(continue_capture || infer_is_clang || infer_is_javac || reactive_mode) ) then ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir () ; - if CLOpt.is_originator && not Config.continue_capture - && not Driver.(equal_mode driver_mode Analyze) + if + CLOpt.is_originator && not Config.continue_capture + && not Driver.(equal_mode driver_mode Analyze) then SourceFiles.mark_all_stale () | Explore -> ResultsDir.assert_results_dir "please run an infer analysis first" diff --git a/infer/src/integration/CaptureCompilationDatabase.ml b/infer/src/integration/CaptureCompilationDatabase.ml index de034776f..abacc749e 100644 --- a/infer/src/integration/CaptureCompilationDatabase.ml +++ b/infer/src/integration/CaptureCompilationDatabase.ml @@ -75,11 +75,11 @@ let run_compilation_database compilation_database should_capture_file = match Config.buck_compilation_database with | Some NoDeps when Config.linters -> Some fail_sentinel_fname - | Some NoDeps | Some Deps _ | None -> + | Some NoDeps | Some (Deps _) | None -> None in Utils.rmtree fail_sentinel_fname ; - let chunksize = min (List.length compilation_data / Config.jobs + 1) 10 in + let chunksize = min ((List.length compilation_data / Config.jobs) + 1) 10 in Parmap.pariter ~ncores:Config.jobs ~chunksize (invoke_cmd ~fail_sentinel) sequence ; L.progress "@." ; L.(debug Analysis Medium) "Ran %d jobs" number_of_jobs ; @@ -93,7 +93,7 @@ let run_compilation_database compilation_database should_capture_file = (** Computes the compilation database files. *) let get_compilation_database_files_buck ~prog ~args = let dep_depth = - match Config.buck_compilation_database with Some Deps depth -> Some depth | _ -> None + match Config.buck_compilation_database with Some (Deps depth) -> Some depth | _ -> None in match Buck.add_flavors_to_buck_arguments ~filter_kind:`Yes ~dep_depth diff --git a/infer/src/integration/Diff.ml b/infer/src/integration/Diff.ml index 2411ec0db..872b1a3f0 100644 --- a/infer/src/integration/Diff.ml +++ b/infer/src/integration/Diff.ml @@ -28,7 +28,8 @@ let checkout revision = | None -> L.(die UserError) "Please specify a script to checkout the %a revision of your project using --checkout-%a \ -