[ocamlformat] Upgrade ocamlformat version

Reviewed By: jvillard

Differential Revision: D18162727

fbshipit-source-id: ffb9f7541
master
Josh Berdine 5 years ago committed by Facebook Github Bot
parent 9e5307b339
commit 8d20e4d64d

@ -221,7 +221,7 @@ DUNE_ML:=$(shell find * -name 'dune*.in' | grep -v workspace)
fmt_dune: fmt_dune:
parallel $(OCAMLFORMAT_EXE) -i ::: $(DUNE_ML) parallel $(OCAMLFORMAT_EXE) -i ::: $(DUNE_ML)
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) SRC_ML:=$(shell find * \( -name _build -or -name facebook-clang-plugins -or -path facebook/dependencies -or -path sledge/llvm -or -path sledge/.llvm_build \) -not -prune -or -type f -and -name '*'.ml -or -name '*'.mli 2>/dev/null)
.PHONY: fmt_all .PHONY: fmt_all
fmt_all: fmt_all:

@ -1,4 +1,5 @@
profile = ocamlformat profile = ocamlformat
break-before-in = fit-or-vertical
let-binding-spacing = sparse let-binding-spacing = sparse
margin = 100 margin = 100
version = 0.9 version = 0.12-20-gfce0d2e

@ -14,7 +14,7 @@ module Raw = struct
let compare_typ_ _ _ = 0 let compare_typ_ _ _ = 0
(* ignore types while comparing bases. we can't trust the types from all of our frontends to be (* ignore types while comparing bases. we can't trust the types from all of our frontends to be
consistent, and the variable names should already be enough to distinguish the bases. *) consistent, and the variable names should already be enough to distinguish the bases. *)
type base = Var.t * typ_ [@@deriving compare] type base = Var.t * typ_ [@@deriving compare]
let equal_base = [%compare.equal: base] let equal_base = [%compare.equal: base]

@ -7,8 +7,8 @@
*) *)
(** The Smallfoot Intermediate Language: Annotations *) (** The Smallfoot Intermediate Language: Annotations *)
open! IStd
open! IStd
module F = Format module F = Format
type parameter = {name: string option; value: string} [@@deriving compare] type parameter = {name: string option; value: string} [@@deriving compare]
@ -81,9 +81,7 @@ module Method = struct
type t = {return: Item.t; params: Item.t list} type t = {return: Item.t; params: Item.t list}
(** Pretty print a method annotation. *) (** Pretty print a method annotation. *)
let pp s fmt {return; params} = let pp s fmt {return; params} = F.fprintf fmt "%a %s(%a)" Item.pp return s (Pp.seq Item.pp) params
F.fprintf fmt "%a %s(%a)" Item.pp return s (Pp.seq Item.pp) params
(** Empty method annotation. *) (** Empty method annotation. *)
let empty = {return= []; params= []} let empty = {return= []; params= []}

@ -7,8 +7,8 @@
*) *)
(** The Smallfoot Intermediate Language: Annotations *) (** The Smallfoot Intermediate Language: Annotations *)
open! IStd
open! IStd
module F = Format module F = Format
type parameter = {name: string option; value: string} type parameter = {name: string option; value: string}

@ -57,10 +57,9 @@ let should_try_to_update pname_blob akind =
|> SqliteUtils.check_result_code db ~log:"replace bind pname" ; |> SqliteUtils.check_result_code db ~log:"replace bind pname" ;
Sqlite3.bind find_stmt 2 (* :akind *) (Sqlite3.Data.INT (int64_of_attributes_kind akind)) Sqlite3.bind find_stmt 2 (* :akind *) (Sqlite3.Data.INT (int64_of_attributes_kind akind))
|> SqliteUtils.check_result_code db ~log:"replace bind attribute kind" ; |> SqliteUtils.check_result_code db ~log:"replace bind attribute kind" ;
SqliteUtils.result_single_column_option ~finalize:false ~log:"Attributes.replace" db SqliteUtils.result_single_column_option ~finalize:false ~log:"Attributes.replace" db find_stmt
find_stmt
|> (* there is no entry with a strictly larger "definedness" for that proc name *) |> (* there is no entry with a strictly larger "definedness" for that proc name *)
Option.is_none ) Option.is_none )
let select_statement = let select_statement =

@ -7,6 +7,7 @@
*) *)
(** The Smallfoot Intermediate Language: Binary Operators *) (** The Smallfoot Intermediate Language: Binary Operators *)
open! IStd open! IStd
type ikind_option_for_binop = Typ.ikind option type ikind_option_for_binop = Typ.ikind option

@ -7,6 +7,7 @@
*) *)
(** The Smallfoot Intermediate Language: Binary Operators *) (** The Smallfoot Intermediate Language: Binary Operators *)
open! IStd open! IStd
(** Binary operations *) (** Binary operations *)

@ -68,7 +68,7 @@ let rec pp fmt = function
F.fprintf fmt "*%a" pp de F.fprintf fmt "*%a" pp de
| Dfcall (fun_dexp, args, _, {cf_virtual= isvirtual}) -> | Dfcall (fun_dexp, args, _, {cf_virtual= isvirtual}) ->
let pp_args fmt des = let pp_args fmt des =
if eradicate_java () then ( if des <> [] then F.pp_print_string fmt "..." ) if eradicate_java () then (if des <> [] then F.pp_print_string fmt "...")
else Pp.comma_seq pp fmt des else Pp.comma_seq pp fmt des
in in
let pp_fun fmt = function let pp_fun fmt = function
@ -148,8 +148,7 @@ let pp_vpath pe fmt vpath =
let rec has_tmp_var = function let rec has_tmp_var = function
| Dpvar pvar | Dpvaraddr pvar -> | Dpvar pvar | Dpvaraddr pvar ->
Pvar.is_frontend_tmp pvar || Pvar.is_clang_tmp pvar Pvar.is_frontend_tmp pvar || Pvar.is_clang_tmp pvar
| Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _) | Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _) ->
->
has_tmp_var dexp has_tmp_var dexp
| Darray (dexp1, dexp2) | Dbinop (_, dexp1, dexp2) -> | Darray (dexp1, dexp2) | Dbinop (_, dexp1, dexp2) ->
has_tmp_var dexp1 || has_tmp_var dexp2 has_tmp_var dexp1 || has_tmp_var dexp2

@ -29,11 +29,7 @@ let pp_loc_trace fmt l = PrettyPrintable.pp_collection ~pp_item:pp_loc_trace_ele
let contains_exception loc_trace_elem = let contains_exception loc_trace_elem =
let pred nt = let pred nt =
match nt with match nt with Exception _ -> true | Condition _ | Procedure_start _ | Procedure_end _ -> false
| Exception _ ->
true
| Condition _ | Procedure_start _ | Procedure_end _ ->
false
in in
List.exists ~f:pred loc_trace_elem.lt_node_tags List.exists ~f:pred loc_trace_elem.lt_node_tags

@ -47,14 +47,14 @@ and t =
val equal : t -> t -> bool val equal : t -> t -> bool
(** Equality for expressions. *) (** Equality for expressions. *)
(** Set of expressions. *)
module Set : Caml.Set.S with type elt = t module Set : Caml.Set.S with type elt = t
(** Set of expressions. *)
(** Map with expression keys. *)
module Map : Caml.Map.S with type key = t module Map : Caml.Map.S with type key = t
(** Map with expression keys. *)
(** Hashtable with expression keys. *)
module Hash : Caml.Hashtbl.S with type key = t module Hash : Caml.Hashtbl.S with type key = t
(** Hashtable with expression keys. *)
val is_null_literal : t -> bool val is_null_literal : t -> bool

@ -382,7 +382,7 @@ let rec get_typ tenv = function
Some (Typ.mk (Typ.Tint Typ.IBool)) Some (Typ.mk (Typ.Tint Typ.IBool))
| BinaryOperator (_, e1, e2) -> ( | BinaryOperator (_, e1, e2) -> (
(* TODO: doing this properly will require taking account of language-specific coercion (* TODO: doing this properly will require taking account of language-specific coercion
semantics. Only return a type when the operands have the same type for now *) semantics. Only return a type when the operands have the same type for now *)
match (get_typ tenv e1, get_typ tenv e2) with match (get_typ tenv e1, get_typ tenv e2) with
| Some typ1, Some typ2 when Typ.equal typ1 typ2 -> | Some typ1, Some typ2 when Typ.equal typ1 typ2 ->
Some typ1 Some typ1
@ -572,9 +572,9 @@ and of_sil ~include_array_indexes ~f_resolve_id ~add_deref exp typ =
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 (* 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 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 analysis, you should probably be using SIL. this is unsound if the code modifies the
literal, e.g. using `const_cast<char*>` *) literal, e.g. using `const_cast<char*>` *)
of_sil_ (Exp.Lindex (Var (Ident.create_normal (Ident.string_to_name s) 0), index_exp)) typ of_sil_ (Exp.Lindex (Var (Ident.create_normal (Ident.string_to_name s) 0), index_exp)) typ
| Lindex (root_exp, index_exp) -> ( | Lindex (root_exp, index_exp) -> (
match access_expr_of_lhs_exp ~include_array_indexes ~f_resolve_id ~add_deref exp typ with match access_expr_of_lhs_exp ~include_array_indexes ~f_resolve_id ~add_deref exp typ with
@ -679,9 +679,9 @@ let access_expr_of_exp ~include_array_indexes ~f_resolve_id exp typ =
Some access_expr Some access_expr
| BinaryOperator (_, exp0, exp1) -> ( | BinaryOperator (_, exp0, exp1) -> (
(* pointer arithmetic. somewhere in one of the expressions, there should be at least (* pointer arithmetic. somewhere in one of the expressions, there should be at least
one pointer type represented as an access path. just use that access path and forget one pointer type represented as an access path. just use that access path and forget
about the arithmetic. if you need to model this more precisely, you should be using about the arithmetic. if you need to model this more precisely, you should be using
SIL instead *) SIL instead *)
match get_access_exprs exp0 with match get_access_exprs exp0 with
| ap :: _ -> | ap :: _ ->
Some ap Some ap
@ -689,7 +689,7 @@ let access_expr_of_exp ~include_array_indexes ~f_resolve_id exp typ =
match get_access_exprs exp1 with ap :: _ -> Some ap | [] -> None ) ) match get_access_exprs exp1 with ap :: _ -> Some ap | [] -> None ) )
| Constant (Const.Cint i) -> | Constant (Const.Cint i) ->
(* this can happen in intentionally crashing code like *0xdeadbeef = 0 used for (* 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 *) debugging. doesn't really matter what we do here, so just create a dummy var *)
let dummy_base_var = let dummy_base_var =
Var.of_id (Ident.create_normal (Ident.string_to_name (IntLit.to_string i)) 0) Var.of_id (Ident.create_normal (Ident.string_to_name (IntLit.to_string i)) 0)
in in

@ -27,8 +27,8 @@ type t =
let pp fmt = function let pp fmt = function
| Assign (access_expr, exp, loc) -> | Assign (access_expr, exp, loc) ->
F.fprintf fmt "%a := %a [%a]" HilExp.AccessExpression.pp access_expr HilExp.pp exp F.fprintf fmt "%a := %a [%a]" HilExp.AccessExpression.pp access_expr HilExp.pp exp Location.pp
Location.pp loc loc
| Assume (exp, _, _, loc) -> | Assume (exp, _, _, loc) ->
F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc
| Call (ret, call, actuals, _, loc) -> | Call (ret, call, actuals, _, loc) ->
@ -60,8 +60,8 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr : Sil.instr) =
match instr with match instr with
| Load {id= lhs_id; e= rhs_exp; typ= rhs_typ; loc} -> | Load {id= lhs_id; e= rhs_exp; typ= rhs_typ; loc} ->
analyze_id_assignment ~add_deref:true (Var.of_id lhs_id) rhs_exp rhs_typ loc analyze_id_assignment ~add_deref:true (Var.of_id lhs_id) rhs_exp rhs_typ loc
| Store {e1= Lvar lhs_pvar; typ= lhs_typ; e2= rhs_exp; loc} | Store {e1= Lvar lhs_pvar; typ= lhs_typ; e2= rhs_exp; loc} when Pvar.is_ssa_frontend_tmp lhs_pvar
when Pvar.is_ssa_frontend_tmp lhs_pvar -> ->
(* do not need to add deref here as it is added implicitly in of_pvar by forgetting the & *) (* do not need to add deref here as it is added implicitly in of_pvar by forgetting the & *)
analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc
| Call | Call

@ -217,9 +217,7 @@ let update_name_generator ids =
(** Generate a normal identifier whose name encodes a path given as a string. *) (** Generate a normal identifier whose name encodes a path given as a string. *)
let create_path pathstring = let create_path pathstring = create_normal (string_to_name ("%path%" ^ pathstring)) path_ident_stamp
create_normal (string_to_name ("%path%" ^ pathstring)) path_ident_stamp
(** {2 Pretty Printing} *) (** {2 Pretty Printing} *)

@ -28,14 +28,14 @@ type kind [@@deriving compare]
val equal_kind : kind -> kind -> bool val equal_kind : kind -> kind -> bool
(** Equality for kind. *) (** Equality for kind. *)
(** Set for identifiers. *)
module Set : Caml.Set.S with type elt = t module Set : Caml.Set.S with type elt = t
(** Set for identifiers. *)
(** Hash table with ident as key. *)
module Hash : Caml.Hashtbl.S with type key = t module Hash : Caml.Hashtbl.S with type key = t
(** Hash table with ident as key. *)
(** Map with ident as key. *)
module Map : Caml.Map.S with type key = t module Map : Caml.Map.S with type key = t
(** Map with ident as key. *)
module HashQueue : Hash_queue.S with type Key.t = t module HashQueue : Hash_queue.S with type Key.t = t

@ -328,8 +328,8 @@ let desc_unsafe_guarded_by_access accessed_fld guarded_by_str loc =
Format.asprintf Format.asprintf
"The field %a is annotated with %a, but the lock %a is not held during the access to the \ "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 \ 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 \ current class without synchronization. Consider wrapping the access in a %s block or making \
making the method private." the method private."
MF.pp_monospaced accessed_fld_str MF.pp_monospaced annot_str MF.pp_monospaced guarded_by_str MF.pp_monospaced accessed_fld_str MF.pp_monospaced annot_str MF.pp_monospaced guarded_by_str
line_info syncronized_str line_info syncronized_str
in in
@ -469,8 +469,7 @@ let desc_allocation_mismatch alloc dealloc =
let using (primitive_pname, called_pname, loc) = let using (primitive_pname, called_pname, loc) =
let by_call = let by_call =
if Typ.Procname.equal primitive_pname called_pname then "" if Typ.Procname.equal primitive_pname called_pname then ""
else else " by call to " ^ MF.monospaced_to_string (Typ.Procname.to_simplified_string called_pname)
" by call to " ^ MF.monospaced_to_string (Typ.Procname.to_simplified_string called_pname)
in in
"using " "using "
^ MF.monospaced_to_string (Typ.Procname.to_simplified_string primitive_pname) ^ MF.monospaced_to_string (Typ.Procname.to_simplified_string primitive_pname)
@ -564,7 +563,7 @@ let desc_frontend_warning desc sugg_opt loc =
let tags = Tags.create () in let tags = Tags.create () in
let sugg = match sugg_opt with Some sugg -> sugg | None -> "" in let sugg = match sugg_opt with Some sugg -> sugg | None -> "" in
(* If the description ends in a period, we remove it because the sentence continues with (* If the description ends in a period, we remove it because the sentence continues with
"at line ..." *) "at line ..." *)
let desc = match String.chop_suffix ~suffix:"." desc with Some desc -> desc | None -> desc in let desc = match String.chop_suffix ~suffix:"." desc with Some desc -> desc | None -> desc in
let description = Format.sprintf "%s %s. %s" desc (at_line tags loc) sugg in let description = Format.sprintf "%s %s. %s" desc (at_line tags loc) sugg in
{no_desc with descriptions= [description]; tags= !tags} {no_desc with descriptions= [description]; tags= !tags}
@ -658,8 +657,7 @@ let desc_retain_cycle cycle_str loc cycle_dotty =
Logging.d_strln "Proposition with retain cycle:" ; Logging.d_strln "Proposition with retain cycle:" ;
let tags = Tags.create () in let tags = Tags.create () in
let desc = let desc =
Format.sprintf "Retain cycle %s involving the following objects:%s" (at_line tags loc) Format.sprintf "Retain cycle %s involving the following objects:%s" (at_line tags loc) cycle_str
cycle_str
in in
{descriptions= [desc]; tags= !tags; dotty= cycle_dotty} {descriptions= [desc]; tags= !tags; dotty= cycle_dotty}

@ -42,8 +42,8 @@ val is_self : t -> bool
val rename : f:(string -> string) -> t -> t val rename : f:(string -> string) -> t -> t
(** Maps over both the plain and the mangled components. *) (** Maps over both the plain and the mangled components. *)
(** Set of Mangled. *)
module Set : Caml.Set.S with type elt = t module Set : Caml.Set.S with type elt = t
(** Set of Mangled. *)
(** Map with Mangled as key *)
module Map : Caml.Map.S with type key = t module Map : Caml.Map.S with type key = t
(** Map with Mangled as key *)

@ -167,11 +167,7 @@ module Core_foundation_model = struct
type core_lib = Core_foundation | Core_graphics type core_lib = Core_foundation | Core_graphics
let core_lib_to_type_list lib = let core_lib_to_type_list lib =
match lib with match lib with Core_foundation -> core_foundation_types | Core_graphics -> core_graphics_types
| Core_foundation ->
core_foundation_types
| Core_graphics ->
core_graphics_types
let rec is_core_lib lib typ = let rec is_core_lib lib typ =

@ -17,9 +17,7 @@ module NodeKey = struct
let to_string = Caml.Digest.to_hex let to_string = Caml.Digest.to_hex
let compute node ~simple_key ~succs ~preds = let compute node ~simple_key ~succs ~preds =
let v = let v = (simple_key node, List.rev_map ~f:simple_key succs, List.rev_map ~f:simple_key preds) in
(simple_key node, List.rev_map ~f:simple_key succs, List.rev_map ~f:simple_key preds)
in
Utils.better_hash v Utils.better_hash v
@ -351,11 +349,7 @@ module Node = struct
let pp_instrs ~highlight pe0 f node = let pp_instrs ~highlight pe0 f node =
let pe = let pe =
match highlight with match highlight with None -> pe0 | Some instr -> Pp.extend_colormap pe0 (Obj.repr instr) Red
| None ->
pe0
| Some instr ->
Pp.extend_colormap pe0 (Obj.repr instr) Red
in in
Instrs.pp pe f (get_instrs node) Instrs.pp pe f (get_instrs node)
@ -428,17 +422,17 @@ end
(* =============== END of module Node =============== *) (* =============== END of module Node =============== *)
(** Map over nodes *)
module NodeMap = Caml.Map.Make (Node) module NodeMap = Caml.Map.Make (Node)
(** Map over nodes *)
(** Hash table with nodes as keys. *)
module NodeHash = Hashtbl.Make (Node) module NodeHash = Hashtbl.Make (Node)
(** Hash table with nodes as keys. *)
(** Set of nodes. *)
module NodeSet = Node.NodeSet module NodeSet = Node.NodeSet
(** Set of nodes. *)
(** Map with node id keys. *)
module IdMap = Node.IdMap module IdMap = Node.IdMap
(** Map with node id keys. *)
(** procedure description *) (** procedure description *)
type t = type t =
@ -594,9 +588,7 @@ let set_exit_node pdesc node = pdesc.exit_node <- node
let set_start_node pdesc node = pdesc.start_node <- node let set_start_node pdesc node = pdesc.start_node <- node
(** Append the locals to the list of local variables *) (** Append the locals to the list of local variables *)
let append_locals pdesc new_locals = let append_locals pdesc new_locals = pdesc.attributes.locals <- pdesc.attributes.locals @ new_locals
pdesc.attributes.locals <- pdesc.attributes.locals @ new_locals
let set_succs_exn_only (node : Node.t) exn = node.exn <- exn let set_succs_exn_only (node : Node.t) exn = node.exn <- exn
@ -837,10 +829,10 @@ let is_connected proc_desc =
if List.is_empty succs || List.is_empty preds then Error `Other else Ok () if List.is_empty succs || List.is_empty preds then Error `Other else Ok ()
| Node.Join_node -> | Node.Join_node ->
(* Join node has the exception that it may be without predecessors (* Join node has the exception that it may be without predecessors
and pointing to between_join_and_exit which points to an exit node. and pointing to between_join_and_exit which points to an exit node.
This happens when the if branches end with a return. This happens when the if branches end with a return.
Nested if statements, where all branches have return statements, Nested if statements, where all branches have return statements,
introduce a sequence of join nodes *) introduce a sequence of join nodes *)
if if
(List.is_empty preds && not (is_consecutive_join_nodes n NodeSet.empty)) (List.is_empty preds && not (is_consecutive_join_nodes n NodeSet.empty))
|| ((not (List.is_empty preds)) && List.is_empty succs) || ((not (List.is_empty preds)) && List.is_empty succs)

@ -178,17 +178,17 @@ module Node : sig
val compute_key : t -> NodeKey.t val compute_key : t -> NodeKey.t
end end
(** Map with node id keys. *)
module IdMap : PrettyPrintable.PPMap with type key = Node.id module IdMap : PrettyPrintable.PPMap with type key = Node.id
(** Map with node id keys. *)
(** Hash table with nodes as keys. *)
module NodeHash : Caml.Hashtbl.S with type key = Node.t module NodeHash : Caml.Hashtbl.S with type key = Node.t
(** Hash table with nodes as keys. *)
(** Map over nodes. *)
module NodeMap : Caml.Map.S with type key = Node.t module NodeMap : Caml.Map.S with type key = Node.t
(** Map over nodes. *)
(** Set of nodes. *)
module NodeSet : Caml.Set.S with type elt = Node.t module NodeSet : Caml.Set.S with type elt = Node.t
(** Set of nodes. *)
(** procedure descriptions *) (** procedure descriptions *)
@ -316,8 +316,8 @@ val has_modify_in_block_attr : t -> Pvar.t -> bool
val is_connected : t -> (unit, [`Join | `Other]) Result.t val is_connected : t -> (unit, [`Join | `Other]) Result.t
(** checks whether a cfg for the given procdesc is connected or not *) (** checks whether a cfg for the given procdesc is connected or not *)
module SQLite : SqliteUtils.Data with type t = t option
(** per-procedure CFGs are stored in the SQLite "procedures" table as NULL if the procedure has no (** per-procedure CFGs are stored in the SQLite "procedures" table as NULL if the procedure has no
CFG *) CFG *)
module SQLite : SqliteUtils.Data with type t = t option
val load : Typ.Procname.t -> t option val load : Typ.Procname.t -> t option

@ -106,7 +106,7 @@ type ( 'context
type ('context, 'f_in, 'f_out, 'captured_types, 'emptyness) path_extra = type ('context, 'f_in, 'f_out, 'captured_types, 'emptyness) path_extra =
| PathEmpty : ('context, 'f, 'f, unit, empty) path_extra | PathEmpty : ('context, 'f, 'f, unit, empty) path_extra
| PathNonEmpty : | PathNonEmpty :
{ on_objc_cpp: 'context -> 'f_in -> objc_cpp -> ('f_out * 'captured_types capt) option } {on_objc_cpp: 'context -> 'f_in -> objc_cpp -> ('f_out * 'captured_types capt) option}
-> ('context, 'f_in, 'f_out, 'captured_types, non_empty) path_extra -> ('context, 'f_in, 'f_out, 'captured_types, non_empty) path_extra
type ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'emptyness) path_matcher = type ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, 'emptyness) path_matcher =
@ -272,14 +272,8 @@ let templ_cons :
let templ_end : let templ_end :
('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, _) templ_matcher
-> ( 'context -> ('context, 'f_in, 'f_out, 'captured_types, 'markers_in, 'markers_out, non_empty) path_matcher
, 'f_in =
, 'f_out
, 'captured_types
, 'markers_in
, 'markers_out
, non_empty )
path_matcher =
let match_empty_templ_args (f, captured_types, template_args) = let match_empty_templ_args (f, captured_types, template_args) =
match template_args with [] -> Some (f, captured_types) | _ -> None match template_args with [] -> Some (f, captured_types) | _ -> None
in in
@ -544,8 +538,7 @@ module Call = struct
| Exp.Var v -> | Exp.Var v ->
v v
| e -> | e ->
Logging.(die InternalError) Logging.(die InternalError) "Expected Lvar, got %a:%a" Exp.pp e (Typ.pp Pp.text) (typ arg)
"Expected Lvar, got %a:%a" Exp.pp e (Typ.pp Pp.text) (typ arg)
end end
type ('context, 'f_in, 'f_out, 'captured_types) proc_matcher = type ('context, 'f_in, 'f_out, 'captured_types) proc_matcher =
@ -767,16 +760,15 @@ module Call = struct
(** Matches third captured type *) (** Matches third captured type *)
let match_typ3 : let match_typ3 :
'marker -> ('context, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) one_arg_matcher 'marker -> ('context, _ * (_ * ('marker mtyp * _)), _ * (_ * ('marker * _))) one_arg_matcher =
=
let pos3 (_, (_, (x, _))) = x in let pos3 (_, (_, (x, _))) = x in
fun marker -> mk_match_typ_nth pos3 pos3 marker fun marker -> mk_match_typ_nth pos3 pos3 marker
(** Matches the type matched by the given path_matcher *) (** Matches the type matched by the given path_matcher *)
let match_typ : let match_typ :
('context, _, _, unit, unit, unit, non_empty) path_matcher ('context, _, _, unit, unit, unit, non_empty) path_matcher -> ('context, _, _) one_arg_matcher
-> ('context, _, _) one_arg_matcher = =
fun m -> fun m ->
let ({on_templated_name} : (_, _, _, unit, unit, unit, non_empty) path_matcher) = m in let ({on_templated_name} : (_, _, _, unit, unit, unit, non_empty) path_matcher) = m in
let rec match_typ context typ = let rec match_typ context typ =

@ -9,7 +9,8 @@ open! IStd
(** To be used in 'list_constraint *) (** To be used in 'list_constraint *)
type accept_more type accept_more
and end_of_list
and end_of_list
(* Markers are a fool-proofing mechanism to avoid mistaking captured types. (* Markers are a fool-proofing mechanism to avoid mistaking captured types.
Template argument types can be captured with [capt_typ] to be referenced later Template argument types can be captured with [capt_typ] to be referenced later
@ -226,7 +227,8 @@ module Call : sig
include include
Common Common
with type ('context, 'f) dispatcher = 'context -> Typ.Procname.t -> FuncArg.t list -> 'f option with type ('context, 'f) dispatcher =
'context -> Typ.Procname.t -> FuncArg.t list -> 'f option
val merge_dispatchers : val merge_dispatchers :
('context, 'f) dispatcher -> ('context, 'f) dispatcher -> ('context, 'f) dispatcher ('context, 'f) dispatcher -> ('context, 'f) dispatcher -> ('context, 'f) dispatcher

@ -38,8 +38,7 @@ type t = {pv_hash: int; pv_name: Mangled.t; pv_kind: pvar_kind} [@@deriving comp
let get_name_of_local_with_procname var = let get_name_of_local_with_procname var =
match var.pv_kind with match var.pv_kind with
| Local_var pname -> | Local_var pname ->
Mangled.from_string Mangled.from_string (F.asprintf "%s_%a" (Mangled.to_string var.pv_name) Typ.Procname.pp pname)
(F.asprintf "%s_%a" (Mangled.to_string var.pv_name) Typ.Procname.pp pname)
| _ -> | _ ->
var.pv_name var.pv_name
@ -124,9 +123,7 @@ let materialized_cpp_temporary = "SIL_materialize_temp__"
let is_frontend_tmp pvar = let is_frontend_tmp pvar =
(* Check whether the program variable is a temporary one generated by Sawja, javac, or some other (* 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 `$` *) bytecode/name generation pass. valid java identifiers cannot contain `$` *)
let is_bytecode_tmp name = let is_bytecode_tmp name = String.contains name '$' || String.is_prefix ~prefix:"CatchVar" name in
String.contains name '$' || String.is_prefix ~prefix:"CatchVar" name
in
(* Check whether the program variable is generated by [mk_tmp] *) (* Check whether the program variable is generated by [mk_tmp] *)
let is_sil_tmp name = String.is_prefix ~prefix:tmp_prefix name in let is_sil_tmp name = String.is_prefix ~prefix:tmp_prefix name in
let name = to_string pvar in let name = to_string pvar in

@ -218,12 +218,7 @@ let compare_hpara_dll = compare_hpara_dll0 (fun _ _ -> 0)
let equal_hpara_dll = [%compare.equal: hpara_dll] let equal_hpara_dll = [%compare.equal: hpara_dll]
(** {2 Comparision and Inspection Functions} *) (** {2 Comparision and Inspection Functions} *)
let is_objc_object = function let is_objc_object = function Hpointsto (_, _, Sizeof {typ}) -> Typ.is_objc_class typ | _ -> false
| Hpointsto (_, _, Sizeof {typ}) ->
Typ.is_objc_class typ
| _ ->
false
(** Check if a pvar is a local static in objc *) (** Check if a pvar is a local static in objc *)
let is_static_local_name pname pvar = let is_static_local_name pname pvar =
@ -301,8 +296,7 @@ let pp_texp pe f = function
| Exp.Sizeof {typ; nbytes; dynamic_length; subtype} -> | Exp.Sizeof {typ; nbytes; dynamic_length; subtype} ->
let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" (pp_exp_printenv pe)) l in let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" (pp_exp_printenv pe)) l in
let pp_size f size = Option.iter ~f:(Int.pp f) size in let pp_size f size = Option.iter ~f:(Int.pp f) size in
F.fprintf f "%a%a%a%a" (Typ.pp pe) typ pp_size nbytes pp_len dynamic_length Subtype.pp F.fprintf f "%a%a%a%a" (Typ.pp pe) typ pp_size nbytes pp_len dynamic_length Subtype.pp subtype
subtype
| e -> | e ->
pp_exp_printenv pe f e pp_exp_printenv pe f e
@ -827,9 +821,7 @@ let rec pp_sexp_env pe0 envo f se =
| Eexp (e, inst) -> | Eexp (e, inst) ->
F.fprintf f "%a%a" (pp_exp_printenv pe) e (pp_inst_if_trace pe) inst F.fprintf f "%a%a" (pp_exp_printenv pe) e (pp_inst_if_trace pe) inst
| Estruct (fel, inst) -> | Estruct (fel, inst) ->
let pp_diff f (n, se) = let pp_diff f (n, se) = F.fprintf f "%a:%a" Typ.Fieldname.pp n (pp_sexp_env pe envo) se in
F.fprintf f "%a:%a" Typ.Fieldname.pp n (pp_sexp_env pe envo) se
in
F.fprintf f "{%a}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst F.fprintf f "{%a}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst
| Earray (len, nel, inst) -> | Earray (len, nel, inst) ->
let pp_diff f (i, se) = let pp_diff f (i, se) =
@ -1268,8 +1260,7 @@ let rec exp_sub_ids (f : subst_fun) exp =
let apply_sub subst : subst_fun = let apply_sub subst : subst_fun =
fun id -> fun id -> match List.Assoc.find subst ~equal:Ident.equal id with Some x -> x | None -> Exp.Var id
match List.Assoc.find subst ~equal:Ident.equal id with Some x -> x | None -> Exp.Var id
let exp_sub (subst : subst) e = exp_sub_ids (apply_sub subst) e let exp_sub (subst : subst) e = exp_sub_ids (apply_sub subst) e
@ -1305,8 +1296,7 @@ let instr_sub_ids ~sub_id_binders f instr =
if phys_equal actual' actual then actual_pair else (actual', typ) ) if phys_equal actual' actual then actual_pair else (actual', typ) )
actuals actuals
in in
if if phys_equal ret_id' ret_id_typ && phys_equal fun_exp' fun_exp && phys_equal actuals' actuals
phys_equal ret_id' ret_id_typ && phys_equal fun_exp' fun_exp && phys_equal actuals' actuals
then instr then instr
else Call (ret_id', fun_exp', actuals', call_flags, loc) else Call (ret_id', fun_exp', actuals', call_flags, loc)
| Prune (exp, loc, true_branch, if_kind) -> | Prune (exp, loc, true_branch, if_kind) ->
@ -1464,14 +1454,8 @@ let hpred_compact sh hpred =
let exp_get_offsets exp = let exp_get_offsets exp =
let rec f offlist_past e = let rec f offlist_past e =
match (e : Exp.t) with match (e : Exp.t) with
| Var _ | Var _ | Const _ | UnOp _ | BinOp _ | Exn _ | Closure _ | Lvar _ | Sizeof {dynamic_length= None}
| Const _ ->
| UnOp _
| BinOp _
| Exn _
| Closure _
| Lvar _
| Sizeof {dynamic_length= None} ->
offlist_past offlist_past
| Sizeof {dynamic_length= Some l} -> | Sizeof {dynamic_length= Some l} ->
f offlist_past l f offlist_past l

@ -7,8 +7,8 @@
*) *)
(** The Smallfoot Intermediate Language *) (** The Smallfoot Intermediate Language *)
open! IStd
open! IStd
module F = Format module F = Format
(** {2 Programs and Types} *) (** {2 Programs and Types} *)
@ -239,8 +239,8 @@ val equal_hpred : ?inst:bool -> hpred -> hpred -> bool
The inst:: parameter specifies whether instumentations should also The inst:: parameter specifies whether instumentations should also
be considered (false by default). *) be considered (false by default). *)
(** Sets of heap predicates *)
module HpredSet : Caml.Set.S with type elt = hpred module HpredSet : Caml.Set.S with type elt = hpred
(** Sets of heap predicates *)
(** {2 Compaction} *) (** {2 Compaction} *)

@ -109,9 +109,7 @@ let is_captured source =
|> Option.is_some ) |> Option.is_some )
let is_non_empty_statement = let is_non_empty_statement = ResultsDatabase.register_statement "SELECT 1 FROM source_files LIMIT 1"
ResultsDatabase.register_statement "SELECT 1 FROM source_files LIMIT 1"
let is_empty () = let is_empty () =
ResultsDatabase.with_registered_statement is_non_empty_statement ~f:(fun db stmt -> ResultsDatabase.with_registered_statement is_non_empty_statement ~f:(fun db stmt ->
@ -134,8 +132,8 @@ let is_freshly_captured source =
SourceFile.SQLite.serialize source SourceFile.SQLite.serialize source
|> Sqlite3.bind load_stmt 1 |> Sqlite3.bind load_stmt 1
|> SqliteUtils.check_result_code db ~log:"load bind source file" ; |> SqliteUtils.check_result_code db ~log:"load bind source file" ;
SqliteUtils.result_single_column_option ~finalize:false SqliteUtils.result_single_column_option ~finalize:false ~log:"SourceFiles.is_freshly_captured"
~log:"SourceFiles.is_freshly_captured" db load_stmt db load_stmt
|> Option.value_map ~default:false ~f:deserialize_freshly_captured ) |> Option.value_map ~default:false ~f:deserialize_freshly_captured )

@ -261,9 +261,7 @@ let with_block_args_instrs resolved_pdesc substitutions =
in in
let call_instr = let call_instr =
let id_exps = List.map ~f:(fun (id, _, typ) -> (id, typ)) id_exp_typs in let id_exps = List.map ~f:(fun (id, _, typ) -> (id, typ)) id_exp_typs in
let converted_args = let converted_args = List.map ~f:(fun (exp, typ) -> (convert_exp exp, typ)) origin_args in
List.map ~f:(fun (exp, typ) -> (convert_exp exp, typ)) origin_args
in
Sil.Call Sil.Call
( return_ids ( return_ids
, Exp.Const (Const.Cfun block_name) , Exp.Const (Const.Cfun block_name)
@ -299,7 +297,7 @@ let append_no_duplicates_formals_and_annot =
let with_block_args callee_pdesc pname_with_block_args block_args = let with_block_args callee_pdesc pname_with_block_args block_args =
let callee_attributes = Procdesc.get_attributes callee_pdesc in let callee_attributes = Procdesc.get_attributes callee_pdesc in
(* Substitution from a block parameter to the block name and the new formals (* Substitution from a block parameter to the block name and the new formals
that correspond to the captured variables *) that correspond to the captured variables *)
let substitutions : (Typ.Procname.t * (Mangled.t * Typ.t) list) Mangled.Map.t = let substitutions : (Typ.Procname.t * (Mangled.t * Typ.t) list) Mangled.Map.t =
List.fold2_exn callee_attributes.formals block_args ~init:Mangled.Map.empty List.fold2_exn callee_attributes.formals block_args ~init:Mangled.Map.empty
~f:(fun subts (param_name, _) block_arg_opt -> ~f:(fun subts (param_name, _) block_arg_opt ->
@ -309,7 +307,7 @@ let with_block_args callee_pdesc pname_with_block_args block_args =
List.map List.map
~f:(fun (_, var, typ) -> ~f:(fun (_, var, typ) ->
(* Here we create fresh names for the new formals, based on the names of the captured (* Here we create fresh names for the new formals, based on the names of the captured
variables annotated with the name of the caller method *) variables annotated with the name of the caller method *)
(Pvar.get_name_of_local_with_procname var, typ) ) (Pvar.get_name_of_local_with_procname var, typ) )
cl.captured_vars cl.captured_vars
in in
@ -318,7 +316,7 @@ let with_block_args callee_pdesc pname_with_block_args block_args =
subts ) subts )
in in
(* Extend formals with fresh variables for the captured variables of the block arguments, (* Extend formals with fresh variables for the captured variables of the block arguments,
without duplications. *) without duplications. *)
let new_formals_blocks_captured_vars, extended_formals_annots = let new_formals_blocks_captured_vars, extended_formals_annots =
let new_formals_blocks_captured_vars_with_annots = let new_formals_blocks_captured_vars_with_annots =
let formals_annots = let formals_annots =
@ -341,8 +339,8 @@ let with_block_args callee_pdesc pname_with_block_args block_args =
source_file source_file
| None -> | None ->
Logging.die InternalError Logging.die InternalError
"specialize_with_block_args ahould only be called with defined procedures, but we \ "specialize_with_block_args ahould only be called with defined procedures, but we cannot \
cannot find the captured file of procname %a" find the captured file of procname %a"
Typ.Procname.pp pname Typ.Procname.pp pname
in in
let resolved_attributes = let resolved_attributes =

@ -9,8 +9,8 @@ module L = Logging
(** Module for Type Environments. *) (** Module for Type Environments. *)
(** Hash tables on type names. *)
module TypenameHash = Caml.Hashtbl.Make (Typ.Name) module TypenameHash = Caml.Hashtbl.Make (Typ.Name)
(** Hash tables on type names. *)
module TypenameHashNormalizer = MaximumSharing.ForHashtbl (TypenameHash) module TypenameHashNormalizer = MaximumSharing.ForHashtbl (TypenameHash)

@ -129,10 +129,7 @@ let range_of_ikind =
let ikind_is_char = function IChar | ISChar | IUChar -> true | _ -> false let ikind_is_char = function IChar | ISChar | IUChar -> true | _ -> false
(** Kinds of floating-point numbers *) (** Kinds of floating-point numbers *)
type fkind = type fkind = FFloat (** [float] *) | FDouble (** [double] *) | FLongDouble (** [long double] *)
| FFloat (** [float] *)
| FDouble (** [double] *)
| FLongDouble (** [long double] *)
[@@deriving compare] [@@deriving compare]
let equal_fkind = [%compare.equal: fkind] let equal_fkind = [%compare.equal: fkind]
@ -684,8 +681,8 @@ module Procname = struct
match verbosity with match verbosity with
| Verbose | Non_verbose -> | Verbose | Non_verbose ->
(* if verbose, then package.class.method(params): rtype, (* if verbose, then package.class.method(params): rtype,
else rtype package.class.method(params) else rtype package.class.method(params)
verbose is used for example to create unique filenames, non_verbose to create reports *) verbose is used for example to create unique filenames, non_verbose to create reports *)
let pp_class_name verbosity fmt j = let pp_class_name verbosity fmt j =
pp_type_verbosity verbosity fmt (Name.Java.split_typename j.class_name) pp_type_verbosity verbosity fmt (Name.Java.split_typename j.class_name)
in in
@ -1423,8 +1420,7 @@ module Procname = struct
end end
module Fieldname = struct module Fieldname = struct
type t = Clang of {class_name: Name.t; field_name: string} | Java of string type t = Clang of {class_name: Name.t; field_name: string} | Java of string [@@deriving compare]
[@@deriving compare]
let equal = [%compare.equal: t] let equal = [%compare.equal: t]

@ -55,10 +55,7 @@ val ikind_is_unsigned : ikind -> bool
(** Check whether the integer kind is unsigned *) (** Check whether the integer kind is unsigned *)
(** Kinds of floating-point numbers *) (** Kinds of floating-point numbers *)
type fkind = type fkind = FFloat (** [float] *) | FDouble (** [double] *) | FLongDouble (** [long double] *)
| FFloat (** [float] *)
| FDouble (** [double] *)
| FLongDouble (** [long double] *)
[@@deriving compare] [@@deriving compare]
(** kind of pointer *) (** kind of pointer *)
@ -448,8 +445,7 @@ being the name of the struct, [None] means the parameter is of some other type.
; template_args: template_spec_info } ; template_args: template_spec_info }
[@@deriving compare] [@@deriving compare]
val make : val make : Name.t -> string -> kind -> template_spec_info -> Parameter.clang_parameter list -> t
Name.t -> string -> kind -> template_spec_info -> Parameter.clang_parameter list -> t
(** Create an objc procedure name from a class_name and method_name. *) (** Create an objc procedure name from a class_name and method_name. *)
val get_class_name : t -> string val get_class_name : t -> string
@ -540,14 +536,14 @@ being the name of the struct, [None] means the parameter is of some other type.
val is_objc_method : t -> bool val is_objc_method : t -> bool
(** Hash tables with proc names as keys. *)
module Hash : Caml.Hashtbl.S with type key = t module Hash : Caml.Hashtbl.S with type key = t
(** Hash tables with proc names as keys. *)
(** Maps from proc names. *)
module Map : PrettyPrintable.PPMap with type key = t module Map : PrettyPrintable.PPMap with type key = t
(** Maps from proc names. *)
(** Sets of proc names. *)
module Set : PrettyPrintable.PPSet with type elt = t module Set : PrettyPrintable.PPSet with type elt = t
(** Sets of proc names. *)
module SQLite : sig module SQLite : sig
val serialize : t -> Sqlite3.Data.t val serialize : t -> Sqlite3.Data.t
@ -643,11 +639,11 @@ module Fieldname : sig
val equal : t -> t -> bool val equal : t -> t -> bool
(** Equality for field names. *) (** Equality for field names. *)
(** Set for fieldnames *)
module Set : Caml.Set.S with type elt = t module Set : Caml.Set.S with type elt = t
(** Set for fieldnames *)
(** Map for fieldnames *)
module Map : Caml.Map.S with type key = t module Map : Caml.Map.S with type key = t
(** Map for fieldnames *)
module Clang : sig module Clang : sig
val from_class_name : Name.t -> string -> t val from_class_name : Name.t -> string -> t

@ -60,10 +60,10 @@ module Partition = struct
match fold_right head ~init ~f:prepend_node with match fold_right head ~init ~f:prepend_node with
| Empty | Component _ -> | Empty | Component _ ->
(* [fold_right] is expected to always provide a non-empty sequence. (* [fold_right] is expected to always provide a non-empty sequence.
Hence the result of [fold_right ~f:prepend_node] will always start with a Node. *) Hence the result of [fold_right ~f:prepend_node] will always start with a Node. *)
Logging.(die InternalError) Logging.(die InternalError)
"WeakTopologicalOrder.Partition.expand: the expansion function fold_right should \ "WeakTopologicalOrder.Partition.expand: the expansion function fold_right should not \
not return ~init directly" return ~init directly"
| Node {node= head; next= rest} -> | Node {node= head; next= rest} ->
Component {head; rest; next} ) Component {head; rest; next} )
@ -111,12 +111,12 @@ module type Make = functor (CFG : PreProcCfg) -> S with module CFG = CFG
module Bourdoncle_SCC (CFG : PreProcCfg) = struct module Bourdoncle_SCC (CFG : PreProcCfg) = struct
module CFG = CFG module CFG = CFG
module Dfn = CFG.Node.IdMap
(** (**
[dfn] contains a DFS pre-order indexing. A node is not in the map if it has never been visited. [dfn] contains a DFS pre-order indexing. A node is not in the map if it has never been visited.
A node's dfn is +oo if it has been fully visited (head of cross-edges) or we want to hide it A node's dfn is +oo if it has been fully visited (head of cross-edges) or we want to hide it
for building a subcomponent partition (head of highest back-edges). for building a subcomponent partition (head of highest back-edges).
*) *)
module Dfn = CFG.Node.IdMap
(* (*
Unlike Bourdoncle's paper version or OCamlGraph implementation, this implementation handles Unlike Bourdoncle's paper version or OCamlGraph implementation, this implementation handles

@ -78,8 +78,8 @@ end
module type Make = functor (CFG : PreProcCfg) -> S with module CFG = CFG module type Make = functor (CFG : PreProcCfg) -> S with module CFG = CFG
module Bourdoncle_SCC : Make
(** (**
Implementation of Bourdoncle's "Hierarchical decomposition of a directed graph into strongly Implementation of Bourdoncle's "Hierarchical decomposition of a directed graph into strongly
connected components and subcomponents". See [Bou] Figure 4, page 10. connected components and subcomponents". See [Bou] Figure 4, page 10.
*) *)
module Bourdoncle_SCC : Make

@ -532,8 +532,7 @@ module InvertedMap (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S
inter prev next ~f:(fun prev next -> ValueDomain.widen ~prev ~next ~num_iters) inter prev next ~f:(fun prev next -> ValueDomain.widen ~prev ~next ~num_iters)
end end
module SafeInvertedMap (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : WithTop) = module SafeInvertedMap (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : WithTop) = struct
struct
module M = InvertedMap (Key) (ValueDomain) module M = InvertedMap (Key) (ValueDomain)
type key = M.key type key = M.key

@ -17,9 +17,9 @@ end
open! Types open! Types
exception Stop_analysis
(** This exception can be raised by abstract interpreters to stop the analysis early without (** This exception can be raised by abstract interpreters to stop the analysis early without
triggering further errors. Clients who raise this exception should catch it eventually. *) triggering further errors. Clients who raise this exception should catch it eventually. *)
exception Stop_analysis
(** Abstract domains and domain combinators *) (** Abstract domains and domain combinators *)
@ -38,13 +38,12 @@ module type S = sig
val widen : prev:t -> next:t -> num_iters:int -> t val widen : prev:t -> next:t -> num_iters:int -> t
end end
include include (* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *)
(* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *)
sig sig
[@@@warning "-60"] [@@@warning "-60"]
(** a trivial domain *) module Empty : S with type t = unit
module Empty : S with type t = unit (** a trivial domain *)
end end
(** A domain with an explicit bottom value *) (** A domain with an explicit bottom value *)
@ -95,12 +94,11 @@ module Flat (V : PrettyPrintable.PrintableEquatableType) : sig
val get : t -> V.t option val get : t -> V.t option
end end
include include sig
sig [@@@warning "-60"]
[@@@warning "-60"]
(** Stacked abstract domain: tagged union of [Below] and [Above] domains where all elements of [Below] are strictly smaller than elements of [Above] *) (** Stacked abstract domain: tagged union of [Below] and [Above] domains where all elements of [Below] are strictly smaller than elements of [Above] *)
module Stacked (Below : S) (Above : S) : S with type t = (Below.t, Above.t) below_above module Stacked (Below : S) (Above : S) : S with type t = (Below.t, Above.t) below_above
end end
module StackedUtils : sig module StackedUtils : sig
@ -165,13 +163,12 @@ module type FiniteSetS = sig
include WithBottom with type t := t include WithBottom with type t := t
end end
include include sig
sig [@@@warning "-60"]
[@@@warning "-60"]
(** Lift a PPSet to a powerset domain ordered by subset. The elements of the set should be drawn from (** Lift a PPSet to a powerset domain ordered by subset. The elements of the set should be drawn from
a *finite* collection of possible values, since the widening operator here is just union. *) a *finite* collection of possible values, since the widening operator here is just union. *)
module FiniteSetOfPPSet (PPSet : PrettyPrintable.PPSet) : FiniteSetS with type elt = PPSet.elt module FiniteSetOfPPSet (PPSet : PrettyPrintable.PPSet) : FiniteSetS with type elt = PPSet.elt
end end
(** Lift a set to a powerset domain ordered by subset. The elements of the set should be drawn from (** Lift a set to a powerset domain ordered by subset. The elements of the set should be drawn from
@ -195,18 +192,14 @@ module type MapS = sig
include WithBottom with type t := t include WithBottom with type t := t
end end
include include sig
sig [@@@warning "-60"]
[@@@warning "-60"]
(** Map domain ordered by union over the set of bindings, so the bottom element is the empty map. (** Map domain ordered by union over the set of bindings, so the bottom element is the empty map.
Every element implicitly maps to bottom unless it is explicitly bound to something else. Every element implicitly maps to bottom unless it is explicitly bound to something else.
Uses PPMap as the underlying map *) Uses PPMap as the underlying map *)
module MapOfPPMap (PPMap : PrettyPrintable.PPMap) (ValueDomain : S) : module MapOfPPMap (PPMap : PrettyPrintable.PPMap) (ValueDomain : S) :
MapS MapS with type key = PPMap.key and type value = ValueDomain.t and type t = ValueDomain.t PPMap.t
with type key = PPMap.key
and type value = ValueDomain.t
and type t = ValueDomain.t PPMap.t
end end
(** Map domain ordered by union over the set of bindings, so the bottom element is the empty map. (** Map domain ordered by union over the set of bindings, so the bottom element is the empty map.
@ -233,30 +226,29 @@ module SafeInvertedMap (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain
(* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *) (* ocaml ignores the warning suppression at toplevel, hence the [include struct ... end] trick *)
include include sig
sig [@@@warning "-60"]
[@@@warning "-60"]
module FiniteMultiMap module FiniteMultiMap
(Key : PrettyPrintable.PrintableOrderedType) (Key : PrettyPrintable.PrintableOrderedType)
(Value : PrettyPrintable.PrintableOrderedType) : sig (Value : PrettyPrintable.PrintableOrderedType) : sig
include WithBottom include WithBottom
val add : Key.t -> Value.t -> t -> t [@@warning "-32"] val add : Key.t -> Value.t -> t -> t [@@warning "-32"]
val mem : Key.t -> t -> bool [@@warning "-32"] val mem : Key.t -> t -> bool [@@warning "-32"]
val remove : Key.t -> Value.t -> t -> t [@@warning "-32"] val remove : Key.t -> Value.t -> t -> t [@@warning "-32"]
end end
end end
module BooleanAnd : S with type t = bool
(** Boolean domain ordered by p || ~q. Useful when you want a boolean that's true only when it's (** Boolean domain ordered by p || ~q. Useful when you want a boolean that's true only when it's
true in both conditional branches. *) true in both conditional branches. *)
module BooleanAnd : S with type t = bool
module BooleanOr : WithBottom with type t = bool
(** Boolean domain ordered by ~p || q. Useful when you want a boolean that's true only when it's (** Boolean domain ordered by ~p || q. Useful when you want a boolean that's true only when it's
true in one conditional branch. *) true in one conditional branch. *)
module BooleanOr : WithBottom with type t = bool
module type MaxCount = sig module type MaxCount = sig
val max : int val max : int
@ -268,8 +260,8 @@ end
module CountDomain (MaxCount : MaxCount) : sig module CountDomain (MaxCount : MaxCount) : sig
include WithBottom with type t = private int include WithBottom with type t = private int
(** top is maximum value *)
include WithTop with type t := t include WithTop with type t := t
(** top is maximum value *)
val increment : t -> t val increment : t -> t
(** bump the count by one if it is less than the max *) (** bump the count by one if it is less than the max *)
@ -284,11 +276,11 @@ end
(** Domain keeping a non-negative count with a bounded maximum value. (** Domain keeping a non-negative count with a bounded maximum value.
[join] is minimum and [top] is zero. *) [join] is minimum and [top] is zero. *)
module DownwardIntDomain (MaxCount : MaxCount) : sig module DownwardIntDomain (MaxCount : MaxCount) : sig
(** top is zero *)
include WithTop with type t = private int include WithTop with type t = private int
(** top is zero *)
(** bottom is the provided maximum *)
include WithBottom with type t := t include WithBottom with type t := t
(** bottom is the provided maximum *)
val increment : t -> t val increment : t -> t
(** bump the count by one if this won't cross the maximum *) (** bump the count by one if this won't cross the maximum *)

@ -204,8 +204,7 @@ module AbstractInterpreterCommon (TransferFunctions : TransferFunctions.SIL) = s
let prev = old_state.State.pre in let prev = old_state.State.pre in
let next = astate_pre in let next = astate_pre in
let res = Domain.widen ~prev ~next ~num_iters in let res = Domain.widen ~prev ~next ~num_iters in
if Config.write_html then if Config.write_html then debug_absint_operation (`Widen (num_iters, (prev, next, res))) ;
debug_absint_operation (`Widen (num_iters, (prev, next, res))) ;
res ) res )
else astate_pre else astate_pre
in in
@ -368,7 +367,7 @@ module MakeUsingWTO (TransferFunctions : TransferFunctions.SIL) = struct
To mitigate the problem, it tries to do narrowing, in loop level, right after it found a To mitigate the problem, it tries to do narrowing, in loop level, right after it found a
fixpoint of a loop. Thus, it narrows before the widened values are flowed to the following fixpoint of a loop. Thus, it narrows before the widened values are flowed to the following
loops. In order to guarantee the termination of the analysis, this eager narrowing is applied loops. In order to guarantee the termination of the analysis, this eager narrowing is applied
only to the outermost loops or when the first visits of each loops. *) only to the outermost loops or when the first visits of each loops. *)
type mode = Widen | WidenThenNarrow | Narrow type mode = Widen | WidenThenNarrow | Narrow
let is_narrowing_of = function Widen | WidenThenNarrow -> false | Narrow -> true let is_narrowing_of = function Widen | WidenThenNarrow -> false | Narrow -> true
@ -453,8 +452,8 @@ module MakeUsingWTO (TransferFunctions : TransferFunctions.SIL) = struct
let compute_post ?(do_narrowing = false) = make_compute_post ~exec_cfg_internal ~do_narrowing let compute_post ?(do_narrowing = false) = make_compute_post ~exec_cfg_internal ~do_narrowing
end end
module type Make = functor (TransferFunctions : TransferFunctions.SIL) -> S module type Make = functor (TransferFunctions : TransferFunctions.SIL) ->
with module TransferFunctions = TransferFunctions S with module TransferFunctions = TransferFunctions
module MakeRPO (T : TransferFunctions.SIL) = module MakeRPO (T : TransferFunctions.SIL) =
MakeWithScheduler (Scheduler.ReversePostorder (T.CFG)) (T) MakeWithScheduler (Scheduler.ReversePostorder (T.CFG)) (T)

@ -58,11 +58,11 @@ module type S = sig
(** extract the state for a node id from the given invariant map *) (** extract the state for a node id from the given invariant map *)
end end
module type Make = functor (TransferFunctions : TransferFunctions.SIL) -> S module type Make = functor (TransferFunctions : TransferFunctions.SIL) ->
with module TransferFunctions = TransferFunctions S with module TransferFunctions = TransferFunctions
(** create an intraprocedural abstract interpreter from transfer functions using the reverse post-order scheduler *)
module MakeRPO : Make module MakeRPO : Make
(** create an intraprocedural abstract interpreter from transfer functions using the reverse post-order scheduler *)
(** create an intraprocedural abstract interpreter from transfer functions using Bourdoncle's strongly connected component weak topological order *)
module MakeWTO : Make module MakeWTO : Make
(** create an intraprocedural abstract interpreter from transfer functions using Bourdoncle's strongly connected component weak topological order *)

@ -110,8 +110,8 @@ module MakeAbstractInterpreterWithConfig
(HilConfig : HilConfig) (HilConfig : HilConfig)
(TransferFunctions : TransferFunctions.HIL) : (TransferFunctions : TransferFunctions.HIL) :
S S
with type domain = TransferFunctions.Domain.t with type domain = TransferFunctions.Domain.t
and module Interpreter = MakeAbstractInterpreter(Make(TransferFunctions)(HilConfig)) = struct and module Interpreter = MakeAbstractInterpreter(Make(TransferFunctions)(HilConfig)) = struct
module LowerHilInterpreter = Make (TransferFunctions) (HilConfig) module LowerHilInterpreter = Make (TransferFunctions) (HilConfig)
module Interpreter = MakeAbstractInterpreter (LowerHilInterpreter) module Interpreter = MakeAbstractInterpreter (LowerHilInterpreter)

@ -18,12 +18,12 @@ module DefaultConfig : HilConfig
module Make (TransferFunctions : TransferFunctions.HIL) (HilConfig : HilConfig) : sig module Make (TransferFunctions : TransferFunctions.HIL) (HilConfig : HilConfig) : sig
module CFG : module CFG :
ProcCfg.S ProcCfg.S
with type t = TransferFunctions.CFG.t with type t = TransferFunctions.CFG.t
and type instrs_dir = TransferFunctions.CFG.instrs_dir and type instrs_dir = TransferFunctions.CFG.instrs_dir
and type Node.t = TransferFunctions.CFG.Node.t and type Node.t = TransferFunctions.CFG.Node.t
and type Node.id = TransferFunctions.CFG.Node.id and type Node.id = TransferFunctions.CFG.Node.id
and module Node.IdMap = TransferFunctions.CFG.Node.IdMap and module Node.IdMap = TransferFunctions.CFG.Node.IdMap
and module Node.IdSet = TransferFunctions.CFG.Node.IdSet and module Node.IdSet = TransferFunctions.CFG.Node.IdSet
module Domain : module type of AbstractDomain.Pair (TransferFunctions.Domain) (Bindings) module Domain : module type of AbstractDomain.Pair (TransferFunctions.Domain) (Bindings)
@ -68,12 +68,12 @@ module MakeAbstractInterpreterWithConfig
(HilConfig : HilConfig) (HilConfig : HilConfig)
(TransferFunctions : TransferFunctions.HIL) : (TransferFunctions : TransferFunctions.HIL) :
S S
with type domain = TransferFunctions.Domain.t with type domain = TransferFunctions.Domain.t
and module Interpreter = MakeAbstractInterpreter(Make(TransferFunctions)(HilConfig)) and module Interpreter = MakeAbstractInterpreter(Make(TransferFunctions)(HilConfig))
(** Simpler version of the above wrapper that uses the default HIL config *) (** Simpler version of the above wrapper that uses the default HIL config *)
module MakeAbstractInterpreter (TransferFunctions : TransferFunctions.HIL) : sig module MakeAbstractInterpreter (TransferFunctions : TransferFunctions.HIL) : sig
include module type of include module type of
MakeAbstractInterpreterWithConfig (AbstractInterpreter.MakeRPO) (DefaultConfig) MakeAbstractInterpreterWithConfig (AbstractInterpreter.MakeRPO) (DefaultConfig)
(TransferFunctions) (TransferFunctions)
end end

@ -118,9 +118,7 @@ let type_get_direct_supertypes tenv (typ : Typ.t) =
[] []
let type_get_class_name {Typ.desc} = let type_get_class_name {Typ.desc} = match desc with Typ.Tptr (typ, _) -> Typ.name typ | _ -> None
match desc with Typ.Tptr (typ, _) -> Typ.name typ | _ -> None
let type_get_annotation tenv (typ : Typ.t) : Annot.Item.t option = let type_get_annotation tenv (typ : Typ.t) : Annot.Item.t option =
match typ.desc with match typ.desc with

@ -216,9 +216,7 @@ module Exceptional = struct
in in
fold_exceptional_succs pdesc n ~f:add_exn_pred ~init:exn_preds_acc fold_exceptional_succs pdesc n ~f:add_exn_pred ~init:exn_preds_acc
in in
let exceptional_preds = let exceptional_preds = Procdesc.fold_nodes pdesc ~f:add_exn_preds ~init:Procdesc.IdMap.empty in
Procdesc.fold_nodes pdesc ~f:add_exn_preds ~init:Procdesc.IdMap.empty
in
(pdesc, exceptional_preds) (pdesc, exceptional_preds)
@ -291,8 +289,7 @@ end
(** Wrapper that reverses the direction of the CFG *) (** Wrapper that reverses the direction of the CFG *)
module Backward (Base : S with type instrs_dir = Instrs.not_reversed) = struct module Backward (Base : S with type instrs_dir = Instrs.not_reversed) = struct
include ( include (
Base : Base : S with type t = Base.t and type instrs_dir := Base.instrs_dir and module Node = Base.Node )
S with type t = Base.t and type instrs_dir := Base.instrs_dir and module Node = Base.Node )
type instrs_dir = Instrs.reversed type instrs_dir = Instrs.reversed
@ -341,8 +338,7 @@ end = struct
let instrs (node, index) = let instrs (node, index) =
let instrs = Base.instrs node in let instrs = Base.instrs node in
if Instrs.is_empty instrs then Instrs.empty if Instrs.is_empty instrs then Instrs.empty else Instrs.nth_exn instrs index |> Instrs.singleton
else Instrs.nth_exn instrs index |> Instrs.singleton
let first_of_node node = (node, 0) let first_of_node node = (node, 0)

@ -91,17 +91,14 @@ end
(** Forward CFG with no exceptional control-flow *) (** Forward CFG with no exceptional control-flow *)
module Normal : module Normal :
S S with type t = Procdesc.t and module Node = DefaultNode and type instrs_dir = Instrs.not_reversed
with type t = Procdesc.t
and module Node = DefaultNode
and type instrs_dir = Instrs.not_reversed
(** Forward CFG with exceptional control-flow *) (** Forward CFG with exceptional control-flow *)
module Exceptional : module Exceptional :
S S
with type t = Procdesc.t * DefaultNode.t list Procdesc.IdMap.t with type t = Procdesc.t * DefaultNode.t list Procdesc.IdMap.t
and module Node = DefaultNode and module Node = DefaultNode
and type instrs_dir = Instrs.not_reversed and type instrs_dir = Instrs.not_reversed
(** Wrapper that reverses the direction of the CFG *) (** Wrapper that reverses the direction of the CFG *)
module Backward (Base : S with type instrs_dir = Instrs.not_reversed) : module Backward (Base : S with type instrs_dir = Instrs.not_reversed) :

@ -20,8 +20,7 @@ module type S = sig
val of_summary : Summary.t -> t option val of_summary : Summary.t -> t option
val read_full : val read_full : caller_summary:Summary.t -> callee_pname:Typ.Procname.t -> (Procdesc.t * t) option
caller_summary:Summary.t -> callee_pname:Typ.Procname.t -> (Procdesc.t * t) option
val read : caller_summary:Summary.t -> callee_pname:Typ.Procname.t -> t option val read : caller_summary:Summary.t -> callee_pname:Typ.Procname.t -> t option
@ -44,8 +43,7 @@ module Make (P : Payload) : S with type t = P.t = struct
let get_payload analysis_result = let get_payload analysis_result =
let open Option.Monad_infix in let open Option.Monad_infix in
analysis_result analysis_result
>>= fun summary -> >>= fun summary -> of_summary summary >>| fun payload -> (Summary.get_proc_desc summary, payload)
of_summary summary >>| fun payload -> (Summary.get_proc_desc summary, payload)
let read_full ~caller_summary ~callee_pname = let read_full ~caller_summary ~callee_pname =

@ -22,8 +22,7 @@ module type S = sig
val of_summary : Summary.t -> t option val of_summary : Summary.t -> t option
(** Read the corresponding part of the payload from the procedure summary *) (** Read the corresponding part of the payload from the procedure summary *)
val read_full : val read_full : caller_summary:Summary.t -> callee_pname:Typ.Procname.t -> (Procdesc.t * t) option
caller_summary:Summary.t -> callee_pname:Typ.Procname.t -> (Procdesc.t * t) option
(** Return the proc desc and payload for the given procedure. Runs the analysis on-demand if (** Return the proc desc and payload for the given procedure. Runs the analysis on-demand if
necessary. *) necessary. *)

@ -13,8 +13,8 @@ open! IStd
module type S = sig module type S = sig
module CFG : ProcCfg.S module CFG : ProcCfg.S
(** abstract domain whose state we propagate *)
module Domain : AbstractDomain.S module Domain : AbstractDomain.S
(** abstract domain whose state we propagate *)
(** read-only extra state (results of previous analyses, globals, etc.) *) (** read-only extra state (results of previous analyses, globals, etc.) *)
type extras type extras
@ -75,7 +75,7 @@ module MakeDisjunctive (TransferFunctions : DisjReady) (DConfig : DisjunctiveCon
include include
SIL SIL
with type extras = TransferFunctions.extras with type extras = TransferFunctions.extras
and module CFG = TransferFunctions.CFG and module CFG = TransferFunctions.CFG
and type Domain.t = Disjuncts.t and type Domain.t = Disjuncts.t
end end

@ -21,8 +21,7 @@ let rec parse_import_file import_file channel =
; global_paths= curr_file_paths ; global_paths= curr_file_paths
; checkers= _ } -> ; checkers= _ } ->
already_imported_files := import_file :: !already_imported_files ; already_imported_files := import_file :: !already_imported_files ;
collect_all_macros_and_paths ~from_file:import_file imports curr_file_macros collect_all_macros_and_paths ~from_file:import_file imports curr_file_macros curr_file_paths
curr_file_paths
| None -> | None ->
L.(debug Linters Medium) "No macros or paths found.@\n" ; L.(debug Linters Medium) "No macros or paths found.@\n" ;
([], []) ([], [])
@ -312,7 +311,7 @@ and do_frontend_checks_decl linters (context : CLintersContext.context)
let context' = CLintersContext.update_current_method context decl in let context' = CLintersContext.update_current_method context decl in
ALIssues.invoke_set_of_checkers_on_node linters context' an ; ALIssues.invoke_set_of_checkers_on_node linters context' an ;
(* We need to visit explicitly nodes reachable via Parameters transitions (* We need to visit explicitly nodes reachable via Parameters transitions
because they won't be visited during the evaluation of the formula *) because they won't be visited during the evaluation of the formula *)
do_frontend_checks_via_transition linters context' map_active an CTL.Parameters ; do_frontend_checks_via_transition linters context' map_active an CTL.Parameters ;
( match CAst_utils.get_method_body_opt decl with ( match CAst_utils.get_method_body_opt decl with
| Some stmt -> | Some stmt ->

@ -22,9 +22,9 @@ let filter_parsed_linters_developer parsed_linters =
match Config.linter with match Config.linter with
| None -> | None ->
L.(die UserError) L.(die UserError)
"In linters developer mode you should debug only one linter at a time. This is \ "In linters developer mode you should debug only one linter at a time. This is important \
important for debugging the rule. Pass the flag --linter <name> to specify the linter \ for debugging the rule. Pass the flag --linter <name> to specify the linter you want to \
you want to debug." debug."
| Some lint -> | Some lint ->
List.filter List.filter
~f:(fun (rule : linter) -> ~f:(fun (rule : linter) ->
@ -40,9 +40,7 @@ let filter_parsed_linters_by_path parsed_linters source_file =
~f:(fun path -> ALVar.compare_str_with_alexp (SourceFile.to_rel_path source_file) path) ~f:(fun path -> ALVar.compare_str_with_alexp (SourceFile.to_rel_path source_file) path)
paths paths
in in
let whitelist_ok = let whitelist_ok = List.is_empty linter.whitelist_paths || should_lint linter.whitelist_paths in
List.is_empty linter.whitelist_paths || should_lint linter.whitelist_paths
in
let blacklist_ok = let blacklist_ok =
List.is_empty linter.blacklist_paths || not (should_lint linter.blacklist_paths) List.is_empty linter.blacklist_paths || not (should_lint linter.blacklist_paths)
in in
@ -343,8 +341,7 @@ let expand_formula phi map_ error_msg_ =
expand f1_sub map' error_msg' expand f1_sub map' error_msg'
| Unequal_lengths -> | Unequal_lengths ->
L.(die ExternalError) L.(die ExternalError)
"Formula identifier '%s' is not called with the right number of parameters" name "Formula identifier '%s' is not called with the right number of parameters" name )
)
with Caml.Not_found -> acc with Caml.Not_found -> acc
(* in this case it should be a predicate *) ) (* in this case it should be a predicate *) )
| Not f1 -> | Not f1 ->
@ -491,8 +488,8 @@ let log_frontend_issue method_decl_opt (node : Ctl_parser_types.ast_node)
~ltr:trace ~node_key ~ltr:trace ~node_key
let fill_issue_desc_info_and_log context ~witness ~current_node (issue_desc : CIssue.issue_desc) let fill_issue_desc_info_and_log context ~witness ~current_node (issue_desc : CIssue.issue_desc) loc
loc = =
let process_message message = let process_message message =
remove_new_lines_and_whitespace (expand_message_string context message current_node) remove_new_lines_and_whitespace (expand_message_string context message current_node)
in in
@ -502,8 +499,8 @@ let fill_issue_desc_info_and_log context ~witness ~current_node (issue_desc : CI
try log_frontend_issue context.CLintersContext.current_method witness issue_desc' try log_frontend_issue context.CLintersContext.current_method witness issue_desc'
with CFrontend_errors.IncorrectAssumption e -> with CFrontend_errors.IncorrectAssumption e ->
let trans_unit_ctx = context.CLintersContext.translation_unit_context in let trans_unit_ctx = context.CLintersContext.translation_unit_context in
ClangLogging.log_caught_exception trans_unit_ctx "IncorrectAssumption" e.position ClangLogging.log_caught_exception trans_unit_ctx "IncorrectAssumption" e.position e.source_range
e.source_range e.ast_node e.ast_node
(* Calls the set of hard coded checkers (if any) *) (* Calls the set of hard coded checkers (if any) *)
@ -540,7 +537,7 @@ let invoke_set_of_checkers_on_node parsed_linters context an =
( match an with ( 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. (* Don't run parsed linters on TranslationUnitDecl node.
Because depending on the formula it may give an error at line -1 *) Because depending on the formula it may give an error at line -1 *)
() ()
| _ -> | _ ->
if not CFrontend_config.tableaux_evaluation then if not CFrontend_config.tableaux_evaluation then

@ -95,8 +95,7 @@ let receiver_method_call an =
Ctl_parser_types.ast_node_name (Ctl_parser_types.Decl decl) Ctl_parser_types.ast_node_name (Ctl_parser_types.Decl decl)
| _ -> | _ ->
L.(die ExternalError) L.(die ExternalError)
"receiver_method_call must be called with ObjCMessageExpr, but got %s" "receiver_method_call must be called with ObjCMessageExpr, but got %s" (tag_name_of_node an)
(tag_name_of_node an)
let ivar_name an = let ivar_name an =

@ -7,13 +7,13 @@
open! IStd open! IStd
(** Raised when the parser encounters a violation of a certain invariant *)
exception ALParserInvariantViolationException of string exception ALParserInvariantViolationException of string
(** Raised when the parser encounters a violation of a certain invariant *)
type exc_info type exc_info
(** Raised when any exception from the lexer/parser of AL is caught, to include source-location info *)
exception ALFileException of exc_info exception ALFileException of exc_info
(** Raised when any exception from the lexer/parser of AL is caught, to include source-location info *)
val create_exc_info : string -> Lexing.lexbuf -> exc_info val create_exc_info : string -> Lexing.lexbuf -> exc_info

@ -60,9 +60,7 @@ let rec is_component_or_controller_descendant_impl decl =
CKComponentController. CKComponentController.
Does not recurse into hierarchy. *) Does not recurse into hierarchy. *)
and contains_ck_impl decl_list = and contains_ck_impl decl_list = List.exists ~f:is_component_or_controller_descendant_impl decl_list
List.exists ~f:is_component_or_controller_descendant_impl decl_list
(** An easy way to fix the component kit best practice (** An easy way to fix the component kit best practice
http://componentkit.org/docs/avoid-local-variables.html http://componentkit.org/docs/avoid-local-variables.html
@ -165,8 +163,8 @@ let mutable_local_vars_advice context an =
else None else None
with CFrontend_errors.IncorrectAssumption e -> with CFrontend_errors.IncorrectAssumption e ->
let trans_unit_ctx = context.CLintersContext.translation_unit_context in let trans_unit_ctx = context.CLintersContext.translation_unit_context in
ClangLogging.log_caught_exception trans_unit_ctx "IncorrectAssumption" e.position ClangLogging.log_caught_exception trans_unit_ctx "IncorrectAssumption" e.position e.source_range
e.source_range e.ast_node ; e.ast_node ;
None None
@ -257,9 +255,7 @@ let component_with_unconventional_superclass_advice context an =
in in
match an with 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 = let if_decl_opt = CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface in
CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface
in
if Option.is_some if_decl_opt && is_ck_context context an then if Option.is_some if_decl_opt && is_ck_context context an then
check_interface (Option.value_exn if_decl_opt) check_interface (Option.value_exn if_decl_opt)
else None else None
@ -315,9 +311,7 @@ let component_with_multiple_factory_methods_advice context an =
in in
match an with 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 = let if_decl_opt = CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface in
CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface
in
match if_decl_opt with Some d when is_ck_context context an -> check_interface d | _ -> [] ) match if_decl_opt with Some d when is_ck_context context an -> check_interface d | _ -> [] )
| _ -> | _ ->
[] []

@ -446,11 +446,7 @@ let objc_message_receiver context an =
(* an |= call_method(m) where the name must be exactly m *) (* an |= call_method(m) where the name must be exactly m *)
let call_method an m = let call_method an m =
match get_selector an with match get_selector an with Some selector -> ALVar.compare_str_with_alexp selector m | _ -> false
| Some selector ->
ALVar.compare_str_with_alexp selector m
| _ ->
false
let call_class_method an mname = let call_class_method an mname =
@ -461,8 +457,8 @@ let call_class_method an mname =
ALVar.compare_str_with_alexp omei.omei_selector mname ALVar.compare_str_with_alexp omei.omei_selector mname
| `Instance -> | `Instance ->
(* The ObjC class type, 'Class', is treated as an instance receiver kind. (* The ObjC class type, 'Class', is treated as an instance receiver kind.
We need to check if the receiver is the class type to catch cases like We need to check if the receiver is the class type to catch cases like
[[self class] myClassMethod] *) [[self class] myClassMethod] *)
ALVar.compare_str_with_alexp omei.omei_selector mname && is_receiver_objc_class_type an ALVar.compare_str_with_alexp omei.omei_selector mname && is_receiver_objc_class_type an
| _ -> | _ ->
false ) false )
@ -479,8 +475,8 @@ let call_instance_method an mname =
ALVar.compare_str_with_alexp omei.omei_selector mname ALVar.compare_str_with_alexp omei.omei_selector mname
| `Instance -> | `Instance ->
(* The ObjC class type, 'Class', is treated as an instance receiver kind. (* The ObjC class type, 'Class', is treated as an instance receiver kind.
We need to verify the receiver is not the class type to avoid cases like We need to verify the receiver is not the class type to avoid cases like
[[self class] myClassMethod] *) [[self class] myClassMethod] *)
ALVar.compare_str_with_alexp omei.omei_selector mname ALVar.compare_str_with_alexp omei.omei_selector mname
&& not (is_receiver_objc_class_type an) && not (is_receiver_objc_class_type an)
| _ -> | _ ->
@ -1427,9 +1423,7 @@ let rec get_decl_attributes_for_callexpr_param an =
L.debug Linters Verbose "#####POINTER LOOP UP: '%i'@\n" si.si_pointer ; L.debug Linters Verbose "#####POINTER LOOP UP: '%i'@\n" si.si_pointer ;
match CAst_utils.get_decl_opt_with_decl_ref drti.drti_decl_ref with match CAst_utils.get_decl_opt_with_decl_ref drti.drti_decl_ref with
| Some (FunctionDecl (_, _, _, fdi)) -> | Some (FunctionDecl (_, _, _, fdi)) ->
List.fold fdi.fdi_parameters List.fold fdi.fdi_parameters ~f:(fun acc p -> List.append (get_attr_param p) acc) ~init:[]
~f:(fun acc p -> List.append (get_attr_param p) acc)
~init:[]
| Some (ParmVarDecl _ as d) -> | Some (ParmVarDecl _ as d) ->
get_attr_param d get_attr_param d
| _ -> | _ ->
@ -1590,9 +1584,7 @@ let source_file_matches src_file path_re =
~default:false src_file ~default:false src_file
let is_in_source_file an path_re = let is_in_source_file an path_re = source_file_matches (Ctl_parser_types.get_source_file an) path_re
source_file_matches (Ctl_parser_types.get_source_file an) path_re
let is_referencing_decl_from_source_file an path_re = let is_referencing_decl_from_source_file an path_re =
source_file_matches (Ctl_parser_types.get_referenced_decl_source_file an) path_re source_file_matches (Ctl_parser_types.get_referenced_decl_source_file an) path_re

@ -434,8 +434,7 @@ val get_available_attr_ios_sdk : Ctl_parser_types.ast_node -> string option
val get_selector : Ctl_parser_types.ast_node -> string option val get_selector : Ctl_parser_types.ast_node -> string option
val within_responds_to_selector_block : val within_responds_to_selector_block : CLintersContext.context -> Ctl_parser_types.ast_node -> bool
CLintersContext.context -> Ctl_parser_types.ast_node -> bool
val objc_method_call_within_responds_to_selector_block : val objc_method_call_within_responds_to_selector_block :
CLintersContext.context -> Ctl_parser_types.ast_node -> bool CLintersContext.context -> Ctl_parser_types.ast_node -> bool

@ -261,10 +261,10 @@ module Debug = struct
match root with 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 (* handling special case of DeclStmt with VarDecl: emit the VarDecl node
then emit the statements in DeclStmt as children of VarDecl. This is then emit the statements in DeclStmt as children of VarDecl. This is
because despite being equal, the statements inside VarDecl and those because despite being equal, the statements inside VarDecl and those
inside DeclStmt belong to different instances, hence they fail the inside DeclStmt belong to different instances, hence they fail the
phys_equal check that should colour them *) phys_equal check that should colour them *)
pp_children pp_ast_aux (fun n -> Decl n) fmt next_level var_decl ; pp_children pp_ast_aux (fun n -> Decl n) fmt next_level var_decl ;
pp_stmts fmt (next_level + 1) stmts pp_stmts fmt (next_level + 1) stmts
| Stmt stmt -> | Stmt stmt ->

@ -201,9 +201,8 @@ let get_successor_stmts_of_decl decl =
Option.to_list block_decl_info.Clang_ast_t.bdi_body Option.to_list block_decl_info.Clang_ast_t.bdi_body
| VarDecl (_, _, _, var_decl_info) -> | VarDecl (_, _, _, var_decl_info) ->
Option.to_list var_decl_info.vdi_init_expr Option.to_list var_decl_info.vdi_init_expr
| ObjCIvarDecl (_, _, _, fldi, _) | ObjCIvarDecl (_, _, _, fldi, _) | FieldDecl (_, _, _, fldi) | ObjCAtDefsFieldDecl (_, _, _, fldi)
| FieldDecl (_, _, _, fldi) ->
| ObjCAtDefsFieldDecl (_, _, _, fldi) ->
Option.to_list fldi.fldi_init_expr Option.to_list fldi.fldi_init_expr
| _ -> | _ ->
[] []
@ -232,13 +231,13 @@ let rec is_node_successor_of ~is_successor:succ_node node =
| Stmt _ -> | Stmt _ ->
let node_succ_stmts = get_successor_stmts node in let node_succ_stmts = get_successor_stmts node in
List.exists node_succ_stmts ~f:(fun (s : Clang_ast_t.stmt) -> List.exists node_succ_stmts ~f:(fun (s : Clang_ast_t.stmt) ->
ast_node_equal (Stmt s) succ_node ast_node_equal (Stmt s) succ_node || is_node_successor_of ~is_successor:succ_node (Stmt s)
|| is_node_successor_of ~is_successor:succ_node (Stmt s) ) )
| Decl _ -> | Decl _ ->
let node_succ_decls = get_successor_decls node in let node_succ_decls = get_successor_decls node in
List.exists node_succ_decls ~f:(fun (d : Clang_ast_t.decl) -> List.exists node_succ_decls ~f:(fun (d : Clang_ast_t.decl) ->
ast_node_equal (Decl d) succ_node ast_node_equal (Decl d) succ_node || is_node_successor_of ~is_successor:succ_node (Decl d)
|| is_node_successor_of ~is_successor:succ_node (Decl d) ) )
let get_direct_successor_nodes an = let get_direct_successor_nodes an =
@ -512,8 +511,8 @@ and c_type_equal c_type abs_ctype =
| BuiltinType (_, bi), BuiltIn abi -> | BuiltinType (_, bi), BuiltIn abi ->
builtin_equal bi abi builtin_equal bi abi
| BuiltinType (_, `ObjCId), TypeName ae when ALVar.compare_str_with_alexp "instancetype" ae -> | BuiltinType (_, `ObjCId), TypeName ae when ALVar.compare_str_with_alexp "instancetype" ae ->
(* This is a special case coming from an AttributedType with {ati_attr_kind=`Nonnull} where the (* This is a special case coming from an AttributedType with {ati_attr_kind=`Nonnull} where the
compiler change 'instancetype' to ObjCId *) compiler change 'instancetype' to ObjCId *)
L.(debug Linters Verbose) L.(debug Linters Verbose)
"@\n Special Case when comparing BuiltInType(ObjcId) and TypeName(instancetype)\n" ; "@\n Special Case when comparing BuiltInType(ObjcId) and TypeName(instancetype)\n" ;
true true
@ -529,8 +528,8 @@ and c_type_equal c_type abs_ctype =
| ObjCObjectPointerType (_, qt), _ -> | ObjCObjectPointerType (_, qt), _ ->
check_type_ptr qt.qt_type_ptr abs_ctype check_type_ptr qt.qt_type_ptr abs_ctype
| ObjCObjectType (_, ooti), TypeName ae when ALVar.compare_str_with_alexp "instancetype" ae -> | ObjCObjectType (_, ooti), TypeName ae when ALVar.compare_str_with_alexp "instancetype" ae ->
(* This is a special case coming from an AttributedType with {ati_attr_kind=`Nonnull} where the (* This is a special case coming from an AttributedType with {ati_attr_kind=`Nonnull} where the
compiler change 'instancetype' to ObjCId *) compiler change 'instancetype' to ObjCId *)
check_type_ptr ooti.ooti_base_type abs_ctype check_type_ptr ooti.ooti_base_type abs_ctype
| ObjCObjectType _, ObjCGenProt _ -> | ObjCObjectType _, ObjCGenProt _ ->
objc_object_type_equal c_type abs_ctype objc_object_type_equal c_type abs_ctype

@ -84,7 +84,7 @@ let update_linter_context_map parsed_linters an linter_context_map =
else else
let res = Ctl_parser_types.ast_node_has_kind tl an in let res = Ctl_parser_types.ast_node_has_kind tl an in
(*L.(debug Linters Medium) "@\n Updating linter map for node %i with '%b'" (*L.(debug Linters Medium) "@\n Updating linter map for node %i with '%b'"
(Ctl_parser_types.ast_node_pointer an) res; *) (Ctl_parser_types.ast_node_pointer an) res; *)
ClosureHashtbl.add phi res acc_map ClosureHashtbl.add phi res acc_map
with Caml.Not_found -> with Caml.Not_found ->
Logging.die InternalError "Every linter condition should have an entry in the map." ) Logging.die InternalError "Every linter condition should have an entry in the map." )
@ -220,15 +220,15 @@ let add_valid_formulae an checker lcxt cl =
let pointer = Ctl_parser_types.ast_node_pointer an in *) let pointer = Ctl_parser_types.ast_node_pointer an in *)
let add_in_set phi acc_set = let add_in_set phi acc_set =
(* L.(debug Linters Medium) (* L.(debug Linters Medium)
"@\n **** In (%i, %s) ADDING FORMULA **** @\n %a@\n@\n" pointer name CTL.Debug.pp_formula "@\n **** In (%i, %s) ADDING FORMULA **** @\n %a@\n@\n" pointer name CTL.Debug.pp_formula
phi ; *) phi ; *)
CTLFormulaSet.add phi acc_set CTLFormulaSet.add phi acc_set
in in
let is_valid phi acc_set = CTLFormulaSet.mem phi acc_set in let is_valid phi acc_set = CTLFormulaSet.mem phi acc_set in
let do_formula acc_set phi = let do_formula acc_set phi =
(* L.(debug Linters Medium) (* L.(debug Linters Medium)
"@\n In (%i, %s) Dealing with formula @\n %a@\n" pointer name CTL.Debug.pp_formula phi ; "@\n In (%i, %s) Dealing with formula @\n %a@\n" pointer name CTL.Debug.pp_formula phi ;
L.(debug Linters Medium) "@\n ---------------------------- @\n" ;*) L.(debug Linters Medium) "@\n ---------------------------- @\n" ;*)
match phi with match phi with
| True -> | True ->
add_in_set phi acc_set add_in_set phi acc_set
@ -294,8 +294,8 @@ let report_issue an lcxt linter (*npo_condition*) =
let open Ctl_parser_types in let open Ctl_parser_types in
let open ALIssues in let open ALIssues in
(*let name = Ctl_parser_types.ast_node_kind an in (*let name = Ctl_parser_types.ast_node_kind an in
let pointer = Ctl_parser_types.ast_node_pointer an in let pointer = Ctl_parser_types.ast_node_pointer an in
L.(debug Linters Medium) L.(debug Linters Medium)
"@\n@\n@\n ***** In (%i, %s) Reporting because we found @\n%a@\n@\n@\n@\n" pointer name "@\n@\n@\n ***** In (%i, %s) Reporting because we found @\n%a@\n@\n@\n@\n" pointer name
CTL.Debug.pp_formula linter.condition ;*) CTL.Debug.pp_formula linter.condition ;*)
let loc = ALUtils.location_from_an lcxt an in let loc = ALUtils.location_from_an lcxt an in

@ -105,8 +105,7 @@ let reset () = copy initial ~into:global_stats
let pp f stats = let pp f stats =
let pp_hit_percent hit miss f = let pp_hit_percent hit miss f =
let total = hit + miss in let total = hit + miss in
if Int.equal total 0 then F.pp_print_string f "N/A%%" if Int.equal total 0 then F.pp_print_string f "N/A%%" else F.fprintf f "%d%%" (hit * 100 / total)
else F.fprintf f "%d%%" (hit * 100 / total)
in in
let pp_int_field stats f field = let pp_int_field stats f field =
F.fprintf f "%s= %d@;" (Field.name field) (Field.get field stats) F.fprintf f "%s= %d@;" (Field.name field) (Field.get field stats)
@ -120,8 +119,7 @@ let pp f stats =
Fields.iter ~summary_file_try_load:(pp_int_field stats f) Fields.iter ~summary_file_try_load:(pp_int_field stats f)
~summary_read_from_disk:(pp_int_field stats f) ~summary_read_from_disk:(pp_int_field stats f)
~summary_cache_hits:(pp_cache_hits stats stats.summary_cache_misses f) ~summary_cache_hits:(pp_cache_hits stats stats.summary_cache_misses f)
~summary_cache_misses:(pp_int_field stats f) ~summary_cache_misses:(pp_int_field stats f) ~summary_has_model_queries:(pp_int_field stats f)
~summary_has_model_queries:(pp_int_field stats f)
~ondemand_procs_analyzed:(pp_int_field stats f) ~ondemand_procs_analyzed:(pp_int_field stats f)
~ondemand_local_cache_hits:(pp_cache_hits stats stats.ondemand_local_cache_misses f) ~ondemand_local_cache_hits:(pp_cache_hits stats stats.ondemand_local_cache_misses f)
~ondemand_local_cache_misses:(pp_int_field stats f) ~ondemand_local_cache_misses:(pp_int_field stats f)

@ -8,8 +8,7 @@ open! IStd
module F = Format module F = Format
module type NodeSig = sig module type NodeSig = sig
type t = private type t = private {id: int; pname: Typ.Procname.t; mutable successors: int list; mutable flag: bool}
{id: int; pname: Typ.Procname.t; mutable successors: int list; mutable flag: bool}
val make : int -> Typ.Procname.t -> int list -> t val make : int -> Typ.Procname.t -> int list -> t
@ -144,7 +143,7 @@ let to_dotty g filename =
let remove_unflagged_and_unflag_all {id_map; node_map} = let remove_unflagged_and_unflag_all {id_map; node_map} =
NodeMap.filter_map_inplace NodeMap.filter_map_inplace
(fun _id (n : Node.t) -> (fun _id (n : Node.t) ->
if n.flag then ( Node.unset_flag n ; Some n ) else ( IdMap.remove id_map n.pname ; None ) ) if n.flag then (Node.unset_flag n ; Some n) else (IdMap.remove id_map n.pname ; None) )
node_map node_map

@ -8,8 +8,7 @@ open! IStd
module F = Format module F = Format
module type NodeSig = sig module type NodeSig = sig
type t = private type t = private {id: int; pname: Typ.Procname.t; mutable successors: int list; mutable flag: bool}
{id: int; pname: Typ.Procname.t; mutable successors: int list; mutable flag: bool}
val make : int -> Typ.Procname.t -> int list -> t val make : int -> Typ.Procname.t -> int list -> t

@ -208,8 +208,8 @@ end
let issue_of_cost kind CostIssues.{complexity_increase_issue; zero_issue; infinite_issue} ~delta let issue_of_cost kind CostIssues.{complexity_increase_issue; zero_issue; infinite_issue} ~delta
~prev_item ~prev_item
~curr_item:( {CostItem.cost_item= cost_info; degree_with_term= curr_degree_with_term} as ~curr_item:
curr_item ) = ({CostItem.cost_item= cost_info; degree_with_term= curr_degree_with_term} as curr_item) =
let file = cost_info.Jsonbug_t.loc.file in let file = cost_info.Jsonbug_t.loc.file in
let method_name = cost_info.Jsonbug_t.procedure_name in let method_name = cost_info.Jsonbug_t.procedure_name in
let is_on_ui_thread = cost_info.Jsonbug_t.is_on_ui_thread in let is_on_ui_thread = cost_info.Jsonbug_t.is_on_ui_thread in
@ -413,8 +413,7 @@ let of_reports ~(current_report : Jsonbug_t.report) ~(previous_report : Jsonbug_
let to_files {introduced; fixed; preexisting; costs_summary} destdir = let to_files {introduced; fixed; preexisting; costs_summary} destdir =
Out_channel.write_all (destdir ^/ "introduced.json") Out_channel.write_all (destdir ^/ "introduced.json") ~data:(Jsonbug_j.string_of_report introduced) ;
~data:(Jsonbug_j.string_of_report introduced) ;
Out_channel.write_all (destdir ^/ "fixed.json") ~data:(Jsonbug_j.string_of_report fixed) ; Out_channel.write_all (destdir ^/ "fixed.json") ~data:(Jsonbug_j.string_of_report fixed) ;
Out_channel.write_all (destdir ^/ "preexisting.json") Out_channel.write_all (destdir ^/ "preexisting.json")
~data:(Jsonbug_j.string_of_report preexisting) ; ~data:(Jsonbug_j.string_of_report preexisting) ;

@ -48,9 +48,8 @@ module FileRenamings = struct
with Yojson.Json_error err -> with Yojson.Json_error err ->
L.(die UserError) L.(die UserError)
"Error parsing file renamings: %s@\n\ "Error parsing file renamings: %s@\n\
Expected JSON object of the following form: '%s', but instead got: '%s'" Expected JSON object of the following form: '%s', but instead got: '%s'" err
err "{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"}" "{\"current\": \"aaa.java\", \"previous\": \"BBB.java\"}" (Yojson.Basic.to_string assoc)
(Yojson.Basic.to_string assoc)
in in
match j with match j with
| `List json_renamings -> | `List json_renamings ->

@ -72,8 +72,7 @@ let _read_file_perf_data fname =
match split_class_method_name itm.Perf_profiler_t.function_name with match split_class_method_name itm.Perf_profiler_t.function_name with
| Some (classname, methodname) -> | Some (classname, methodname) ->
let procname = JProcname.make_void_signature_procname ~classname ~methodname in let procname = JProcname.make_void_signature_procname ~classname ~methodname in
global_perf_profiler_data := global_perf_profiler_data := PerfProfilerDataMap.add procname itm !global_perf_profiler_data
PerfProfilerDataMap.add procname itm !global_perf_profiler_data
| _ -> | _ ->
() ()
in in

@ -7,8 +7,8 @@
*) *)
(** Main module for the analysis after the capture phase *) (** Main module for the analysis after the capture phase *)
open! IStd
open! IStd
module F = Format module F = Format
module L = Logging module L = Logging
@ -36,8 +36,8 @@ let analyze_target : SchedulerTypes.target Tasks.doer =
let analyze_proc_name exe_env proc_name = let analyze_proc_name exe_env proc_name =
decr procs_left ; decr procs_left ;
if Int.( <= ) !procs_left 0 then ( if Int.( <= ) !procs_left 0 then (
L.log_task "Analysing block of %d procs, starting with %a@." L.log_task "Analysing block of %d procs, starting with %a@." per_procedure_logging_granularity
per_procedure_logging_granularity Typ.Procname.pp proc_name ; Typ.Procname.pp proc_name ;
procs_left := per_procedure_logging_granularity ) ; procs_left := per_procedure_logging_granularity ) ;
Ondemand.analyze_proc_name_toplevel exe_env proc_name Ondemand.analyze_proc_name_toplevel exe_env proc_name
in in
@ -116,9 +116,7 @@ let get_source_files_to_analyze ~changed_files =
let analyze source_files_to_analyze = let analyze source_files_to_analyze =
if Int.equal Config.jobs 1 then ( if Int.equal Config.jobs 1 then (
let target_files = let target_files = List.rev_map source_files_to_analyze ~f:(fun sf -> SchedulerTypes.File sf) in
List.rev_map source_files_to_analyze ~f:(fun sf -> SchedulerTypes.File sf)
in
Tasks.run_sequentially ~f:analyze_target target_files ; Tasks.run_sequentially ~f:analyze_target target_files ;
BackendStats.get () ) BackendStats.get () )
else ( else (
@ -167,8 +165,8 @@ let invalidate_changed_procedures changed_files =
0 0
in in
L.progress L.progress
"Incremental analysis: %d nodes in reverse analysis call graph, %d of which were \ "Incremental analysis: %d nodes in reverse analysis call graph, %d of which were invalidated \
invalidated @." @."
total_nodes invalidated_nodes ; total_nodes invalidated_nodes ;
ScubaLogging.log_count ~label:"incremental_analysis.total_nodes" ~value:total_nodes ; ScubaLogging.log_count ~label:"incremental_analysis.total_nodes" ~value:total_nodes ;
ScubaLogging.log_count ~label:"incremental_analysis.invalidated_nodes" ~value:invalidated_nodes ; ScubaLogging.log_count ~label:"incremental_analysis.invalidated_nodes" ~value:invalidated_nodes ;

@ -156,16 +156,14 @@ let should_report (issue_kind : Exceptions.severity) issue_type error_desc eclas
in in
List.mem ~equal:IssueType.equal null_deref_issue_types issue_type List.mem ~equal:IssueType.equal null_deref_issue_types issue_type
in in
if issue_type_is_null_deref then Localise.error_desc_is_reportable_bucket error_desc if issue_type_is_null_deref then Localise.error_desc_is_reportable_bucket error_desc else true
else true
(* The reason an issue should be censored (that is, not reported). The empty (* The reason an issue should be censored (that is, not reported). The empty
string (that is "no reason") means that the issue should be reported. *) string (that is "no reason") means that the issue should be reported. *)
let censored_reason (issue_type : IssueType.t) source_file = let censored_reason (issue_type : IssueType.t) source_file =
let filename = SourceFile.to_rel_path source_file in let filename = SourceFile.to_rel_path source_file in
let rejected_by ((issue_type_polarity, issue_type_re), (filename_polarity, filename_re), reason) let rejected_by ((issue_type_polarity, issue_type_re), (filename_polarity, filename_re), reason) =
=
let accepted = let accepted =
(* matches issue_type_re implies matches filename_re *) (* matches issue_type_re implies matches filename_re *)
(not (Bool.equal issue_type_polarity (Str.string_match issue_type_re issue_type.unique_id 0))) (not (Bool.equal issue_type_polarity (Str.string_match issue_type_re issue_type.unique_id 0)))
@ -332,9 +330,8 @@ module JsonCostsPrinter = MakeJsonListPrinter (struct
(CostDomain.BasicCost.pp_degree ~only_bigO:false) (CostDomain.BasicCost.pp_degree ~only_bigO:false)
degree_with_term degree_with_term
; big_o= ; big_o=
Format.asprintf "%a" Format.asprintf "%a" (CostDomain.BasicCost.pp_degree ~only_bigO:true) degree_with_term
(CostDomain.BasicCost.pp_degree ~only_bigO:true) }
degree_with_term }
in in
let cost_info cost = let cost_info cost =
{ Jsonbug_t.polynomial_version= CostDomain.BasicCost.version { Jsonbug_t.polynomial_version= CostDomain.BasicCost.version
@ -407,8 +404,7 @@ let pp_custom_of_report fmt report fields =
| `Issue_field_hash -> | `Issue_field_hash ->
Format.fprintf fmt "%s%s" (comma_separator index) (Caml.Digest.to_hex issue.hash) Format.fprintf fmt "%s%s" (comma_separator index) (Caml.Digest.to_hex issue.hash)
| `Issue_field_line_offset -> | `Issue_field_line_offset ->
Format.fprintf fmt "%s%d" (comma_separator index) Format.fprintf fmt "%s%d" (comma_separator index) (issue.line - issue.procedure_start_line)
(issue.line - issue.procedure_start_line)
| `Issue_field_qualifier_contains_potential_exception_note -> | `Issue_field_qualifier_contains_potential_exception_note ->
Format.pp_print_bool fmt Format.pp_print_bool fmt
(String.is_substring issue.qualifier ~substring:potential_exception_message) (String.is_substring issue.qualifier ~substring:potential_exception_message)
@ -506,9 +502,7 @@ module Stats = struct
let loc = lt.Errlog.lt_loc in let loc = lt.Errlog.lt_loc in
let level = lt.Errlog.lt_level in let level = lt.Errlog.lt_level in
let description = lt.Errlog.lt_description in let description = lt.Errlog.lt_description in
let code = let code = match Printer.LineReader.from_loc linereader loc with Some s -> s | None -> "" in
match Printer.LineReader.from_loc linereader loc with Some s -> s | None -> ""
in
let line = let line =
let pp fmt = let pp fmt =
if description <> "" then if description <> "" then
@ -611,8 +605,7 @@ module StatsLogs = struct
{ analysis_nodes_visited= Summary.Stats.nb_visited summary.stats { analysis_nodes_visited= Summary.Stats.nb_visited summary.stats
; analysis_status= Summary.Stats.failure_kind summary.stats ; analysis_status= Summary.Stats.failure_kind summary.stats
; analysis_total_nodes= Summary.get_proc_desc summary |> Procdesc.get_nodes_num ; analysis_total_nodes= Summary.get_proc_desc summary |> Procdesc.get_nodes_num
; clang_method_kind= ; clang_method_kind= (match lang with Language.Clang -> Some clang_method_kind | _ -> None)
(match lang with Language.Clang -> Some clang_method_kind | _ -> None)
; lang= Language.to_explicit_string lang ; lang= Language.to_explicit_string lang
; method_location= Summary.get_loc summary ; method_location= Summary.get_loc summary
; method_name= Typ.Procname.to_string proc_name ; method_name= Typ.Procname.to_string proc_name
@ -798,11 +791,7 @@ module SummaryStats = struct
module StringMap = PrettyPrintable.MakePPMap (String) module StringMap = PrettyPrintable.MakePPMap (String)
type ('i, 'k) result = type ('i, 'k) result =
| R : | R : {typ: 't typ; get: 'i -> 't; aggrs: ('t, 'k) MetricAggregator.t list} -> ('i, 'k) result
{ typ: 't typ
; get: 'i -> 't
; aggrs: ('t, 'k) MetricAggregator.t list }
-> ('i, 'k) result
let init metrics aggregators = let init metrics aggregators =
List.fold metrics ~init:StringMap.empty ~f:(fun acc (name, M {typ; get}) -> List.fold metrics ~init:StringMap.empty ~f:(fun acc (name, M {typ; get}) ->

@ -19,9 +19,9 @@ let try_capture (attributes : ProcAttributes.t) : ProcAttributes.t option =
let definition_file_opt = SourceFile.of_header decl_file in let definition_file_opt = SourceFile.of_header decl_file in
let try_compile definition_file = let try_compile definition_file =
(* Use the cfg as a proxy to find out whether definition_file was already captured. If it (* Use the cfg as a proxy to find out whether definition_file was already captured. If it
was, there is no point in trying to capture it again. Treat existance of the cfg as a was, there is no point in trying to capture it again. Treat existance of the cfg as a
barrier - if it exists it means that all attributes files have been created - write logic barrier - if it exists it means that all attributes files have been created - write logic
is defined in Cfg.store *) is defined in Cfg.store *)
if not (SourceFiles.is_captured decl_file) then ( if not (SourceFiles.is_captured decl_file) then (
L.(debug Capture Verbose) "Started capture of %a...@\n" SourceFile.pp definition_file ; L.(debug Capture Verbose) "Started capture of %a...@\n" SourceFile.pp definition_file ;
Timeout.suspend_existing_timeout ~keep_symop_total:true ; Timeout.suspend_existing_timeout ~keep_symop_total:true ;
@ -50,9 +50,9 @@ let try_capture (attributes : ProcAttributes.t) : ProcAttributes.t option =
load_defined_attributes is None, it may mean couple of things: load_defined_attributes is None, it may mean couple of things:
- proc_name hasn't been captured yet, so it needs to get captured (most likely scenario) - proc_name hasn't been captured yet, so it needs to get captured (most likely scenario)
- there was a race and proc_name got captured by the time we checked whether - there was a race and proc_name got captured by the time we checked whether
cfg_filename exists. In this case it's important to refetch attributes from disk because cfg_filename exists. In this case it's important to refetch attributes from disk because
contents may have changed (attributes file for proc_name may be there now) contents may have changed (attributes file for proc_name may be there now)
Caveat: it's possible that procedure will be captured in some other unrelated file Caveat: it's possible that procedure will be captured in some other unrelated file
later - infer may ignore it then. *) later - infer may ignore it then. *)
Attributes.load_defined attributes.proc_name Attributes.load_defined attributes.proc_name

@ -7,32 +7,31 @@
open! IStd open! IStd
include include sig
sig (* ignore dead modules added by @@deriving fields *)
(* ignore dead modules added by @@deriving fields *) [@@@warning "-60"]
[@@@warning "-60"]
(** analysis results *) (** analysis results *)
type t = type t =
{ annot_map: AnnotationReachabilityDomain.t option { annot_map: AnnotationReachabilityDomain.t option
; biabduction: BiabductionSummary.t option ; biabduction: BiabductionSummary.t option
; buffer_overrun_analysis: BufferOverrunAnalysisSummary.t option ; buffer_overrun_analysis: BufferOverrunAnalysisSummary.t option
; buffer_overrun_checker: BufferOverrunCheckerSummary.t option ; buffer_overrun_checker: BufferOverrunCheckerSummary.t option
; class_loads: ClassLoadsDomain.summary option ; class_loads: ClassLoadsDomain.summary option
; cost: CostDomain.summary option ; cost: CostDomain.summary option
; impurity: ImpurityDomain.t option ; impurity: ImpurityDomain.t option
; lab_resource_leaks: ResourceLeakDomain.summary option ; lab_resource_leaks: ResourceLeakDomain.summary option
; litho_graphql_field_access: LithoDomain.t option ; litho_graphql_field_access: LithoDomain.t option
; litho_required_props: LithoDomain.t option ; litho_required_props: LithoDomain.t option
; pulse: PulseSummary.t option ; pulse: PulseSummary.t option
; purity: PurityDomain.summary option ; purity: PurityDomain.summary option
; quandary: QuandarySummary.t option ; quandary: QuandarySummary.t option
; racerd: RacerDDomain.summary option ; racerd: RacerDDomain.summary option
; siof: SiofDomain.Summary.t option ; siof: SiofDomain.Summary.t option
; starvation: StarvationDomain.summary option ; starvation: StarvationDomain.summary option
; typestate: TypeState.t option ; typestate: TypeState.t option
; uninit: UninitDomain.Summary.t option } ; uninit: UninitDomain.Summary.t option }
[@@deriving fields] [@@deriving fields]
end end
val pp : Pp.env -> Format.formatter -> t -> unit val pp : Pp.env -> Format.formatter -> t -> unit

@ -233,7 +233,7 @@ let compute_mem_stats () =
; minor_heap_kb= words_to_kb (float_of_int gc_ctrl.minor_heap_size) } ; minor_heap_kb= words_to_kb (float_of_int gc_ctrl.minor_heap_size) }
in in
(* We log number of bytes instead of a larger unit in EventLogger so the EventLogger output can (* We log number of bytes instead of a larger unit in EventLogger so the EventLogger output can
display in whatever format fits best *) display in whatever format fits best *)
let mem = let mem =
Some Some
{ EventLogger.minor_heap_mem= words_to_bytes gc_stats.minor_words { EventLogger.minor_heap_mem= words_to_bytes gc_stats.minor_words

@ -35,13 +35,13 @@ let print_usage_exit err_s =
let spec_files_from_cmdline () = let spec_files_from_cmdline () =
if CLOpt.is_originator then ( if CLOpt.is_originator then (
(* Find spec files specified by command-line arguments. Not run at init time since the specs (* Find spec files specified by command-line arguments. Not run at init time since the specs
files may be generated between init and report time. *) files may be generated between init and report time. *)
List.iter List.iter
~f:(fun arg -> ~f:(fun arg ->
if (not (Filename.check_suffix arg Config.specs_files_suffix)) && arg <> "." then if (not (Filename.check_suffix arg Config.specs_files_suffix)) && arg <> "." then
print_usage_exit ("file " ^ arg ^ ": arguments must be .specs files") ) print_usage_exit ("file " ^ arg ^ ": arguments must be .specs files") )
Config.anon_args ; Config.anon_args ;
if Config.test_filtering then ( Inferconfig.test () ; L.exit 0 ) ; if Config.test_filtering then (Inferconfig.test () ; L.exit 0) ;
if List.is_empty Config.anon_args then load_specfiles () else List.rev Config.anon_args ) if List.is_empty Config.anon_args then load_specfiles () else List.rev Config.anon_args )
else load_specfiles () else load_specfiles ()

@ -86,8 +86,7 @@ let collect_all_stats_files () =
let buck_out_parent = Filename.concat p Filename.parent_dir_name in let buck_out_parent = Filename.concat p Filename.parent_dir_name in
let targets_files = let targets_files =
List.map List.map
~f:(fun (t, p) -> ~f:(fun (t, p) -> (t, find_stats_files_in_dir (concatenate_paths buck_out_parent p)))
(t, find_stats_files_in_dir (concatenate_paths buck_out_parent p)) )
r r
in in
Ok (Buck_out targets_files) Ok (Buck_out targets_files)

@ -64,8 +64,7 @@ let iterate_procedure_callbacks exe_env summary =
let is_specialized = Procdesc.is_specialized proc_desc in let is_specialized = Procdesc.is_specialized proc_desc in
List.fold ~init:summary List.fold ~init:summary
~f:(fun summary {name; dynamic_dispatch; language; callback} -> ~f:(fun summary {name; dynamic_dispatch; language; callback} ->
if Language.equal language procedure_language && (dynamic_dispatch || not is_specialized) if Language.equal language procedure_language && (dynamic_dispatch || not is_specialized) then (
then (
PerfEvent.( PerfEvent.(
log (fun logger -> log (fun logger ->
log_begin_event logger ~name ~categories:["backend"] log_begin_event logger ~name ~categories:["backend"]

@ -41,8 +41,7 @@ type coordinate = {id: int; lambda: int} [@@deriving compare]
(* define a link between two nodes. src_fld/trg_fld define the label of the src/trg field. It is*) (* define a link between two nodes. src_fld/trg_fld define the label of the src/trg field. It is*)
(* useful for having nodes from within a struct and/or to inside a struct *) (* useful for having nodes from within a struct and/or to inside a struct *)
type link = type link = {kind: kind_of_links; src: coordinate; src_fld: string; trg: coordinate; trg_fld: string}
{kind: kind_of_links; src: coordinate; src_fld: string; trg: coordinate; trg_fld: string}
[@@deriving compare] [@@deriving compare]
let equal_link = [%compare.equal: link] let equal_link = [%compare.equal: link]
@ -272,8 +271,7 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) lis
incr dotty_state_count ; incr dotty_state_count ;
let coo = mk_coordinate n lambda in let coo = mk_coordinate n lambda in
match hpred with match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when (not (Exp.equal e Exp.zero)) && !print_full_prop ->
->
let e_color_str = color_to_str (exp_color hpred e) in let e_color_str = color_to_str (exp_color hpred e) in
[Dotdangling (coo, e, e_color_str)] [Dotdangling (coo, e, e_color_str)]
| Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) -> | Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) ->
@ -324,8 +322,7 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda : (Sil.hpred * int) lis
| [] -> | [] ->
[] []
| d :: candidates -> | d :: candidates ->
if is_allocated d then subtract_allocated candidates if is_allocated d then subtract_allocated candidates else d :: subtract_allocated candidates
else d :: subtract_allocated candidates
in in
let candidate_dangling = List.concat_map ~f:get_rhs_predicate sigma_lambda in let candidate_dangling = List.concat_map ~f:get_rhs_predicate sigma_lambda in
let candidate_dangling = filter_duplicate candidate_dangling [] in let candidate_dangling = filter_duplicate candidate_dangling [] in
@ -365,8 +362,7 @@ let rec dotty_mk_node pe sigma =
let e1_color_str = color_to_str (exp_color e1) in let e1_color_str = color_to_str (exp_color e1) in
incr dotty_state_count ; incr dotty_state_count ;
(* increment once more n+1 is the box for e4 *) (* increment once more n+1 is the box for e4 *)
[ Dotdllseg [Dotdllseg (mk_coordinate n lambda, e1, e2, e3, e4, k, hpara_dll.Sil.body_dll, e1_color_str)]
(mk_coordinate n lambda, e1, e2, e3, e4, k, hpara_dll.Sil.body_dll, e1_color_str) ]
in in
match sigma with match sigma with
| [] -> | [] ->
@ -589,8 +585,8 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
~f:(fun (k, lab_src, m, lab_trg) -> ~f:(fun (k, lab_src, m, lab_trg) ->
mk_link k mk_link k
(mk_coordinate (n + 1) lambda) (mk_coordinate (n + 1) lambda)
(strip_special_chars lab_src) (mk_coordinate m lambda) (strip_special_chars lab_src) (mk_coordinate m lambda) (strip_special_chars lab_trg)
(strip_special_chars lab_trg) ) )
target_list target_list
in in
let links_from_elements = List.concat_map ~f:ff (n :: nl) in let links_from_elements = List.concat_map ~f:ff (n :: nl) in
@ -636,8 +632,8 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
trg_label ] trg_label ]
else [] else []
in in
lnk_from_address_struct @ links_from_fields lnk_from_address_struct @ links_from_fields @ dotty_mk_set_links dotnodes sigma' p f cycle
@ dotty_mk_set_links dotnodes sigma' p f cycle ) )
| (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda) :: sigma' -> ( | (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda) :: sigma' -> (
let src = look_up dotnodes e lambda in let src = look_up dotnodes e lambda in
match src with match src with
@ -719,7 +715,7 @@ let print_kind f kind =
"style=dashed; color=blue" !dotty_state_count !lambda_counter !lambda_counter "style=dashed; color=blue" !dotty_state_count !lambda_counter !lambda_counter
"style=filled, color= lightblue" ; "style=filled, color= lightblue" ;
(* F.fprintf f "state%iL%i -> struct%iL%i:%s [color=\"lightblue \" arrowhead=none] @\n" (* F.fprintf f "state%iL%i -> struct%iL%i:%s [color=\"lightblue \" arrowhead=none] @\n"
!dotty_state_count !lambda_counter no lev lab;*) !dotty_state_count !lambda_counter no lev lab;*)
incr dotty_state_count ) incr dotty_state_count )
@ -745,8 +741,8 @@ let dotty_pp_link f link =
F.fprintf f "struct%iL%i:%s%iL%i -> state%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1 lambda1 F.fprintf f "struct%iL%i:%s%iL%i -> state%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1 lambda1
n2 lambda2 n2 lambda2
| _, LinkRetainCycle -> | _, LinkRetainCycle ->
F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\", color= red]@\n" n1 F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\", color= red]@\n" n1 lambda1
lambda1 src_fld n1 lambda1 n2 lambda2 trg_fld n2 lambda2 src_fld n1 lambda1 n2 lambda2 trg_fld n2 lambda2
| _, LinkStructToStruct when !print_full_prop -> | _, LinkStructToStruct when !print_full_prop ->
F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1 F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1
lambda1 n2 lambda2 trg_fld n2 lambda2 lambda1 n2 lambda2 trg_fld n2 lambda2
@ -844,8 +840,7 @@ let rec print_struct f pe e te l coo c =
else else
F.fprintf f F.fprintf f
" node [%s]; @\n struct%iL%i [label=\"{<%s%iL%i> OBJECT: %s } | %a\" ] fontcolor=%s@\n" " node [%s]; @\n struct%iL%i [label=\"{<%s%iL%i> OBJECT: %s } | %a\" ] fontcolor=%s@\n"
"shape=record" n lambda e_no_special_char n lambda print_type (struct_to_dotty_str pe coo) l "shape=record" n lambda e_no_special_char n lambda print_type (struct_to_dotty_str pe coo) l c ;
c ;
F.fprintf f "}@\n" F.fprintf f "}@\n"
@ -868,9 +863,8 @@ and print_sll f pe nesting k e1 coo =
incr dotty_state_count ; incr dotty_state_count ;
( match k with ( match k with
| Sil.Lseg_NE -> | Sil.Lseg_NE ->
F.fprintf f F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list NE\";"
"subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list NE\";" n' n' lambda "style=filled; color=lightgrey;"
lambda "style=filled; color=lightgrey;"
| Sil.Lseg_PE -> | Sil.Lseg_PE ->
F.fprintf f F.fprintf f
"subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list PE\";" n' "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list PE\";" n'
@ -935,9 +929,7 @@ and dotty_pp_state f pe cycle dotnode =
| Dotpointsto (coo, e1, c) when !print_full_prop -> | Dotpointsto (coo, e1, c) when !print_full_prop ->
dotty_exp coo e1 c false dotty_exp coo e1 c false
| Dotstruct (coo, e1, l, c, te) -> | Dotstruct (coo, e1, l, c, te) ->
let l' = let l' = if !print_full_prop then l else List.filter ~f:(fun edge -> in_cycle cycle edge) l in
if !print_full_prop then l else List.filter ~f:(fun edge -> in_cycle cycle edge) l
in
print_struct f pe e1 te l' coo c print_struct f pe e1 te l' coo c
| Dotarray (coo, e1, e2, l, _, c) when !print_full_prop -> | Dotarray (coo, e1, e2, l, _, c) when !print_full_prop ->
print_array f pe e1 e2 l coo c print_array f pe e1 e2 l coo c
@ -1149,8 +1141,7 @@ let pp_cfgnode pdesc fmt (n : Procdesc.Node.t) =
(* don't print exception edges to the exit node *) (* don't print exception edges to the exit node *)
() ()
| _ -> | _ ->
F.fprintf fmt "@\n\t %a -> %a %s;" (pp_cfgnodename pname) n1 (pp_cfgnodename pname) n2 F.fprintf fmt "@\n\t %a -> %a %s;" (pp_cfgnodename pname) n1 (pp_cfgnodename pname) n2 color
color
in in
List.iter ~f:(fun n' -> print_edge n n' false) (Procdesc.Node.get_succs n) ; List.iter ~f:(fun n' -> print_edge n n' false) (Procdesc.Node.get_succs n) ;
List.iter ~f:(fun n' -> print_edge n n' true) (Procdesc.Node.get_exn n) List.iter ~f:(fun n' -> print_edge n n' true) (Procdesc.Node.get_exn n)

@ -213,7 +213,7 @@ and exp_lv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option =
let seen = Exp.Set.add e seen_ in let seen = Exp.Set.add e seen_ in
match Prop.exp_normalize_noabs tenv Sil.sub_empty e with match Prop.exp_normalize_noabs tenv Sil.sub_empty e with
| Exp.Const c -> | Exp.Const c ->
if verbose then ( L.d_str "exp_lv_dexp: constant " ; Sil.d_exp e ; L.d_ln () ) ; if verbose then (L.d_str "exp_lv_dexp: constant " ; Sil.d_exp e ; L.d_ln ()) ;
Some (DExp.Dderef (DExp.Dconst c)) Some (DExp.Dderef (DExp.Dconst c))
| Exp.BinOp (Binop.PlusPI, e1, e2) -> ( | Exp.BinOp (Binop.PlusPI, e1, e2) -> (
if verbose then ( if verbose then (
@ -311,7 +311,7 @@ and exp_rv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option =
let seen = Exp.Set.add e seen_ in let seen = Exp.Set.add e seen_ in
match e with match e with
| Exp.Const c -> | Exp.Const c ->
if verbose then ( L.d_str "exp_rv_dexp: constant " ; Sil.d_exp e ; L.d_ln () ) ; if verbose then (L.d_str "exp_rv_dexp: constant " ; Sil.d_exp e ; L.d_ln ()) ;
Some (DExp.Dconst c) Some (DExp.Dconst c)
| Exp.Lvar pv -> | Exp.Lvar pv ->
if verbose then ( if verbose then (
@ -346,24 +346,24 @@ and exp_rv_dexp_ tenv (seen_ : Exp.Set.t) node e : DExp.t option =
| Some de1, Some de2 -> | Some de1, Some de2 ->
Some (DExp.Darray (de1, de2)) ) Some (DExp.Darray (de1, de2)) )
| Exp.BinOp (op, e1, e2) -> ( | Exp.BinOp (op, e1, e2) -> (
if verbose then ( L.d_str "exp_rv_dexp: BinOp " ; Sil.d_exp e ; L.d_ln () ) ; if verbose then (L.d_str "exp_rv_dexp: BinOp " ; Sil.d_exp e ; L.d_ln ()) ;
match (exp_rv_dexp_ tenv seen node e1, exp_rv_dexp_ tenv seen node e2) with match (exp_rv_dexp_ tenv seen node e1, exp_rv_dexp_ tenv seen node e2) with
| None, _ | _, None -> | None, _ | _, None ->
None None
| Some de1, Some de2 -> | Some de1, Some de2 ->
Some (DExp.Dbinop (op, de1, de2)) ) Some (DExp.Dbinop (op, de1, de2)) )
| Exp.UnOp (op, e1, _) -> ( | Exp.UnOp (op, e1, _) -> (
if verbose then ( L.d_str "exp_rv_dexp: UnOp " ; Sil.d_exp e ; L.d_ln () ) ; if verbose then (L.d_str "exp_rv_dexp: UnOp " ; Sil.d_exp e ; L.d_ln ()) ;
match exp_rv_dexp_ tenv seen node e1 with match exp_rv_dexp_ tenv seen node e1 with
| None -> | None ->
None None
| Some de1 -> | Some de1 ->
Some (DExp.Dunop (op, de1)) ) Some (DExp.Dunop (op, de1)) )
| Exp.Cast (_, e1) -> | Exp.Cast (_, e1) ->
if verbose then ( L.d_str "exp_rv_dexp: Cast " ; Sil.d_exp e ; L.d_ln () ) ; if verbose then (L.d_str "exp_rv_dexp: Cast " ; Sil.d_exp e ; L.d_ln ()) ;
exp_rv_dexp_ tenv seen node e1 exp_rv_dexp_ tenv seen node e1
| Exp.Sizeof {typ; dynamic_length; subtype} -> | Exp.Sizeof {typ; dynamic_length; subtype} ->
if verbose then ( L.d_str "exp_rv_dexp: type " ; Sil.d_exp e ; L.d_ln () ) ; if verbose then (L.d_str "exp_rv_dexp: type " ; Sil.d_exp e ; L.d_ln ()) ;
Some Some
(DExp.Dsizeof (typ, Option.bind dynamic_length ~f:(exp_rv_dexp_ tenv seen node), subtype)) (DExp.Dsizeof (typ, Option.bind dynamic_length ~f:(exp_rv_dexp_ tenv seen node), subtype))
| _ -> | _ ->
@ -564,7 +564,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
(** find the dexp, if any, where the given value is stored (** find the dexp, if any, where the given value is stored
also return the type of the value if found *) also return the type of the value if found *)
let vpath_find tenv prop exp_ : DExp.t option * Typ.t option = let vpath_find tenv prop exp_ : DExp.t option * Typ.t option =
if verbose then ( L.d_str "in vpath_find exp:" ; Sil.d_exp exp_ ; L.d_ln () ) ; if verbose then (L.d_str "in vpath_find exp:" ; Sil.d_exp exp_ ; L.d_ln ()) ;
let rec find sigma_acc sigma_todo exp = let rec find sigma_acc sigma_todo exp =
let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) = let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) =
match se with match se with

@ -87,8 +87,7 @@ val explain_dereference_as_caller_expression :
(** return a description explaining value [exp] in [prop] in terms of a source expression (** return a description explaining value [exp] in [prop] in terms of a source expression
using the formal parameters of the call *) using the formal parameters of the call *)
val explain_divide_by_zero : val explain_divide_by_zero : Tenv.t -> Exp.t -> Procdesc.Node.t -> Location.t -> Localise.error_desc
Tenv.t -> Exp.t -> Procdesc.Node.t -> Location.t -> Localise.error_desc
(** explain a division by zero *) (** explain a division by zero *)
val explain_condition_always_true_false : val explain_condition_always_true_false :

@ -70,8 +70,8 @@ let file_data_to_tenv file_data =
let file_data_to_integer_type_widths file_data = let file_data_to_integer_type_widths file_data =
if is_none file_data.integer_type_widths then if is_none file_data.integer_type_widths then
file_data.integer_type_widths file_data.integer_type_widths <-
<- Option.first_some (Typ.IntegerWidths.load file_data.source) (Some Typ.IntegerWidths.java) ; Option.first_some (Typ.IntegerWidths.load file_data.source) (Some Typ.IntegerWidths.java) ;
file_data.integer_type_widths file_data.integer_type_widths

@ -19,8 +19,7 @@ let merge_global_tenvs infer_deps_file =
let global_tenv_path = let global_tenv_path =
infer_out_src ^/ Config.global_tenv_filename |> DB.filename_from_string infer_out_src ^/ Config.global_tenv_filename |> DB.filename_from_string
in in
Tenv.read global_tenv_path Tenv.read global_tenv_path |> Option.iter ~f:(fun tenv -> Tenv.merge ~src:tenv ~dst:global_tenv)
|> Option.iter ~f:(fun tenv -> Tenv.merge ~src:tenv ~dst:global_tenv)
in in
Utils.iter_infer_deps ~project_root:Config.project_root ~f:merge infer_deps_file ; Utils.iter_infer_deps ~project_root:Config.project_root ~f:merge infer_deps_file ;
Tenv.store_global global_tenv ; Tenv.store_global global_tenv ;

@ -191,8 +191,7 @@ let run_proc_analysis ~caller_pdesc callee_pdesc =
let stats = Summary.Stats.update summary.stats ~failure_kind:kind in let stats = Summary.Stats.update summary.stats ~failure_kind:kind in
let payloads = let payloads =
let biabduction = let biabduction =
Some Some BiabductionSummary.{preposts= []; phase= summary.payloads.biabduction |> opt_get_phase}
BiabductionSummary.{preposts= []; phase= summary.payloads.biabduction |> opt_get_phase}
in in
{summary.payloads with biabduction} {summary.payloads with biabduction}
in in
@ -231,7 +230,7 @@ let run_proc_analysis ~caller_pdesc callee_pdesc =
match exn with match exn with
| SymOp.Analysis_failure_exe kind -> | SymOp.Analysis_failure_exe kind ->
(* in production mode, log the timeout/crash and continue with the summary we had before (* in production mode, log the timeout/crash and continue with the summary we had before
the failure occurred *) the failure occurred *)
log_error_and_continue exn initial_callee_summary kind log_error_and_continue exn initial_callee_summary kind
| _ -> | _ ->
(* this happens with assert false or some other unrecognized exception *) (* this happens with assert false or some other unrecognized exception *)
@ -259,13 +258,13 @@ let dump_duplicate_procs source_file procs =
{ is_defined= { is_defined=
true true
(* likely not needed: if [pname] is part of [procs] then it *is* defined, so we (* likely not needed: if [pname] is part of [procs] then it *is* defined, so we
expect the attribute to be defined too *) expect the attribute to be defined too *)
; translation_unit ; translation_unit
; loc } ; loc }
when (* defined in another file *) when (* defined in another file *)
(not (SourceFile.equal source_file translation_unit)) (not (SourceFile.equal source_file translation_unit))
&& (* really defined in that file and not in an include *) && (* really defined in that file and not in an include *)
SourceFile.equal translation_unit loc.file -> SourceFile.equal translation_unit loc.file ->
Some (pname, translation_unit) Some (pname, translation_unit)
| _ -> | _ ->
None ) None )
@ -275,8 +274,8 @@ let dump_duplicate_procs source_file procs =
~append:true ~perm:0o666 ~f:(fun outc -> ~append:true ~perm:0o666 ~f:(fun outc ->
let fmt = F.formatter_of_out_channel outc in let fmt = F.formatter_of_out_channel outc in
List.iter duplicate_procs ~f:(fun (pname, source_captured) -> List.iter duplicate_procs ~f:(fun (pname, source_captured) ->
F.fprintf fmt "DUPLICATE_SYMBOLS source:%a source_captured:%a pname:%a@\n" F.fprintf fmt "DUPLICATE_SYMBOLS source:%a source_captured:%a pname:%a@\n" SourceFile.pp
SourceFile.pp source_file SourceFile.pp source_captured Typ.Procname.pp pname ) ; source_file SourceFile.pp source_captured Typ.Procname.pp pname ) ;
F.pp_print_flush fmt () ) F.pp_print_flush fmt () )
in in
if not (List.is_empty duplicate_procs) then output_to_file duplicate_procs if not (List.is_empty duplicate_procs) then output_to_file duplicate_procs

@ -51,8 +51,8 @@ module VarDomain = Liveness.Domain
each pvar in to_nullify afer we finish the analysis. Nullify instructions speed up the analysis each pvar in to_nullify afer we finish the analysis. Nullify instructions speed up the analysis
by enabling it to GC state that will no longer be read. *) by enabling it to GC state that will no longer be read. *)
module NullifyTransferFunctions = struct module NullifyTransferFunctions = struct
(** (reaching non-nullified vars) * (vars to nullify) *)
module Domain = AbstractDomain.Pair (VarDomain) (VarDomain) module Domain = AbstractDomain.Pair (VarDomain) (VarDomain)
(** (reaching non-nullified vars) * (vars to nullify) *)
module CFG = ProcCfg.Exceptional module CFG = ProcCfg.Exceptional

@ -119,10 +119,10 @@ let is_suppressed ?(field_name = None) tenv proc_desc kind =
let lookup = Tenv.lookup tenv in let lookup = Tenv.lookup tenv in
let proc_attributes = Procdesc.get_attributes proc_desc in let proc_attributes = Procdesc.get_attributes proc_desc in
(* Errors can be suppressed with annotations. An error of kind CHECKER_ERROR_NAME can be (* Errors can be suppressed with annotations. An error of kind CHECKER_ERROR_NAME can be
suppressed with the following annotations: suppressed with the following annotations:
- @android.annotation.SuppressLint("checker-error-name") - @android.annotation.SuppressLint("checker-error-name")
- @some.PrefixErrorName - @some.PrefixErrorName
where the kind matching is case - insensitive and ignores '-' and '_' characters. *) where the kind matching is case - insensitive and ignores '-' and '_' characters. *)
let annotation_matches (a : Annot.t) = let annotation_matches (a : Annot.t) =
let normalize str = Str.global_replace (Str.regexp "[_-]") "" (String.lowercase str) in let normalize str = Str.global_replace (Str.regexp "[_-]") "" (String.lowercase str) in
let drop_prefix str = Str.replace_first (Str.regexp "^[A-Za-z]+_") "" str in let drop_prefix str = Str.replace_first (Str.regexp "^[A-Za-z]+_") "" str in

@ -43,8 +43,7 @@ let mk_command_doc ~see_also:see_also_commands ?environment:environment_opt ?fil
Cmdliner.Manpage.s_files section ) ] Cmdliner.Manpage.s_files section ) ]
in in
CLOpt.mk_command_doc ~section ~version:Version.versionString CLOpt.mk_command_doc ~section ~version:Version.versionString
~date:Version.man_pages_last_modify_date ~synopsis:[`Pre synopsis] ~environment ~files ~date:Version.man_pages_last_modify_date ~synopsis:[`Pre synopsis] ~environment ~files ~see_also
~see_also
let analyze = let analyze =
@ -86,8 +85,8 @@ let compile =
~description: ~description:
[ `P [ `P
"Intercepts compilation commands similarly to $(b,infer-capture), but simply execute \ "Intercepts compilation commands similarly to $(b,infer-capture), but simply execute \
these compilation commands and do not perform any translation of the source files. \ these compilation commands and do not perform any translation of the source files. This \
This can be useful to configure build systems or for debugging purposes." ] can be useful to configure build systems or for debugging purposes." ]
~examples: ~examples:
[ `P [ `P
"$(b,cmake)(1) hardcodes the absolute paths to the compiler inside the Makefiles it \ "$(b,cmake)(1) hardcodes the absolute paths to the compiler inside the Makefiles it \
@ -151,8 +150,8 @@ $(b,infer) $(i,[options])|}
languages of the C family, and a command to build them, infer produces a list of \ languages of the C family, and a command to build them, infer produces a list of \
potential issues." potential issues."
; `P ; `P
"Infer consists of a collection of tools referenced in the $(i,SEE ALSO) section of \ "Infer consists of a collection of tools referenced in the $(i,SEE ALSO) section of this \
this manual. See their respective manuals for more information." manual. See their respective manuals for more information."
; `P ; `P
"When run without a subcommand, and if a compilation command is specified via the \ "When run without a subcommand, and if a compilation command is specified via the \
$(b,--) option or one of the $(b,--clang-compilation-database[-escaped]) options, then \ $(b,--) option or one of the $(b,--clang-compilation-database[-escaped]) options, then \
@ -171,9 +170,9 @@ $(b,infer) $(i,[options])|}
inferconfig_file CLOpt.args_env_var CLOpt.args_env_var inferconfig_file inferconfig_file CLOpt.args_env_var CLOpt.args_env_var inferconfig_file
CLOpt.args_env_var Cmdliner.Manpage.s_environment Cmdliner.Manpage.s_files) CLOpt.args_env_var Cmdliner.Manpage.s_environment Cmdliner.Manpage.s_files)
; `P ; `P
"Options can be specified inside an argument file $(i,file) by passing \ "Options can be specified inside an argument file $(i,file) by passing $(b,@)$(i,file) \
$(b,@)$(i,file) as argument. The format is one option per line, and enclosing single \ as argument. The format is one option per line, and enclosing single ' and double \" \
' and double \" quotes are ignored." quotes are ignored."
; `P ; `P
"Options without a default value (e.g., $(b,--linter)) and options with list-like \ "Options without a default value (e.g., $(b,--linter)) and options with list-like \
values (e.g., $(b,--Xbuck)) all have a corresponding $(b,--option-reset) flag that \ values (e.g., $(b,--Xbuck)) all have a corresponding $(b,--option-reset) flag that \
@ -197,9 +196,9 @@ $(b,infer) $(i,[options])|}
inferconfig_env_var inferconfig_file Cmdliner.Manpage.s_files) inferconfig_env_var inferconfig_file Cmdliner.Manpage.s_files)
; `P ; `P
(Printf.sprintf (Printf.sprintf
"If $(b,%s) is set to \"1\", then infer commands will exit with an error code in \ "If $(b,%s) is set to \"1\", then infer commands will exit with an error code in some \
some cases when otherwise a simple warning would be emitted on stderr, for instance \ cases when otherwise a simple warning would be emitted on stderr, for instance if a \
if a deprecated form of an option is used." deprecated form of an option is used."
CLOpt.strict_mode_env_var) ] CLOpt.strict_mode_env_var) ]
~files: ~files:
[ `P [ `P
@ -224,8 +223,8 @@ $(b,infer) $(i,[options])|}
; `P "- cumulative options are JSON arrays of the appropriate type" ; `P "- cumulative options are JSON arrays of the appropriate type"
; `P ; `P
(Printf.sprintf (Printf.sprintf
"Infer will look for an $(b,%s) file in the current directory, then its parent, \ "Infer will look for an $(b,%s) file in the current directory, then its parent, etc., \
etc., stopping at the first $(b,%s) file found." stopping at the first $(b,%s) file found."
inferconfig_file inferconfig_file) inferconfig_file inferconfig_file)
; `P "Example:" ; `P "Example:"
; `Pre ; `Pre
@ -242,8 +241,8 @@ let report =
~synopsis:"$(b,infer) $(b,report) $(i,[options]) [$(i,file.specs)...]" ~synopsis:"$(b,infer) $(b,report) $(i,[options]) [$(i,file.specs)...]"
~description: ~description:
[ `P [ `P
"Read, convert, and print .specs files in the results directory. Each spec is printed \ "Read, convert, and print .specs files in the results directory. Each spec is printed to \
to standard output unless option -q is used." standard output unless option -q is used."
; `P ; `P
"If no specs file are passed on the command line, process all the .specs in the results \ "If no specs file are passed on the command line, process all the .specs in the results \
directory." ] directory." ]
@ -254,16 +253,15 @@ let reportdiff =
mk_command_doc ~title:"Infer Report Difference" mk_command_doc ~title:"Infer Report Difference"
~short_description:"compute the differences between two infer reports" ~short_description:"compute the differences between two infer reports"
~synopsis: ~synopsis:
"$(b,infer) $(b,reportdiff) $(b,--report-current) $(i,file) $(b,--report-previous) \ "$(b,infer) $(b,reportdiff) $(b,--report-current) $(i,file) $(b,--report-previous) $(i,file) \
$(i,file) $(i,[options])" $(i,[options])"
~description: ~description:
[ `P [ `P
"Given two infer reports $(i,previous) and $(i,current), compute the following three \ "Given two infer reports $(i,previous) and $(i,current), compute the following three \
reports and store them inside the \"differential/\" subdirectory of the results \ reports and store them inside the \"differential/\" subdirectory of the results \
directory:" directory:"
; `Noblank ; `Noblank
; `P ; `P "- $(b,introduced.json) contains the issues found in $(i,current) but not $(i,previous);"
"- $(b,introduced.json) contains the issues found in $(i,current) but not $(i,previous);"
; `Noblank ; `Noblank
; `P "- $(b,fixed.json) contains the issues found in $(i,previous) but not $(i,current);" ; `P "- $(b,fixed.json) contains the issues found in $(i,previous) but not $(i,current);"
; `Noblank ; `Noblank
@ -280,8 +278,8 @@ let events =
~synopsis:{|$(b,infer) $(b,events)|} ~synopsis:{|$(b,infer) $(b,events)|}
~description: ~description:
[ `P [ `P
"Emit to stdout one JSON object per line, each describing a logged event happened \ "Emit to stdout one JSON object per line, each describing a logged event happened during \
during the execution of Infer" ] the execution of Infer" ]
~see_also:InferCommand.[Report; Run] ~see_also:InferCommand.[Report; Run]

@ -99,8 +99,7 @@ type desc =
; default_string: string ; default_string: string
; spec: spec ; spec: spec
; decode_json: inferconfig_dir:string -> Yojson.Basic.t -> string list ; decode_json: inferconfig_dir:string -> Yojson.Basic.t -> string list
(** how to go from an option in the json config file to a list of command-line options *) (** how to go from an option in the json config file to a list of command-line options *) }
}
let dashdash ?short long = let dashdash ?short long =
match (long, short) with match (long, short) with
@ -163,7 +162,7 @@ module SectionMap = Caml.Map.Make (struct
type t = String.t type t = String.t
(* this must be the reverse of the order in which we want the sections to appear in the (* this must be the reverse of the order in which we want the sections to appear in the
manual *) manual *)
let compare s1 s2 = let compare s1 s2 =
if String.equal s1 s2 then (* this simplifies the next two cases *) if String.equal s1 s2 then (* this simplifies the next two cases *)
0 0
@ -190,9 +189,7 @@ let add parse_mode sections desc =
let desc_list = List.Assoc.find_exn ~equal:equal_parse_mode parse_mode_desc_lists parse_mode in let desc_list = List.Assoc.find_exn ~equal:equal_parse_mode parse_mode_desc_lists parse_mode in
desc_list := desc :: !desc_list ; desc_list := desc :: !desc_list ;
let add_to_section (command, section) = let add_to_section (command, section) =
let sections = let sections = List.Assoc.find_exn ~equal:InferCommand.equal help_sections_desc_lists command in
List.Assoc.find_exn ~equal:InferCommand.equal help_sections_desc_lists command
in
let prev_contents = try SectionMap.find section !sections with Caml.Not_found -> [] in let prev_contents = try SectionMap.find section !sections with Caml.Not_found -> [] in
sections := SectionMap.add section (desc :: prev_contents) !sections sections := SectionMap.add section (desc :: prev_contents) !sections
in in
@ -526,8 +523,8 @@ let map_to_str map =
String.concat list ~sep:"," String.concat list ~sep:","
let mk_string_map ?(default = String.Map.empty) ?(default_to_string = map_to_str) let mk_string_map ?(default = String.Map.empty) ?(default_to_string = map_to_str) ?(deprecated = [])
?(deprecated = []) ~long ?short ?parse_mode ?in_help ?(meta = "key=value") doc = ~long ?short ?parse_mode ?in_help ?(meta = "key=value") doc =
let flag = mk_flag ~deprecated ?short ~long in let flag = mk_flag ~deprecated ?short ~long in
let split_str str = let split_str str =
match String.lsplit2 str ~on:'=' with match String.lsplit2 str ~on:'=' with
@ -550,8 +547,8 @@ let mk_string_map ?(default = String.Map.empty) ?(default_to_string = map_to_str
var := add_to_map !var ~key ~data ) var := add_to_map !var ~key ~data )
~mk_spec:(fun set -> String set ) ~mk_spec:(fun set -> String set )
(* In spirit of JSON we could have presented json as list of key-value pairs (* In spirit of JSON we could have presented json as list of key-value pairs
with e.g. "key" and "value" fields, but for simplicity let's present each key-value pair with e.g. "key" and "value" fields, but for simplicity let's present each key-value pair
as it is passed to command line, which is a <key>=<value> *) as it is passed to command line, which is a <key>=<value> *)
~decode_json:(list_json_decoder (string_json_decoder ~flag)) ~decode_json:(list_json_decoder (string_json_decoder ~flag))
@ -568,8 +565,8 @@ let normalize_path_in_args_being_parsed ?(f = Fn.id) ~is_anon_arg str =
else str else str
let mk_path_helper ~setter ~default_to_string ~default ~deprecated ~long ~short ~parse_mode let mk_path_helper ~setter ~default_to_string ~default ~deprecated ~long ~short ~parse_mode ~in_help
~in_help ~meta ~decode_json doc = ~meta ~decode_json doc =
mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~decode_json mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~decode_json
~default_to_string ~default_to_string
~mk_setter:(fun var str -> ~mk_setter:(fun var str ->
@ -707,8 +704,8 @@ let normalize_desc_list speclist =
sort speclist sort speclist
let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~description let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~description ?options
?options ?exit_status ?environment ?files ?notes ?bugs ?examples ~see_also command_str = ?exit_status ?environment ?files ?notes ?bugs ?examples ~see_also command_str =
let add_if section blocks = let add_if section blocks =
match blocks with None -> `Blocks [] | Some bs -> `Blocks (`S section :: bs) match blocks with None -> `Blocks [] | Some bs -> `Blocks (`S section :: bs)
in in
@ -840,8 +837,7 @@ let anon_fun arg =
(* stop parsing the current args and go look in that argfile *) (* stop parsing the current args and go look in that argfile *)
raise (SubArguments (args_from_argfile arg)) raise (SubArguments (args_from_argfile arg))
else if else if
!anon_arg_action.parse_subcommands !anon_arg_action.parse_subcommands && List.Assoc.mem !subcommand_actions ~equal:String.equal arg
&& List.Assoc.mem !subcommand_actions ~equal:String.equal arg
then then
let command_switch = List.Assoc.find_exn !subcommand_actions ~equal:String.equal arg in let command_switch = List.Assoc.find_exn !subcommand_actions ~equal:String.equal arg in
match (!curr_command, is_originator) with match (!curr_command, is_originator) with
@ -906,8 +902,8 @@ let encode_argv_to_env argv =
~f:(fun arg -> ~f:(fun arg ->
(not (String.contains arg env_var_sep)) (not (String.contains arg env_var_sep))
|| ||
( warnf "WARNING: Ignoring unsupported option containing '%c' character: %s@\n" ( warnf "WARNING: Ignoring unsupported option containing '%c' character: %s@\n" env_var_sep
env_var_sep arg ; arg ;
false ) ) false ) )
argv) argv)

@ -124,8 +124,7 @@ val mk_symbol :
(** [mk_symbol long symbols] defines a command line flag [--long <symbol>] where [(<symbol>,_)] is (** [mk_symbol long symbols] defines a command line flag [--long <symbol>] where [(<symbol>,_)] is
an element of [symbols]. *) an element of [symbols]. *)
val mk_symbol_opt : val mk_symbol_opt : symbols:(string * 'a) list -> ?f:('a -> 'a) -> ?mk_reset:bool -> 'a option ref t
symbols:(string * 'a) list -> ?f:('a -> 'a) -> ?mk_reset:bool -> 'a option ref t
(** [mk_symbol_opt] is similar to [mk_symbol] but defaults to [None]. If [mk_reset] is false then do not create an additional --[long]-reset option to reset the value of the option to [None]. *) (** [mk_symbol_opt] is similar to [mk_symbol] but defaults to [None]. If [mk_reset] is false then do not create an additional --[long]-reset option to reset the value of the option to [None]. *)
val mk_symbol_seq : val mk_symbol_seq :

@ -83,7 +83,7 @@ type os_type = Unix | Win32 | Cygwin
type compilation_database_dependencies = type compilation_database_dependencies =
| Deps of int option | Deps of int option
(* get the compilation database of the dependencies up to depth n (* get the compilation database of the dependencies up to depth n
by [Deps (Some n)], or all by [Deps None] *) by [Deps (Some n)], or all by [Deps None] *)
| NoDeps | NoDeps
[@@deriving compare] [@@deriving compare]
@ -140,8 +140,7 @@ let build_system_of_exe_name name =
If this is an alias for another build system that infer supports, you can use@\n\ If this is an alias for another build system that infer supports, you can use@\n\
`--force-integration <command>` where <command> is one of the following supported build \ `--force-integration <command>` where <command> is one of the following supported build \
systems:@\n\ systems:@\n\
@[<v2> %a@]" @[<v2> %a@]" name
name
(Pp.seq ~print_env:Pp.text_break ~sep:"" F.pp_print_string) (Pp.seq ~print_env:Pp.text_break ~sep:"" F.pp_print_string)
( List.map ~f:fst build_system_exe_assoc ( List.map ~f:fst build_system_exe_assoc
|> List.map ~f:string_of_build_system |> List.map ~f:string_of_build_system
@ -663,9 +662,7 @@ and { annotation_reachability
; uninit } = ; uninit } =
let mk_checker ?(default = false) ?(deprecated = []) ~long doc = let mk_checker ?(default = false) ?(deprecated = []) ~long doc =
let var = let var =
CLOpt.mk_bool ~long CLOpt.mk_bool ~long ~in_help:InferCommand.[(Analyze, manual_generic)] ~default ~deprecated doc
~in_help:InferCommand.[(Analyze, manual_generic)]
~default ~deprecated doc
in in
all_checkers := (var, long, doc, default) :: !all_checkers ; all_checkers := (var, long, doc, default) :: !all_checkers ;
var var
@ -819,8 +816,8 @@ and annotation_reachability_cxx =
} }
|} |}
^ "\n\ ^ "\n\
This will cause us to create a new ISOLATED_REACHING_CONNECT issue for every function \ This will cause us to create a new ISOLATED_REACHING_CONNECT issue for every function whose \
whose source path starts with \"isolated/\" that may reach the function named \"connect\", \ source path starts with \"isolated/\" that may reach the function named \"connect\", \
ignoring paths that go through a symbol matching the OCaml regexp \".*::Trusted::.*\"." ) ignoring paths that go through a symbol matching the OCaml regexp \".*::Trusted::.*\"." )
@ -888,8 +885,8 @@ and buck_blacklist =
~long:"buck-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" ~meta:"regex"
"Skip capture of files matched by the specified regular expression (only the \"flavors \ "Skip capture of files matched by the specified regular expression (only the \"flavors (C++)\" \
(C++)\" Buck integration is supported, not Java)." Buck integration is supported, not Java)."
and buck_build_args = and buck_build_args =
@ -935,8 +932,7 @@ and buck_out =
and buck_targets_blacklist = and buck_targets_blacklist =
CLOpt.mk_string_list ~long:"buck-targets-blacklist" CLOpt.mk_string_list ~long:"buck-targets-blacklist"
~in_help: ~in_help:InferCommand.[(Run, manual_buck_compilation_db); (Capture, manual_buck_compilation_db)]
InferCommand.[(Run, manual_buck_compilation_db); (Capture, manual_buck_compilation_db)]
~meta:"regex" "Skip capture of buck targets matched by the specified regular expression." ~meta:"regex" "Skip capture of buck targets matched by the specified regular expression."
@ -968,8 +964,8 @@ and censor_report =
filter is of the form: `<issue_type_regex>:<filename_regex>:<reason_string>`. The first two \ filter is of the form: `<issue_type_regex>:<filename_regex>:<reason_string>`. The first two \
components are OCaml Str regular expressions, with an optional `!` character prefix. If a \ components are OCaml Str regular expressions, with an optional `!` character prefix. If a \
regex has a `!` prefix, the polarity is inverted, and the filter becomes a \"blacklist\" \ regex has a `!` prefix, the polarity is inverted, and the filter becomes a \"blacklist\" \
instead of a \"whitelist\". Each filter is interpreted as an implication: an issue matches \ instead of a \"whitelist\". Each filter is interpreted as an implication: an issue matches if \
if it does not match the `issue_type_regex` or if it does match the `filename_regex`. The \ it does not match the `issue_type_regex` or if it does match the `filename_regex`. The \
filenames that are tested by the regex are relative to the `--project-root` directory. The \ filenames that are tested by the regex are relative to the `--project-root` directory. The \
`<reason_string>` is a non-empty string used to explain why the issue was filtered." `<reason_string>` is a non-empty string used to explain why the issue was filtered."
@ -1029,8 +1025,8 @@ and clang_ignore_regex =
and clang_idirafter_to_override_regex = and clang_idirafter_to_override_regex =
CLOpt.mk_string_opt ~long:"clang-idirafter-to-override-regex" ~meta:"dir_OCaml_regex" CLOpt.mk_string_opt ~long:"clang-idirafter-to-override-regex" ~meta:"dir_OCaml_regex"
"Use this option in the uncommon case where the normal compilation process overrides the \ "Use this option in the uncommon case where the normal compilation process overrides the \
location of internal compiler headers. This option should specify regular expression with \ location of internal compiler headers. This option should specify regular expression with the \
the path to those headers so that infer can use its own clang internal headers instead. \ path to those headers so that infer can use its own clang internal headers instead. \
Concretely, this will replace $(b,-idirafter <path matching the regex>) with $(b,-idirafter \ Concretely, this will replace $(b,-idirafter <path matching the regex>) with $(b,-idirafter \
/path/to/infer/facebook-clang-plugins/clang/install/lib/clang/<version>/include)." /path/to/infer/facebook-clang-plugins/clang/install/lib/clang/<version>/include)."
@ -1040,8 +1036,8 @@ and clang_isystem_to_override_regex =
~deprecated:["-clang-include-to-override-regex"; "-clang-include-to-override"] ~deprecated:["-clang-include-to-override-regex"; "-clang-include-to-override"]
~meta:"dir_OCaml_regex" ~meta:"dir_OCaml_regex"
"Use this option in the uncommon case where the normal compilation process overrides the \ "Use this option in the uncommon case where the normal compilation process overrides the \
location of internal compiler headers. This option should specify regular expression with \ location of internal compiler headers. This option should specify regular expression with the \
the path to those headers so that infer can use its own clang internal headers instead. \ path to those headers so that infer can use its own clang internal headers instead. \
Concretely, this will replace $(b,-isystem <path matching the regex>) with $(b,-isystem \ Concretely, this will replace $(b,-isystem <path matching the regex>) with $(b,-isystem \
/path/to/infer/facebook-clang-plugins/clang/install/lib/clang/<version>/include)." /path/to/infer/facebook-clang-plugins/clang/install/lib/clang/<version>/include)."
@ -1069,8 +1065,8 @@ and compilation_database_escaped =
CLOpt.mk_path_list ~long:"compilation-database-escaped" CLOpt.mk_path_list ~long:"compilation-database-escaped"
~deprecated:["-clang-compilation-db-files-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 \ "File that contain compilation commands where all entries are escaped for the shell, eg coming \
coming from Xcode (can be specified multiple times)" from Xcode (can be specified multiple times)"
and compute_analytics = and compute_analytics =
@ -1195,8 +1191,7 @@ and ( biabduction_models_mode
and print_buckets = and print_buckets =
CLOpt.mk_bool ~long:"print-buckets" CLOpt.mk_bool ~long:"print-buckets"
"Show the internal bucket of Infer reports in their textual description" "Show the internal bucket of Infer reports in their textual description"
and print_types = and print_types = CLOpt.mk_bool ~long:"print-types" ~default:false "Print types in symbolic heaps"
CLOpt.mk_bool ~long:"print-types" ~default:false "Print types in symbolic heaps"
and keep_going = and keep_going =
CLOpt.mk_bool ~deprecated_no:["-no-failures-allowed"] ~long:"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)]
@ -1327,8 +1322,8 @@ and differential_filter_files =
and differential_filter_set = and differential_filter_set =
CLOpt.mk_symbol_seq ~long:"differential-filter-set" ~eq:PolyVariantEqual.( = ) CLOpt.mk_symbol_seq ~long:"differential-filter-set" ~eq:PolyVariantEqual.( = )
"Specify which set of the differential results is filtered with the modified files provided \ "Specify which set of the differential results is filtered with the modified files provided \
through the $(b,--differential-modified-files) argument. By default it is applied to all \ through the $(b,--differential-modified-files) argument. By default it is applied to all sets \
sets ($(b,introduced), $(b,fixed), and $(b,preexisting))" ($(b,introduced), $(b,fixed), and $(b,preexisting))"
~symbols:[("introduced", `Introduced); ("fixed", `Fixed); ("preexisting", `Preexisting)] ~symbols:[("introduced", `Introduced); ("fixed", `Fixed); ("preexisting", `Preexisting)]
~default:[`Introduced; `Fixed; `Preexisting] ~default:[`Introduced; `Fixed; `Preexisting]
@ -1400,16 +1395,14 @@ and eradicate_return_over_annotated =
CLOpt.mk_bool ~long:"eradicate-return-over-annotated" "Return over-annotated warning" CLOpt.mk_bool ~long:"eradicate-return-over-annotated" "Return over-annotated warning"
and eradicate_verbose = and eradicate_verbose = CLOpt.mk_bool ~long:"eradicate-verbose" "Print initial and final typestates"
CLOpt.mk_bool ~long:"eradicate-verbose" "Print initial and final typestates"
and external_java_packages = and external_java_packages =
CLOpt.mk_string_list ~long:"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" ~meta:"prefix"
"Specify a list of Java package prefixes for external Java packages. If set, the analysis \ "Specify a list of Java package prefixes for external Java packages. If set, the analysis will \
will not report non-actionable warnings on those packages." not report non-actionable warnings on those packages."
and fail_on_bug = and fail_on_bug =
@ -1464,8 +1457,8 @@ and from_json_report =
CLOpt.mk_path_opt ~long:"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" ~meta:"report.json"
"Load analysis results from a report file (default is to load the results from the specs \ "Load analysis results from a report file (default is to load the results from the specs files \
files generated by the analysis)." generated by the analysis)."
and frontend_stats = and frontend_stats =
@ -1540,8 +1533,8 @@ and hoisting_report_only_expensive =
and icfg_dotty_outfile = and icfg_dotty_outfile =
CLOpt.mk_path_opt ~long:"icfg-dotty-outfile" ~meta:"path" CLOpt.mk_path_opt ~long:"icfg-dotty-outfile" ~meta:"path"
"If set, specifies path where .dot file should be written, it overrides the path for all \ "If set, specifies path where .dot file should be written, it overrides the path for all other \
other options that would generate icfg file otherwise" options that would generate icfg file otherwise"
and iphoneos_target_sdk_version = and iphoneos_target_sdk_version =
@ -1623,9 +1616,9 @@ and liveness_dangerous_classes =
CLOpt.mk_json ~long:"liveness-dangerous-classes" CLOpt.mk_json ~long:"liveness-dangerous-classes"
~in_help:InferCommand.[(Analyze, manual_clang)] ~in_help:InferCommand.[(Analyze, manual_clang)]
"Specify classes where the destructor should be ignored when computing liveness. In other \ "Specify classes where the destructor should be ignored when computing liveness. In other \
words, assignement to variables of these types (or common wrappers around these types such \ words, assignement to variables of these types (or common wrappers around these types such as \
as $(i,unique_ptr<type>)) will count as dead stores when the variables are not read \ $(i,unique_ptr<type>)) will count as dead stores when the variables are not read explicitly \
explicitly by the program." by the program."
and log_events = and log_events =
@ -1695,8 +1688,7 @@ and linters_ignore_clang_failures =
and linters_validate_syntax_only = and linters_validate_syntax_only =
CLOpt.mk_bool ~long:"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 ~default:false "Validate syntax of AL files, then emit possible errors in JSON format to stdout"
"Validate syntax of AL files, then emit possible errors in JSON format to stdout"
and load_average = and load_average =
@ -1760,8 +1752,8 @@ and nullable_annotation =
and nullsafe_third_party_signatures = and nullsafe_third_party_signatures =
CLOpt.mk_string_opt ~long:"nullsafe-third-party-signatures" CLOpt.mk_string_opt ~long:"nullsafe-third-party-signatures"
"Path to a folder with annotated signatures of third-party methods to be taken into account \ "Path to a folder with annotated signatures of third-party methods to be taken into account by \
by nullsafe. Path is either relative to .inferconfig folder or absolute" nullsafe. Path is either relative to .inferconfig folder or absolute"
and nullsafe_strict_containers = and nullsafe_strict_containers =
@ -1869,8 +1861,8 @@ and procedures_attributes =
and procedures_definedness = and procedures_definedness =
CLOpt.mk_bool ~long:"procedures-definedness" ~default:true CLOpt.mk_bool ~long:"procedures-definedness" ~default:true
~in_help:InferCommand.[(Explore, manual_explore_procedures)] ~in_help:InferCommand.[(Explore, manual_explore_procedures)]
"Include procedures definedness in the output of $(b,--procedures), i.e. whether the \ "Include procedures definedness in the output of $(b,--procedures), i.e. whether the procedure \
procedure definition was found, or only the procedure declaration, or the procedure is an \ definition was found, or only the procedure declaration, or the procedure is an \
auto-generated Objective-C accessor" auto-generated Objective-C accessor"
@ -1878,8 +1870,8 @@ and procedures_filter =
CLOpt.mk_string_opt ~long:"procedures-filter" ~meta:"filter" CLOpt.mk_string_opt ~long:"procedures-filter" ~meta:"filter"
~in_help:InferCommand.[(Explore, manual_explore_procedures)] ~in_help:InferCommand.[(Explore, manual_explore_procedures)]
"With $(b,--procedures), only print functions and methods (procedures) matching the specified \ "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 \ $(i,filter). A procedure filter is of the form $(i,path_pattern:procedure_name). Patterns are \
are interpreted as OCaml Str regular expressions. For instance, to keep only methods named \ interpreted as OCaml Str regular expressions. For instance, to keep only methods named \
\"foo\", one can use the filter \".*:foo\", or \"foo\" for short." \"foo\", one can use the filter \".*:foo\", or \"foo\" for short."
@ -2097,8 +2089,7 @@ and rest =
~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 "Stop argument processing, use remaining arguments as a build command" ~usage:exe_usage
(fun build_exe -> (fun build_exe ->
match Filename.basename build_exe with "java" | "javac" -> CLOpt.Javac | _ -> CLOpt.NoParse match Filename.basename build_exe with "java" | "javac" -> CLOpt.Javac | _ -> CLOpt.NoParse )
)
and results_dir = and results_dir =
@ -2136,8 +2127,8 @@ and scuba_normals =
and siof_safe_methods = and siof_safe_methods =
CLOpt.mk_string_list ~long:"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<int>::bar()\", \ "Methods that are SIOF-safe; \"foo::bar\" will match \"foo::bar()\", \"foo<int>::bar()\", etc. \
etc. (can be specified multiple times)" (can be specified multiple times)"
and skip_analysis_in_path = and skip_analysis_in_path =
@ -2263,8 +2254,8 @@ and sqlite_cache_size =
CLOpt.mk_int ~long:"sqlite-cache-size" ~default:2000 CLOpt.mk_int ~long:"sqlite-cache-size" ~default:2000
~in_help: ~in_help:
InferCommand.[(Analyze, manual_generic); (Capture, manual_generic); (Run, manual_generic)] InferCommand.[(Analyze, manual_generic); (Capture, manual_generic); (Run, manual_generic)]
"SQLite cache size in pages (if positive) or kB (if negative), follows formal of \ "SQLite cache size in pages (if positive) or kB (if negative), follows formal of corresponding \
corresponding SQLite PRAGMA." SQLite PRAGMA."
and sqlite_page_size = and sqlite_page_size =
@ -2421,8 +2412,7 @@ and type_size =
and uninit_interproc = and uninit_interproc =
CLOpt.mk_bool ~long:"uninit-interproc" CLOpt.mk_bool ~long:"uninit-interproc" "Run uninit check in the experimental interprocedural mode"
"Run uninit check in the experimental interprocedural mode"
and unsafe_malloc = and unsafe_malloc =
@ -2489,7 +2479,7 @@ let javac_classes_out =
~short: ~short:
'd' 'd'
(* Ensure that some form of "-d ..." is passed to javac. It's unclear whether this is strictly (* Ensure that some form of "-d ..." is passed to javac. It's unclear whether this is strictly
needed but the tests break without this for now. See discussion in D4397716. *) needed but the tests break without this for now. See discussion in D4397716. *)
~default:CLOpt.init_work_dir ~default:CLOpt.init_work_dir
~default_to_string:(fun _ -> ".") ~default_to_string:(fun _ -> ".")
~f:(fun classes_out -> ~f:(fun classes_out ->

@ -12,21 +12,21 @@ module F = Format
module Implementation = struct module Implementation = struct
let attribute_replace_statement = let attribute_replace_statement =
(* The innermost SELECT returns either the current attributes_kind and source_file associated with (* The innermost SELECT returns either the current attributes_kind and source_file associated with
the given proc name, or default values of (-1,""). These default values have the property that the given proc name, or default values of (-1,""). These default values have the property that
they are always "less than" any legit value. More precisely, MAX ensures that some value is they are always "less than" any legit value. More precisely, MAX ensures that some value is
returned even if there is no row satisfying WHERE (we'll get NULL in that case, the value in returned even if there is no row satisfying WHERE (we'll get NULL in that case, the value in
the row otherwise). COALESCE then returns the first non-NULL value, which will be either the the row otherwise). COALESCE then returns the first non-NULL value, which will be either the
value of the row corresponding to that pname in the DB, or the default if no such row exists. value of the row corresponding to that pname in the DB, or the default if no such row exists.
The next (second-outermost) SELECT filters out that value if it is "more defined" than the ones The next (second-outermost) SELECT filters out that value if it is "more defined" than the ones
we would like to insert (which will never be the case if the default values are returned). If we would like to insert (which will never be the case if the default values are returned). If
not, it returns a trivial row (consisting solely of NULL since we don't use its values) and the not, it returns a trivial row (consisting solely of NULL since we don't use its values) and the
INSERT OR REPLACE will proceed and insert or update the values stored into the DB for that INSERT OR REPLACE will proceed and insert or update the values stored into the DB for that
pname. *) pname. *)
(* TRICK: use the source file to be more deterministic in case the same procedure name is defined (* TRICK: use the source file to be more deterministic in case the same procedure name is defined
in several files *) in several files *)
(* TRICK: older versions of sqlite (prior to version 3.15.0 (2016-10-14)) do not support row (* TRICK: older versions of sqlite (prior to version 3.15.0 (2016-10-14)) do not support row
values so the lexicographic ordering for (:akind, :sfile) is done by hand *) values so the lexicographic ordering for (:akind, :sfile) is done by hand *)
ResultsDatabase.register_statement ResultsDatabase.register_statement
{| {|
INSERT OR REPLACE INTO procedures INSERT OR REPLACE INTO procedures
@ -44,8 +44,7 @@ module Implementation = struct
let replace_attributes ~pname_str ~pname ~akind ~source_file ~attributes ~proc_desc ~callees = let replace_attributes ~pname_str ~pname ~akind ~source_file ~attributes ~proc_desc ~callees =
ResultsDatabase.with_registered_statement attribute_replace_statement ResultsDatabase.with_registered_statement attribute_replace_statement ~f:(fun db replace_stmt ->
~f:(fun db replace_stmt ->
Sqlite3.bind replace_stmt 1 (* :pname *) pname Sqlite3.bind replace_stmt 1 (* :pname *) pname
|> SqliteUtils.check_result_code db ~log:"replace bind pname" ; |> SqliteUtils.check_result_code db ~log:"replace bind pname" ;
Sqlite3.bind replace_stmt 2 (* :proc_name_hum *) (Sqlite3.Data.TEXT pname_str) Sqlite3.bind replace_stmt 2 (* :proc_name_hum *) (Sqlite3.Data.TEXT pname_str)
@ -103,9 +102,9 @@ module Implementation = struct
let merge_procedures_table ~db_file = let merge_procedures_table ~db_file =
let db = ResultsDatabase.get_database () in let db = ResultsDatabase.get_database () in
(* Do the merge purely in SQL for great speed. The query works by doing a left join between the (* Do the merge purely in SQL for great speed. The query works by doing a left join between the
sub-table and the main one, and applying the same "more defined" logic as in Attributes in the sub-table and the main one, and applying the same "more defined" logic as in Attributes in the
cases where a proc_name is present in both the sub-table and the main one (main.attr_kind != cases where a proc_name is present in both the sub-table and the main one (main.attr_kind !=
NULL). All the rows that pass this filter are inserted/updated into the main table. *) NULL). All the rows that pass this filter are inserted/updated into the main table. *)
Sqlite3.exec db Sqlite3.exec db
{| {|
INSERT OR REPLACE INTO memdb.procedures INSERT OR REPLACE INTO memdb.procedures
@ -146,13 +145,11 @@ module Implementation = struct
let db_file = infer_out_src ^/ ResultsDatabase.database_filename in let db_file = infer_out_src ^/ ResultsDatabase.database_filename in
let main_db = ResultsDatabase.get_database () in let main_db = ResultsDatabase.get_database () in
Sqlite3.exec main_db (Printf.sprintf "ATTACH '%s' AS attached" db_file) Sqlite3.exec main_db (Printf.sprintf "ATTACH '%s' AS attached" db_file)
|> SqliteUtils.check_result_code main_db |> SqliteUtils.check_result_code main_db ~log:(Printf.sprintf "attaching database '%s'" db_file) ;
~log:(Printf.sprintf "attaching database '%s'" db_file) ;
merge_procedures_table ~db_file ; merge_procedures_table ~db_file ;
merge_source_files_table ~db_file ; merge_source_files_table ~db_file ;
Sqlite3.exec main_db "DETACH attached" Sqlite3.exec main_db "DETACH attached"
|> SqliteUtils.check_result_code main_db |> SqliteUtils.check_result_code main_db ~log:(Printf.sprintf "detaching database '%s'" db_file)
~log:(Printf.sprintf "detaching database '%s'" db_file)
let merge infer_deps_file = let merge infer_deps_file =
@ -244,7 +241,7 @@ end
type response = Ack type response = Ack
module Server = struct module Server = struct
(* General comment about socket/channel destruction: closing the in_channel associated with the socket (* General comment about socket/channel destruction: closing the in_channel associated with the socket
will close the file descriptor too, so closing also the out_channel sometimes throws an exception. will close the file descriptor too, so closing also the out_channel sometimes throws an exception.
That's why in all code below only the input channel is ever closed. *) That's why in all code below only the input channel is ever closed. *)

@ -16,8 +16,8 @@ exception InferInternalError of string
exception InferUserError of string exception InferUserError of string
(** This can be used to avoid scattering exit invocations all over the codebase *)
exception InferExit of int exception InferExit of int
(** This can be used to avoid scattering exit invocations all over the codebase *)
(** kind of error for [die], with similar semantics as [Logging.{external,internal,user}_error] *) (** kind of error for [die], with similar semantics as [Logging.{external,internal,user}_error] *)
type error = ExternalError | InternalError | UserError type error = ExternalError | InternalError | UserError

@ -76,7 +76,7 @@ end = struct
try try
let old = IssueSet.find issue !all_issues in let old = IssueSet.find issue !all_issues in
(* update human-readable string in case it was supplied this time, but keep the previous (* update human-readable string in case it was supplied this time, but keep the previous
value of enabled (see doc comment) *) value of enabled (see doc comment) *)
if Option.is_some hum0 then old.hum <- hum ; if Option.is_some hum0 then old.hum <- hum ;
if Option.is_some doc_url then old.doc_url <- doc_url ; if Option.is_some doc_url then old.doc_url <- doc_url ;
if Option.is_some linters_def_file then old.linters_def_file <- linters_def_file ; if Option.is_some linters_def_file then old.linters_def_file <- linters_def_file ;
@ -145,8 +145,7 @@ let checkers_allocates_memory =
let checkers_annotation_reachability_error = let checkers_annotation_reachability_error =
register_from_string "CHECKERS_ANNOTATION_REACHABILITY_ERROR" register_from_string "CHECKERS_ANNOTATION_REACHABILITY_ERROR" ~hum:"Annotation Reachability Error"
~hum:"Annotation Reachability Error"
let checkers_calls_expensive_method = let checkers_calls_expensive_method =

@ -17,9 +17,7 @@ let add_float ({floats} as t) ~key ~data = {t with floats= String.Map.set floats
let add_string ({strings} as t) ~key ~data = {t with strings= String.Map.set strings ~key ~data} let add_string ({strings} as t) ~key ~data = {t with strings= String.Map.set strings ~key ~data}
let add_string_opt t ~key ~data = let add_string_opt t ~key ~data = match data with Some data -> add_string t ~key ~data | None -> t
match data with Some data -> add_string t ~key ~data | None -> t
let yojson_of_integers integers = let yojson_of_integers integers =
let f ~key ~data acc = (key, `Int data) :: acc in let f ~key ~data acc = (key, `Int data) :: acc in

@ -134,7 +134,7 @@ let register_formatter =
let formatters = mk_formatters () in let formatters = mk_formatters () in
let formatters_ref = ref formatters in let formatters_ref = ref formatters in
logging_formatters := ((formatters_ref, mk_formatters), formatters) :: !logging_formatters ; logging_formatters := ((formatters_ref, mk_formatters), formatters) :: !logging_formatters ;
formatters_ref) formatters_ref )
let flush_formatters {file; console_file} = let flush_formatters {file; console_file} =
@ -209,9 +209,7 @@ let phase fmt = log ~to_console:false phase_file_fmts fmt
let progress fmt = log ~to_console:(not Config.quiet) progress_file_fmts fmt let progress fmt = log ~to_console:(not Config.quiet) progress_file_fmts fmt
let log_task fmt = let log_task fmt =
let to_console = let to_console = match Config.progress_bar with `Plain -> true | `Quiet | `MultiLine -> false in
match Config.progress_bar with `Plain -> true | `Quiet | `MultiLine -> false
in
log ~to_console progress_file_fmts fmt log ~to_console progress_file_fmts fmt
@ -277,9 +275,7 @@ let internal_error fmt = log ~to_console:true internal_error_file_fmts fmt
type ocaml_pos = string * int * int * int type ocaml_pos = string * int * int * int
(** Convert a ml location to a string *) (** Convert a ml location to a string *)
let ocaml_pos_to_string (file, lnum, cnum, enum) = let ocaml_pos_to_string (file, lnum, cnum, enum) = Printf.sprintf "%s:%d:%d-%d:" file lnum cnum enum
Printf.sprintf "%s:%d:%d-%d:" file lnum cnum enum
(** Pretty print a location of ml source *) (** Pretty print a location of ml source *)
let pp_ocaml_pos fmt ocaml_pos = F.pp_print_string fmt (ocaml_pos_to_string ocaml_pos) let pp_ocaml_pos fmt ocaml_pos = F.pp_print_string fmt (ocaml_pos_to_string ocaml_pos)

@ -61,8 +61,8 @@ val debug : debug_kind -> debug_level -> ('a, F.formatter, unit) format -> 'a
val debug_dev : ('a, Format.formatter, unit) format -> 'a val debug_dev : ('a, Format.formatter, unit) format -> 'a
[@@deprecated [@@deprecated
"Only use to debug during development. If you want more permanent logging, use \ "Only use to debug during development. If you want more permanent logging, use [Logging.debug] \
[Logging.debug] instead."] instead."]
[@@warning "-32"] [@@warning "-32"]
(** For debugging during development. *) (** For debugging during development. *)

@ -245,7 +245,7 @@ let logger =
else else
(* assume the trace file is here and is ready to accept list elements *) (* assume the trace file is here and is ready to accept list elements *)
JsonFragment.(pp_state := InList :: !pp_state) ) ; JsonFragment.(pp_state := InList :: !pp_state) ) ;
logger) logger )
(* export logging functions that output a list element at a time and flushes so that multiple (* export logging functions that output a list element at a time and flushes so that multiple

@ -138,8 +138,8 @@ let wait_for_updates pool buffer =
let rec aux acc ~timeout = let rec aux acc ~timeout =
let file_descr = pool.children_updates in let file_descr = pool.children_updates in
(* Use select(2) so that we can both wait on the pipe of children updates and wait for a (* Use select(2) so that we can both wait on the pipe of children updates and wait for a
timeout. The timeout is for giving a chance to the taskbar of refreshing from time to time, timeout. The timeout is for giving a chance to the taskbar of refreshing from time to time,
as well as for checking for new work where none were previously available. *) as well as for checking for new work where none were previously available. *)
let {Unix.Select_fds.read= read_fds} = let {Unix.Select_fds.read= read_fds} =
Unix.select ~read:[file_descr] ~write:[] ~except:[] ~timeout () Unix.select ~read:[file_descr] ~write:[] ~except:[] ~timeout ()
in in
@ -150,18 +150,18 @@ let wait_for_updates pool buffer =
(* no updates, break loop *) acc (* no updates, break loop *) acc
| [_file_descr] -> | [_file_descr] ->
(* Read one OCaml value at a time. This is done by first reading the header of the marshalled (* Read one OCaml value at a time. This is done by first reading the header of the marshalled
value (fixed size), then get the total size of the data from that header, then request a value (fixed size), then get the total size of the data from that header, then request a
read of the full OCaml value. read of the full OCaml value.
This way the buffer is used for only one OCaml value at a time. This is simpler (values do This way the buffer is used for only one OCaml value at a time. This is simpler (values do
not overlap across the end of a read and the beginning of another) and means we do not need not overlap across the end of a read and the beginning of another) and means we do not need
a large buffer as long as messages are never bigger than the buffer. a large buffer as long as messages are never bigger than the buffer.
This works somewhat like [Marshal.from_channel] but uses the file descriptor directly This works somewhat like [Marshal.from_channel] but uses the file descriptor directly
instead of an [in_channel]. Do *not* read from the pipe via an [in_channel] as they read instead of an [in_channel]. Do *not* read from the pipe via an [in_channel] as they read
as much as possible eagerly. This can empty the pipe without us having a way to tell that as much as possible eagerly. This can empty the pipe without us having a way to tell that
there is more to read anymore since the [select] call will return that there is nothing to there is more to read anymore since the [select] call will return that there is nothing to
read. *) read. *)
really_read pool.children_updates ~buf:buffer ~len:Marshal.header_size ; really_read pool.children_updates ~buf:buffer ~len:Marshal.header_size ;
let data_size = Marshal.data_size buffer 0 in let data_size = Marshal.data_size buffer 0 in
really_read pool.children_updates ~buf:buffer ~pos:Marshal.header_size ~len:data_size ; really_read pool.children_updates ~buf:buffer ~pos:Marshal.header_size ~len:data_size ;
@ -251,7 +251,7 @@ let process_updates pool buffer =
TaskBar.update_status pool.task_bar ~slot t status TaskBar.update_status pool.task_bar ~slot t status
| Crash slot -> | Crash slot ->
(* NOTE: the workers only send this message if {!Config.keep_going} is not [true] so if (* NOTE: the workers only send this message if {!Config.keep_going} is not [true] so if
we receive it we know we should fail hard *) we receive it we know we should fail hard *)
let {pid} = pool.slots.(slot) in let {pid} = pool.slots.(slot) in
(* clean crash, give the child process a chance to cleanup *) (* clean crash, give the child process a chance to cleanup *)
Unix.wait (`Pid pid) |> ignore ; Unix.wait (`Pid pid) |> ignore ;
@ -270,8 +270,7 @@ let process_updates pool buffer =
(* try to schedule more work if there are idle workers *) (* try to schedule more work if there are idle workers *)
if not (pool.tasks.is_empty ()) then if not (pool.tasks.is_empty ()) then
Array.iteri pool.children_states ~f:(fun slot state -> Array.iteri pool.children_states ~f:(fun slot state ->
match state with Idle -> send_work_to_child pool slot | Initializing | Processing _ -> () match state with Idle -> send_work_to_child pool slot | Initializing | Processing _ -> () )
)
type 'a final_worker_message = Finished of int * 'a option | FinalCrash of int type 'a final_worker_message = Finished of int * 'a option | FinalCrash of int
@ -420,8 +419,8 @@ let create :
let file_lock = Utils.create_file_lock () in let file_lock = Utils.create_file_lock () in
let task_bar = TaskBar.create ~jobs in let task_bar = TaskBar.create ~jobs in
(* Pipe to communicate from children to parent. Only one pipe is needed: the messages sent by (* Pipe to communicate from children to parent. Only one pipe is needed: the messages sent by
children include the identifier of the child sending the message (its [slot]). This way there children include the identifier of the child sending the message (its [slot]). This way there
is only one pipe to wait on for updates. *) is only one pipe to wait on for updates. *)
let ((pipe_child_r, pipe_child_w) as status_pipe) = Unix.pipe () in let ((pipe_child_r, pipe_child_w) as status_pipe) = Unix.pipe () in
let slots = let slots =
Array.init jobs ~f:(fun slot -> Array.init jobs ~f:(fun slot ->

@ -58,8 +58,7 @@ let remove_results_dir () =
Result.iter_error (is_results_dir ~check_correct_version:false ()) ~f:(fun err -> Result.iter_error (is_results_dir ~check_correct_version:false ()) ~f:(fun err ->
L.(die UserError) L.(die UserError)
"ERROR: '%s' exists but does not seem to be an infer results directory: %s@\n\ "ERROR: '%s' exists but does not seem to be an infer results directory: %s@\n\
ERROR: Please delete '%s' and try again@." ERROR: Please delete '%s' and try again@." Config.results_dir err Config.results_dir ) ;
Config.results_dir err Config.results_dir ) ;
Utils.rmtree Config.results_dir ) ; Utils.rmtree Config.results_dir ) ;
RunState.reset () RunState.reset ()
@ -81,8 +80,8 @@ let create_results_dir () =
L.progress "Deleting results dir because --force-delete-results-dir was passed@." ; L.progress "Deleting results dir because --force-delete-results-dir was passed@." ;
remove_results_dir () ) remove_results_dir () )
else else
L.die UserError "ERROR: %s@\nPlease remove '%s' and try again" error L.die UserError "ERROR: %s@\nPlease remove '%s' and try again" error Config.results_dir
Config.results_dir ) ; ) ;
Unix.mkdir_p Config.results_dir ; Unix.mkdir_p Config.results_dir ;
Unix.mkdir_p (Config.results_dir ^/ Config.events_dir_name) ; Unix.mkdir_p (Config.results_dir ^/ Config.events_dir_name) ;
List.iter ~f:Unix.mkdir_p results_dir_dir_markers ; List.iter ~f:Unix.mkdir_p results_dir_dir_markers ;

@ -47,8 +47,7 @@ let load_and_validate () =
"'%s' already exists but it is not an empty directory and it does not look like an \ "'%s' already exists but it is not an empty directory and it does not look like an \
infer results directory:\n\ infer results directory:\n\
\ %s\n\ \ %s\n\
Was it created using an older version of infer?" Was it created using an older version of infer?" Config.results_dir err_msg) )
Config.results_dir err_msg) )
msg msg
in in
if Sys.file_exists state_file_path <> `Yes then if Sys.file_exists state_file_path <> `Yes then

@ -100,9 +100,7 @@ let line_count source_file =
count_newlines abs_path count_newlines abs_path
let to_rel_path fname = let to_rel_path fname = match fname with RelativeProjectRoot path -> path | _ -> to_abs_path fname
match fname with RelativeProjectRoot path -> path | _ -> to_abs_path fname
let invalid ml_source_file = Invalid {ml_source_file} let invalid ml_source_file = Invalid {ml_source_file}

@ -9,11 +9,11 @@ open! IStd
type t [@@deriving compare] type t [@@deriving compare]
(** Maps from source_file *)
module Map : Caml.Map.S with type key = t module Map : Caml.Map.S with type key = t
(** Maps from source_file *)
(** Set of source files *)
module Set : Caml.Set.S with type elt = t module Set : Caml.Set.S with type elt = t
(** Set of source files *)
module Hash : Caml.Hashtbl.S with type key = t module Hash : Caml.Hashtbl.S with type key = t

@ -25,8 +25,7 @@ let exec db ~log ~stmt =
PerfEvent.log_begin_event logger ~name:"sql exec" ~arguments:[("stmt", `String log)] () ) ; PerfEvent.log_begin_event logger ~name:"sql exec" ~arguments:[("stmt", `String log)] () ) ;
let rc = Sqlite3.exec db stmt in let rc = Sqlite3.exec db stmt in
PerfEvent.(log (fun logger -> log_end_event logger ())) ; PerfEvent.(log (fun logger -> log_end_event logger ())) ;
try check_result_code db ~log rc try check_result_code db ~log rc with Error err -> error "exec: %s (%s)" err (Sqlite3.errmsg db)
with Error err -> error "exec: %s (%s)" err (Sqlite3.errmsg db)
let finalize db ~log stmt = let finalize db ~log stmt =
@ -48,8 +47,7 @@ let result_fold_rows ?finalize:(do_finalize = true) db ~log stmt ~init ~f =
| err -> | err ->
L.die InternalError "%s: %s (%s)" log (Sqlite3.Rc.to_string err) (Sqlite3.errmsg db) L.die InternalError "%s: %s (%s)" log (Sqlite3.Rc.to_string err) (Sqlite3.errmsg db)
in in
if do_finalize then if do_finalize then protect ~finally:(fun () -> finalize db ~log stmt) ~f:(fun () -> aux init stmt)
protect ~finally:(fun () -> finalize db ~log stmt) ~f:(fun () -> aux init stmt)
else aux init stmt else aux init stmt
@ -64,8 +62,7 @@ let zero_or_one_row ~log = function
| [x] -> | [x] ->
Some x Some x
| _ :: _ :: _ as l -> | _ :: _ :: _ as l ->
L.die InternalError "%s: zero or one result expected, got %d rows instead" log L.die InternalError "%s: zero or one result expected, got %d rows instead" log (List.length l)
(List.length l)
let result_option ?finalize db ~log ~read_row stmt = let result_option ?finalize db ~log ~read_row stmt =
@ -79,8 +76,7 @@ let result_single_column_option ?finalize db ~log stmt =
let result_unit ?finalize db ~log stmt = let result_unit ?finalize db ~log stmt =
if if not (Container.is_empty stmt ~iter:(Container.iter ~fold:(result_fold_rows ?finalize db ~log)))
not (Container.is_empty stmt ~iter:(Container.iter ~fold:(result_fold_rows ?finalize db ~log)))
then L.die InternalError "%s: the SQLite query should not return any rows" log then L.die InternalError "%s: the SQLite query should not return any rows" log

@ -7,9 +7,9 @@
open! IStd open! IStd
exception Error of string
(** The functions in this module tend to raise more often than their counterparts in [Sqlite3]. In (** The functions in this module tend to raise more often than their counterparts in [Sqlite3]. In
particular, they may raise if the [Sqlite3.Rc.t] result of certain operations is unexpected. *) particular, they may raise if the [Sqlite3.Rc.t] result of certain operations is unexpected. *)
exception Error of string
val check_result_code : Sqlite3.db -> log:string -> Sqlite3.Rc.t -> unit val check_result_code : Sqlite3.db -> log:string -> Sqlite3.Rc.t -> unit
(** Assert that the result is either [Sqlite3.Rc.OK] or [Sqlite3.Rc.ROW]. If the result is not (** Assert that the result is either [Sqlite3.Rc.OK] or [Sqlite3.Rc.ROW]. If the result is not

@ -17,8 +17,8 @@ type failure_kind =
| FKrecursion_timeout of int (** max recursion level exceeded *) | FKrecursion_timeout of int (** max recursion level exceeded *)
| FKcrash of string (** uncaught exception or failed assertion *) | FKcrash of string (** uncaught exception or failed assertion *)
(** failure that prevented analysis from finishing *)
exception Analysis_failure_exe of failure_kind exception Analysis_failure_exe of failure_kind
(** failure that prevented analysis from finishing *)
let exn_not_failure = function Analysis_failure_exe _ -> false | _ -> true let exn_not_failure = function Analysis_failure_exe _ -> false | _ -> true

@ -59,8 +59,8 @@ type failure_kind =
| FKrecursion_timeout of int (** max recursion level exceeded *) | FKrecursion_timeout of int (** max recursion level exceeded *)
| FKcrash of string (** uncaught exception or failed assertion *) | FKcrash of string (** uncaught exception or failed assertion *)
(** Timeout exception *)
exception Analysis_failure_exe of failure_kind exception Analysis_failure_exe of failure_kind
(** Timeout exception *)
val exn_not_failure : exn -> bool val exn_not_failure : exn -> bool
(** check that the exception is not a timeout exception *) (** check that the exception is not a timeout exception *)

@ -70,8 +70,7 @@ let draw_top_bar fmt ~term_width ~total ~finished ~elapsed =
++ ( "%s" ++ ( "%s"
, max (String.length elapsed_string) 9 , max (String.length elapsed_string) 9
(* leave some room for elapsed_string to avoid flicker. 9 characters is "XXhXXmXXs" so it (* leave some room for elapsed_string to avoid flicker. 9 characters is "XXhXXmXXs" so it
gives some reasonable margin. *) gives some reasonable margin. *) )
)
in in
let top_bar_size = min term_width top_bar_size_default in let top_bar_size = min term_width top_bar_size_default in
let progress_bar_size = top_bar_size - size_around_progress_bar in let progress_bar_size = top_bar_size - size_around_progress_bar in

@ -212,9 +212,7 @@ let with_file_lock ~file_lock:{file; oc; fd} ~f =
let with_intermediate_temp_file_out file ~f = let with_intermediate_temp_file_out file ~f =
let temp_filename, temp_oc = let temp_filename, temp_oc = Filename.open_temp_file ~in_dir:(Filename.dirname file) "infer" "" in
Filename.open_temp_file ~in_dir:(Filename.dirname file) "infer" ""
in
let f () = f temp_oc in let f () = f temp_oc in
let finally () = let finally () =
Out_channel.close temp_oc ; Out_channel.close temp_oc ;

@ -41,8 +41,8 @@ let zip_libraries =
None None
in in
(* Order matters: jar files should appear in the order in which they should be searched for (* Order matters: jar files should appear in the order in which they should be searched for
specs files. [Config.specs_library] is in reverse order of appearance on the command specs files. [Config.specs_library] is in reverse order of appearance on the command
line. *) line. *)
List.rev_filter_map Config.specs_library ~f:load_zip List.rev_filter_map Config.specs_library ~f:load_zip
in in
if if
@ -50,7 +50,7 @@ let zip_libraries =
&& (not Config.biabduction_models_mode) && (not Config.biabduction_models_mode)
&& Sys.file_exists Config.biabduction_models_jar = `Yes && Sys.file_exists Config.biabduction_models_jar = `Yes
then mk_zip_lib Config.biabduction_models_jar :: zip_libs then mk_zip_lib Config.biabduction_models_jar :: zip_libs
else zip_libs) else zip_libs )
(** Search path in the list of zip libraries and use a cache directory to save already deserialized (** Search path in the list of zip libraries and use a cache directory to save already deserialized

@ -90,8 +90,8 @@ let create_condition_ls ids_private id_base p_leftover (inst : Sil.subst) =
(* [fav_insts_of_private_ids] does not intersect the free vars in [p_leftover.sigma] *) (* [fav_insts_of_private_ids] does not intersect the free vars in [p_leftover.sigma] *)
Prop.sigma_free_vars p_leftover.Prop.sigma |> Fn.non intersects_fav_insts_of_private_ids Prop.sigma_free_vars p_leftover.Prop.sigma |> Fn.non intersects_fav_insts_of_private_ids
&& (* [fav_insts_of_private_ids] does not intersect the free vars in [insts_of_public_ids] *) && (* [fav_insts_of_private_ids] does not intersect the free vars in [insts_of_public_ids] *)
List.for_all insts_of_public_ids ~f:(fun e -> List.for_all insts_of_public_ids ~f:(fun e ->
Exp.free_vars e |> Fn.non intersects_fav_insts_of_private_ids ) Exp.free_vars e |> Fn.non intersects_fav_insts_of_private_ids )
let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Sil.hpara) = let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para : Sil.hpara) =
@ -912,7 +912,7 @@ let abstract_gc tenv p =
let check fav_seq = let check fav_seq =
Sequence.is_empty fav_seq Sequence.is_empty fav_seq
|| (* non-empty intersection with [fav_p_without_pi] *) || (* non-empty intersection with [fav_p_without_pi] *)
Sequence.exists fav_seq ~f:(fun id -> Ident.Set.mem id fav_p_without_pi) Sequence.exists fav_seq ~f:(fun id -> Ident.Set.mem id fav_p_without_pi)
in in
let strong_filter = function let strong_filter = function
| Sil.Aeq (e1, e2) | Sil.Aneq (e1, e2) -> | Sil.Aeq (e1, e2) | Sil.Aneq (e1, e2) ->
@ -1112,7 +1112,7 @@ let check_junk pname tenv prop =
in in
(is_none alloc_attribute && !leaks_reported <> []) (is_none alloc_attribute && !leaks_reported <> [])
|| (* None attribute only reported if it's the first one *) || (* None attribute only reported if it's the first one *)
List.mem ~equal:attr_opt_equal !leaks_reported alloc_attribute List.mem ~equal:attr_opt_equal !leaks_reported alloc_attribute
in in
let ignore_leak = let ignore_leak =
!BiabductionConfig.allow_leak || ignore_resource || is_undefined !BiabductionConfig.allow_leak || ignore_resource || is_undefined

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

Loading…
Cancel
Save