pghs975uc
/
infer_clone
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Deprecate more IList functions and use Core List instead

Browse Source 
Reviewed By: jberdine

Differential Revision: D4501499

fbshipit-source-id: 21ae309
master
Cristiano Calcagno 8 years ago committed by Facebook Github Bot
parent 61b49553b5
commit 60916922c6
74 changed files with 792 additions and 854 deletions
Show Stats Download Patch File Download Diff File

2
infer/src/IR/Cfg.re
Unescape View File

@ -74,7 +74,7 @@ let get_all_procs cfg => {
/** Get the procedures whose body is defined in this cfg */
let get_defined_procs cfg => IList.filter Procdesc.is_defined (get_all_procs cfg);
let get_defined_procs cfg => List.filter f::Procdesc.is_defined (get_all_procs cfg);
/** checks whether a cfg is connected or not */

5
infer/src/IR/Cg.re
Unescape View File

@ -223,7 +223,8 @@ let get_all_nodes (g: t) => {
IList.map (fun node => (node, get_calls g node)) nodes
};
let get_nodes_and_calls (g: t) => IList.filter (fun (n, _) => node_defined g n) (get_all_nodes g);
let get_nodes_and_calls (g: t) =>
List.filter f::(fun (n, _) => node_defined g n) (get_all_nodes g);
let node_get_num_ancestors g n => (n, Procname.Set.cardinal (get_ancestors g n));
@ -331,7 +332,7 @@ let get_nodes_and_edges (g: t) :nodes_and_edges => {
let get_defined_nodes (g: t) => {
let (nodes, _) = get_nodes_and_edges g;
let get_node (node, _) => node;
IList.map get_node (IList.filter (fun (_, defined) => defined) nodes)
IList.map get_node (List.filter f::(fun (_, defined) => defined) nodes)
};

19
infer/src/IR/Localise.ml
Unescape View File

@ -140,13 +140,11 @@ module Tags = struct
let create () = ref []
let add tags tag value = tags := (tag, value) :: !tags
let update tags tag value =
let tags' = IList.filter (fun (t, _) -> t <> tag) tags in
let tags' = List.filter ~f:(fun (t, _) -> t <> tag) tags in
(tag, value) :: tags'
let get tags tag =
try
let (_, v) = IList.find (fun (t, _) -> String.equal t tag) tags in
Some v
with Not_found -> None
List.find ~f:(fun (t, _) -> String.equal t tag) tags |>
Option.map ~f:snd
end
module BucketLevel = struct
@ -164,10 +162,9 @@ let error_desc_extract_tag_value err_desc tag_to_extract =
match v with
| (t, _) when String.equal t tag -> true
| _ -> false in
try
let _, s = IList.find (find_value tag_to_extract) err_desc.tags in
s
with Not_found -> ""
match List.find ~f:(find_value tag_to_extract) err_desc.tags with
| Some (_, s) -> s
| None -> ""
let error_desc_to_tag_value_pairs err_desc = err_desc.tags
@ -193,8 +190,8 @@ let error_desc_set_bucket err_desc bucket show_in_message =
(** get the value tag, if any *)
let get_value_line_tag tags =
try
let value = snd (IList.find (fun (tag, _) -> String.equal tag Tags.value) tags) in
let line = snd (IList.find (fun (tag, _) -> String.equal tag Tags.line) tags) in
let value = snd (List.find_exn ~f:(fun (tag, _) -> String.equal tag Tags.value) tags) in
let line = snd (List.find_exn ~f:(fun (tag, _) -> String.equal tag Tags.line) tags) in
Some [value; line]
with Not_found -> None

9
infer/src/IR/Objc_models.ml
Unescape View File

@ -238,11 +238,10 @@ struct
function_arg_is_cftype typ && String.equal funct cf_release
let is_core_graphics_release typ funct =
try
let cg_typ = IList.find
(fun lib -> (String.equal funct (lib^upper_release))) core_graphics_types in
(String.is_substring ~substring:(cg_typ^ref) typ)
with Not_found -> false
let f lib =
String.equal funct (lib ^ upper_release) &&
String.is_substring ~substring:(lib ^ ref) typ in
List.exists ~f core_graphics_types
(*
let function_arg_is_core_pgraphics typ =

10
infer/src/IR/Procdesc.re
Unescape View File

@ -89,7 +89,7 @@ let module Node = {
NodeSet.singleton n
} else {
NodeSet.union
acc (slice_nodes (IList.filter (fun s => not (NodeSet.mem s !visited)) n.succs))
acc (slice_nodes (List.filter f::(fun s => not (NodeSet.mem s !visited)) n.succs))
}
};
IList.fold_left do_node NodeSet.empty nodes
@ -105,7 +105,7 @@ let module Node = {
NodeSet.singleton n
} else {
NodeSet.union
acc (slice_nodes (IList.filter (fun s => not (NodeSet.mem s !visited)) n.preds))
acc (slice_nodes (List.filter f::(fun s => not (NodeSet.mem s !visited)) n.preds))
}
};
IList.fold_left do_node NodeSet.empty nodes
@ -132,9 +132,9 @@ let module Node = {
let visited = ref NodeSet.empty;
let rec nodes n => {
visited := NodeSet.add n !visited;
let succs = IList.filter (fun n => not (NodeSet.mem n !visited)) (generator n);
switch (IList.length succs) {
| 1 => [n, ...nodes (IList.hd succs)]
let succs = List.filter f::(fun n => not (NodeSet.mem n !visited)) (generator n);
switch succs {
| [hd] => [n, ...nodes hd]
| _ => [n]
}
};

58
infer/src/IR/Sil.re
Unescape View File

@ -692,21 +692,22 @@ let module Predicates: {
Can be applied only once, as it destroys the todo list */
let iter (env: env) f f_dll =>
while (env.todo != [] || env.todo_dll != []) {
if (env.todo != []) {
let hpara = IList.hd env.todo;
let () = env.todo = IList.tl env.todo;
switch env.todo {
| [hpara, ...todo'] =>
env.todo = todo';
let (n, emitted) = HparaHash.find env.hash hpara;
if (not emitted) {
f n hpara
}
} else if (
env.todo_dll != []
) {
let hpara_dll = IList.hd env.todo_dll;
let () = env.todo_dll = IList.tl env.todo_dll;
let (n, emitted) = HparaDllHash.find env.hash_dll hpara_dll;
if (not emitted) {
f_dll n hpara_dll
| [] =>
switch env.todo_dll {
| [hpara_dll, ...todo_dll'] =>
env.todo_dll = todo_dll';
let (n, emitted) = HparaDllHash.find env.hash_dll hpara_dll;
if (not emitted) {
f_dll n hpara_dll
}
| [] => ()
}
}
};
@ -1223,7 +1224,7 @@ let hpred_get_lexp acc =>
let hpred_list_get_lexps (filter: Exp.t => bool) (hlist: list hpred) :list Exp.t => {
let lexps = IList.fold_left hpred_get_lexp [] hlist;
IList.filter filter lexps
List.filter f::filter lexps
};
@ -1246,7 +1247,7 @@ let rec exp_fpv e =>
| Sizeof _ _ _ => []
};
let exp_list_fpv el => IList.flatten (IList.map exp_fpv el);
let exp_list_fpv el => List.concat (IList.map exp_fpv el);
let atom_fpv =
fun
@ -1260,12 +1261,12 @@ let rec strexp_fpv =
| Eexp e _ => exp_fpv e
| Estruct fld_se_list _ => {
let f (_, se) => strexp_fpv se;
IList.flatten (IList.map f fld_se_list)
List.concat (IList.map f fld_se_list)
}
| Earray len idx_se_list _ => {
let fpv_in_len = exp_fpv len;
let f (idx, se) => exp_fpv idx @ strexp_fpv se;
fpv_in_len @ IList.flatten (IList.map f idx_se_list)
fpv_in_len @ List.concat (IList.map f idx_se_list)
};
let rec hpred_fpv =
@ -1286,7 +1287,7 @@ let rec hpred_fpv =
analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. */
and hpara_fpv para => {
let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body);
let fpvars_in_body = List.concat (IList.map hpred_fpv para.body);
switch fpvars_in_body {
| [] => []
| _ => assert false
@ -1297,7 +1298,7 @@ and hpara_fpv para => {
analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. */
and hpara_dll_fpv para => {
let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body_dll);
let fpvars_in_body = List.concat (IList.map hpred_fpv para.body_dll);
switch fpvars_in_body {
| [] => []
| _ => assert false
@ -1391,11 +1392,11 @@ let fav_imperative_to_functional f x => {
/** [fav_filter_ident fav f] only keeps [id] if [f id] is true. */
let fav_filter_ident fav filter => fav := IList.filter filter !fav;
let fav_filter_ident fav filter => fav := List.filter f::filter !fav;
/** Like [fav_filter_ident] but return a copy. */
let fav_copy_filter_ident fav filter => ref (IList.filter filter !fav);
let fav_copy_filter_ident fav filter => ref (List.filter f::filter !fav);
/** checks whether every element in l1 appears l2 **/
@ -1730,17 +1731,17 @@ let sub_symmetric_difference sub1_in sub2_in => {
/** [sub_find filter sub] returns the expression associated to the first identifier
that satisfies [filter]. Raise [Not_found] if there isn't one. */
let sub_find filter (sub: subst) => snd (IList.find (fun (i, _) => filter i) sub);
let sub_find filter (sub: subst) => snd (List.find_exn f::(fun (i, _) => filter i) sub);
/** [sub_filter filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter]. */
let sub_filter filter (sub: subst) => IList.filter (fun (i, _) => filter i) sub;
let sub_filter filter (sub: subst) => List.filter f::(fun (i, _) => filter i) sub;
/** [sub_filter_pair filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter(id, sub(id))]. */
let sub_filter_pair = IList.filter;
let sub_filter_pair = List.filter;
/** [sub_range_partition filter sub] partitions [sub] according to
@ -1795,7 +1796,7 @@ let sub_fav_add fav (sub: subst) =>
)
sub;
let sub_fpv (sub: subst) => IList.flatten (IList.map (fun (_, e) => exp_fpv e) sub);
let sub_fpv (sub: subst) => List.concat (IList.map (fun (_, e) => exp_fpv e) sub);
/** Substitutions do not contain binders */
@ -2235,12 +2236,7 @@ let hpred_sub subst => {
/** {2 Functions for replacing occurrences of expressions.} */
let exp_replace_exp epairs e =>
try {
let (_, e') = IList.find (fun (e1, _) => Exp.equal e e1) epairs;
e'
} {
| Not_found => e
};
List.find f::(fun (e1, _) => Exp.equal e e1) epairs |> Option.value_map f::snd default::e;
let atom_replace_exp epairs atom => atom_expmap (fun e => exp_replace_exp epairs e) atom;
@ -2382,13 +2378,13 @@ let sigma_to_sigma_ne sigma :list (list atom, list hpred) =>
([Aeq e1 e2, ...eqs], sigma),
(eqs, [Hlseg Lseg_NE para e1 e2 el, ...sigma])
];
IList.flatten (IList.map g eqs_sigma_list)
List.concat (IList.map g eqs_sigma_list)
| Hdllseg Lseg_PE para_dll e1 e2 e3 e4 el =>
let g (eqs, sigma) => [
([Aeq e1 e3, Aeq e2 e4, ...eqs], sigma),
(eqs, [Hdllseg Lseg_NE para_dll e1 e2 e3 e4 el, ...sigma])
];
IList.flatten (IList.map g eqs_sigma_list)
List.concat (IList.map g eqs_sigma_list)
};
IList.fold_left f [([], [])] sigma
} else {

2
infer/src/IR/Sil.rei
Unescape View File

@ -716,7 +716,7 @@ let sub_filter: (Ident.t => bool) => subst => subst;
/** [sub_filter_exp filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter(id, sub(id))]. */
let sub_filter_pair: ((Ident.t, Exp.t) => bool) => subst => subst;
let sub_filter_pair: subst => f::((Ident.t, Exp.t) => bool) => subst;
/** [sub_range_partition filter sub] partitions [sub] according to

14
infer/src/IR/StructTyp.re
Unescape View File

@ -111,9 +111,8 @@ let fld_typ lookup::lookup default::default fn (typ: Typ.t) =>
| Tstruct name =>
switch (lookup name) {
| Some {fields} =>
try (snd3 (IList.find (fun (f, _, _) => Ident.equal_fieldname f fn) fields)) {
| Not_found => default
}
List.find f::(fun (f, _, _) => Ident.equal_fieldname f fn) fields |>
Option.value_map f::snd3 default::default
| None => default
}
| _ => default
@ -125,13 +124,8 @@ let get_field_type_and_annotation lookup::lookup fn (typ: Typ.t) =>
| Tptr (Tstruct name) _ =>
switch (lookup name) {
| Some {fields, statics} =>
try {
let (_, t, a) =
IList.find (fun (f, _, _) => Ident.equal_fieldname f fn) (fields @ statics);
Some (t, a)
} {
| Not_found => None
}
List.find_map
f::(fun (f, t, a) => Ident.equal_fieldname f fn ? Some (t, a) : None) (fields @ statics)
| None => None
}
| _ => None

2
infer/src/IR/Subtype.re
Unescape View File

@ -153,7 +153,7 @@ let is_instof t => equal_kind (snd t) INSTOF;
let list_intersect equal l1 l2 => {
let in_l2 a => List.mem equal::equal l2 a;
IList.filter in_l2 l1
List.filter f::in_l2 l1
};
let join_flag flag1 flag2 =>

4
infer/src/IR/Tenv.re
Unescape View File

@ -93,8 +93,8 @@ let add tenv name struct_typ => TypenameHash.replace tenv name struct_typ;
/** Get method that is being overriden by java_pname (if any) **/
let get_overriden_method tenv pname_java => {
let struct_typ_get_method_by_name (struct_typ: StructTyp.t) method_name =>
IList.find
(fun meth => String.equal method_name (Procname.get_method meth)) struct_typ.methods;
List.find_exn
f::(fun meth => String.equal method_name (Procname.get_method meth)) struct_typ.methods;
let rec get_overriden_method_in_supers pname_java supers =>
switch supers {
| [superclass, ...supers_tail] =>

32
infer/src/backend/Attribute.ml
Unescape View File

@ -38,7 +38,7 @@ let add_or_replace_check_changed tenv check_attribute_change prop atom0 =
| Sil.Apred (att0, ((_ :: _) as exps0)) | Anpred (att0, ((_ :: _) as exps0)) ->
let pairs =
IList.map (fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in
let _, nexp = IList.hd pairs in (* len exps0 > 0 by match *)
let _, nexp = List.hd_exn pairs in (* len exps0 > 0 by match *)
let natom = Sil.atom_replace_exp pairs atom0 in
let atom_map = function
| Sil.Apred (att, exp :: _) | Anpred (att, exp :: _)
@ -69,7 +69,7 @@ let get_all (prop: 'a Prop.t) =
(** Get all the attributes of the prop *)
let get_for_symb prop att =
IList.filter (function
List.filter ~f:(function
| Sil.Apred (att', _) | Anpred (att', _) -> PredSymb.equal att' att
| _ -> false
) prop.Prop.pi
@ -86,14 +86,12 @@ let get_for_exp tenv (prop: 'a Prop.t) exp =
let get tenv prop exp category =
let atts = get_for_exp tenv prop exp in
try
Some
(IList.find (function
| Sil.Apred (att, _) | Anpred (att, _) ->
PredSymb.equal_category (PredSymb.to_category att) category
| _ -> false
) atts)
with Not_found -> None
List.find
~f:(function
| Sil.Apred (att, _) | Anpred (att, _) ->
PredSymb.equal_category (PredSymb.to_category att) category
| _ -> false)
atts
let get_undef tenv prop exp =
get tenv prop exp ACundef
@ -248,11 +246,15 @@ let find_arithmetic_problem tenv proc_node_session prop exp =
| Exp.Sizeof (_, None, _) -> ()
| Exp.Sizeof (_, Some len, _) -> walk len in
walk exp;
try Some (Div0 (IList.find check_zero !exps_divided)), !res
with Not_found ->
(match !uminus_unsigned with
| (e, t):: _ -> Some (UminusUnsigned (e, t)), !res
| _ -> None, !res)
let problem_opt =
match (List.find ~f:check_zero !exps_divided, !uminus_unsigned) with
| Some e, _ ->
Some (Div0 e)
| None, (e, t):: _ ->
Some (UminusUnsigned (e, t))
| None, [] ->
None in
problem_opt, !res
(** Deallocate the stack variables in [pvars], and replace them by normal variables.
Return the list of stack variables whose address was still present after deallocation. *)

305
infer/src/backend/BuiltinDefn.ml
Unescape View File

@ -62,29 +62,30 @@ let return_result tenv e prop ret_id =
let add_array_to_prop tenv pdesc prop_ lexp typ =
let pname = Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
begin
try
let hpred = IList.find (function
let hpred_opt =
List.find
~f:(function
| Sil.Hpointsto(e, _, _) -> Exp.equal e n_lexp
| _ -> false) prop.Prop.sigma in
match hpred with
| Sil.Hpointsto(_, Sil.Earray (len, _, _), _) ->
Some (len, prop)
| _ -> None (* e points to something but not an array *)
with Not_found -> (* e is not allocated, so we can add the array *)
match extract_array_type typ with
| Some arr_typ ->
let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let s = mk_empty_array_rearranged len in
let hpred = Prop.mk_ptsto tenv n_lexp s (Exp.Sizeof (arr_typ, Some len, Subtype.exact)) in
let sigma = prop.Prop.sigma in
let sigma_fp = prop.Prop.sigma_fp in
let prop'= Prop.set prop ~sigma:(hpred:: sigma) in
let prop''= Prop.set prop' ~sigma_fp:(hpred:: sigma_fp) in
let prop''= Prop.normalize tenv prop'' in
Some (len, prop'')
| _ -> None
end
| _ -> false)
prop.Prop.sigma in
match hpred_opt with
| Some (Sil.Hpointsto (_, Sil.Earray (len, _, _), _)) ->
Some (len, prop)
| Some _ ->
None (* e points to something but not an array *)
| None ->
extract_array_type typ |>
Option.map ~f:(fun arr_typ ->
let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let s = mk_empty_array_rearranged len in
let hpred =
Prop.mk_ptsto tenv n_lexp s (Exp.Sizeof (arr_typ, Some len, Subtype.exact)) in
let sigma = prop.Prop.sigma in
let sigma_fp = prop.Prop.sigma_fp in
let prop'= Prop.set prop ~sigma:(hpred:: sigma) in
let prop''= Prop.set prop' ~sigma_fp:(hpred:: sigma_fp) in
let prop''= Prop.normalize tenv prop'' in
(len, prop''))
(* Add an array in prop if it is not allocated.*)
let execute___require_allocated_array { Builtin.tenv; pdesc; prop_; path; args; }
@ -146,40 +147,41 @@ let is_undefined_opt tenv prop n_lexp =
it doesn't appear already in the heap. *)
let create_type tenv n_lexp typ prop =
let prop_type =
try
let _ = IList.find (function
match
List.find ~f:(function
| Sil.Hpointsto(e, _, _) -> Exp.equal e n_lexp
| _ -> false) prop.Prop.sigma in
prop
with Not_found ->
let mhpred =
match typ with
| Typ.Tptr (typ', _) ->
let sexp = Sil.Estruct ([], Sil.inst_none) in
let texp = Exp.Sizeof (typ', None, Subtype.subtypes) in
let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in
Some hpred
| Typ.Tarray _ ->
let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let sexp = mk_empty_array len in
let texp = Exp.Sizeof (typ, None, Subtype.subtypes) in
let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in
Some hpred
| _ -> None in
match mhpred with
| Some hpred ->
let sigma = prop.Prop.sigma in
let sigma_fp = prop.Prop.sigma_fp in
let prop'= Prop.set prop ~sigma:(hpred:: sigma) in
let prop''=
let has_normal_variables =
Sil.fav_exists (Sil.exp_fav n_lexp) Ident.is_normal in
if (is_undefined_opt tenv prop n_lexp) || has_normal_variables
then prop'
else Prop.set prop' ~sigma_fp:(hpred:: sigma_fp) in
let prop''= Prop.normalize tenv prop'' in
prop''
| None -> prop in
| _ -> false) prop.Prop.sigma with
| Some _ ->
prop
| None ->
let mhpred =
match typ with
| Typ.Tptr (typ', _) ->
let sexp = Sil.Estruct ([], Sil.inst_none) in
let texp = Exp.Sizeof (typ', None, Subtype.subtypes) in
let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in
Some hpred
| Typ.Tarray _ ->
let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let sexp = mk_empty_array len in
let texp = Exp.Sizeof (typ, None, Subtype.subtypes) in
let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in
Some hpred
| _ -> None in
match mhpred with
| Some hpred ->
let sigma = prop.Prop.sigma in
let sigma_fp = prop.Prop.sigma_fp in
let prop'= Prop.set prop ~sigma:(hpred:: sigma) in
let prop''=
let has_normal_variables =
Sil.fav_exists (Sil.exp_fav n_lexp) Ident.is_normal in
if (is_undefined_opt tenv prop n_lexp) || has_normal_variables
then prop'
else Prop.set prop' ~sigma_fp:(hpred:: sigma_fp) in
let prop''= Prop.normalize tenv prop'' in
prop''
| None -> prop in
let sil_is_null = Exp.BinOp (Binop.Eq, n_lexp, Exp.zero) in
let sil_is_nonnull = Exp.UnOp (Unop.LNot, sil_is_null, None) in
let null_case = Propset.to_proplist (prune tenv ~positive:true sil_is_null prop) in
@ -198,17 +200,15 @@ let execute___get_type_of { Builtin.pdesc; tenv; prop_; path; ret_id; args; }
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let props = create_type tenv n_lexp typ prop in
let aux prop =
begin
try
let hpred = IList.find (function
| Sil.Hpointsto(e, _, _) -> Exp.equal e n_lexp
| _ -> false) prop.Prop.sigma in
match hpred with
| Sil.Hpointsto(_, _, texp) ->
(return_result tenv texp prop ret_id), path
| _ -> assert false
with Not_found -> (return_result tenv Exp.zero prop ret_id), path
end in
let hpred_opt =
List.find_map ~f:(function
| Sil.Hpointsto(e, _, texp) when Exp.equal e n_lexp -> Some texp
| _ -> None) prop.Prop.sigma in
match hpred_opt with
| Some texp ->
((return_result tenv texp prop ret_id), path)
| None ->
((return_result tenv Exp.zero prop ret_id), path) in
(IList.map aux props)
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
@ -252,50 +252,52 @@ let execute___instanceof_cast ~instof
if Exp.equal texp2 Exp.zero then
[(return_result tenv Exp.zero prop ret_id, path)]
else
begin
try
let hpred = IList.find (function
| Sil.Hpointsto (e1, _, _) -> Exp.equal e1 val1
| _ -> false) prop.Prop.sigma in
match hpred with
| Sil.Hpointsto (_, _, texp1) ->
let pos_type_opt, neg_type_opt =
Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2 in
let mk_res type_opt res_e = match type_opt with
| None -> []
| Some texp1' ->
let prop' =
if Exp.equal texp1 texp1' then prop
else replace_ptsto_texp tenv prop val1 texp1' in
[(return_result tenv res_e prop' ret_id, path)] in
if instof then (* instanceof *)
let pos_res = mk_res pos_type_opt Exp.one in
let neg_res = mk_res neg_type_opt Exp.zero in
pos_res @ neg_res
else (* cast *)
if not should_throw_exception then (* C++ case when negative cast returns 0 *)
let pos_res = mk_res pos_type_opt val1 in
let neg_res = mk_res neg_type_opt Exp.zero in
pos_res @ neg_res
else
begin
if !Config.footprint then
match pos_type_opt with
| None -> deal_with_failed_cast val1 texp1 texp2
| Some _ -> mk_res pos_type_opt val1
else (* !Config.footprint is false *)
match neg_type_opt with
| Some _ ->
if is_undefined_opt tenv prop val1 then mk_res pos_type_opt val1
else deal_with_failed_cast val1 texp1 texp2
| None -> mk_res pos_type_opt val1
end
| _ -> []
with Not_found ->
[(return_result tenv val1 prop ret_id, path)]
end in
let res_opt =
List.find ~f:(function
| Sil.Hpointsto (e1, _, _) -> Exp.equal e1 val1
| _ -> false) prop.Prop.sigma |>
Option.map ~f:(function
| Sil.Hpointsto (_, _, texp1) ->
let pos_type_opt, neg_type_opt =
Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2 in
let mk_res type_opt res_e = match type_opt with
| None -> []
| Some texp1' ->
let prop' =
if Exp.equal texp1 texp1' then prop
else replace_ptsto_texp tenv prop val1 texp1' in
[(return_result tenv res_e prop' ret_id, path)] in
if instof then (* instanceof *)
let pos_res = mk_res pos_type_opt Exp.one in
let neg_res = mk_res neg_type_opt Exp.zero in
pos_res @ neg_res
else (* cast *)
if not should_throw_exception then (* C++ case when negative cast returns 0 *)
let pos_res = mk_res pos_type_opt val1 in
let neg_res = mk_res neg_type_opt Exp.zero in
pos_res @ neg_res
else
begin
if !Config.footprint then
match pos_type_opt with
| None -> deal_with_failed_cast val1 texp1 texp2
| Some _ -> mk_res pos_type_opt val1
else (* !Config.footprint is false *)
match neg_type_opt with
| Some _ ->
if is_undefined_opt tenv prop val1 then mk_res pos_type_opt val1
else deal_with_failed_cast val1 texp1 texp2
| None -> mk_res pos_type_opt val1
end
| _ -> []
) in
match res_opt with
| Some res ->
res
| None ->
[(return_result tenv val1 prop ret_id, path)] in
let props = create_type tenv val1 typ1 prop in
IList.flatten (IList.map exe_one_prop props)
List.concat (IList.map exe_one_prop props)
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___instanceof builtin_args
@ -399,9 +401,11 @@ let execute___get_hidden_field { Builtin.tenv; pdesc; prop_; path; ret_id; args;
| Sil.Hpointsto(e, Sil.Estruct (fsel, _), _)
when Exp.equal e n_lexp && not in_foot && has_fld_hidden fsel ->
let set_ret_val () =
match IList.find filter_fld_hidden fsel with
| _, Sil.Eexp(e, _) -> ret_val := Some e
| _ -> () in
match List.find ~f:filter_fld_hidden fsel with
| Some (_, Sil.Eexp(e, _)) ->
ret_val := Some e
| _ ->
() in
set_ret_val();
hpred
| _ -> hpred in
@ -430,7 +434,7 @@ let execute___set_hidden_field { Builtin.tenv; pdesc; prop_; path; args; }
let se = Sil.Eexp(n_lexp2, Sil.inst_none) in
let fsel' =
(Ident.fieldname_hidden, se) ::
(IList.filter (fun x -> not (filter_fld_hidden x)) fsel) in
(List.filter ~f:(fun x -> not (filter_fld_hidden x)) fsel) in
Sil.Hpointsto(e, Sil.Estruct (fsel', inst), texp)
| Sil.Hpointsto(e, Sil.Estruct (fsel, inst), texp)
when Exp.equal e n_lexp1 && in_foot && not (has_fld_hidden fsel) ->
@ -545,21 +549,21 @@ let execute___release_autorelease_pool
let call_release res atom =
match res, atom with
| ((prop', path') :: _, Sil.Apred (_, exp :: _)) ->
(try
let hpred = IList.find (function
| Sil.Hpointsto(e1, _, _) -> Exp.equal e1 exp
| _ -> false) prop_.Prop.sigma in
match hpred with
| Sil.Hpointsto (_, _, Exp.Sizeof (typ, _, _)) ->
let res1 =
execute___objc_release
{ builtin_args with
Builtin.args = [(exp, typ)];
prop_ = prop';
path = path'; } in
res1
| _ -> res
with Not_found -> res)
List.find ~f:(function
| Sil.Hpointsto(e1, _, _) -> Exp.equal e1 exp
| _ -> false) prop_.Prop.sigma |>
Option.value_map ~f:(function
| Sil.Hpointsto (_, _, Exp.Sizeof (typ, _, _)) ->
let res1 =
execute___objc_release
{ builtin_args with
Builtin.args = [(exp, typ)];
prop_ = prop';
path = path'; } in
res1
| _ -> res
)
~default:res
| _ -> res in
IList.fold_left call_release [(prop_without_attribute, path)] autoreleased_objects
else execute___no_op prop_ path
@ -644,16 +648,21 @@ let execute___objc_cast { Builtin.tenv; pdesc; prop_; path; ret_id; args; }
let pname = Procdesc.get_proc_name pdesc in
let val1, prop__ = check_arith_norm_exp tenv pname val1_ prop_ in
let texp2, prop = check_arith_norm_exp tenv pname texp2_ prop__ in
(try
let hpred = IList.find (function
(match
List.find ~f:(function
| Sil.Hpointsto(e1, _, _) -> Exp.equal e1 val1
| _ -> false) prop.Prop.sigma in
match hpred, texp2 with
| Sil.Hpointsto (val1, _, _), Exp.Sizeof _ ->
let prop' = replace_ptsto_texp tenv prop val1 texp2 in
[(return_result tenv val1 prop' ret_id, path)]
| _ -> [(return_result tenv val1 prop ret_id, path)]
with Not_found -> [(return_result tenv val1 prop ret_id, path)])
| _ -> false) prop.Prop.sigma |>
Option.map ~f:(fun hpred -> match hpred, texp2 with
| Sil.Hpointsto (val1, _, _), Exp.Sizeof _ ->
let prop' = replace_ptsto_texp tenv prop val1 texp2 in
[(return_result tenv val1 prop' ret_id, path)]
| _ -> [(return_result tenv val1 prop ret_id, path)]
)
with
| Some res ->
res
| None ->
[(return_result tenv val1 prop ret_id, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_abort { Builtin.proc_name; }
@ -720,7 +729,7 @@ let execute_free mk { Builtin.pdesc; instr; tenv; prop_; path; args; loc; }
Propset.to_proplist (prune tenv ~positive:false n_lexp prop) in
let plist =
prop_zero @ (* model: if 0 then skip else _execute_free_nonzero *)
IList.flatten (IList.map (fun p ->
List.concat (IList.map (fun p ->
_execute_free_nonzero mk pdesc tenv instr p
(Prop.exp_normalize_prop tenv p lexp) typ loc) prop_nonzero) in
IList.map (fun p -> (p, path)) plist
@ -792,18 +801,18 @@ let execute___cxx_typeid ({ Builtin.pdesc; tenv; prop_; args; loc} as r)
| type_info_exp :: rest ->
(let res = execute_alloc PredSymb.Mnew false { r with args = [type_info_exp] } in
match rest with
| [(field_exp, _); (lexp, typ)] ->
| [(field_exp, _); (lexp, typ_)] ->
let pname = Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let typ =
try
let hpred = IList.find (function
| Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp
| _ -> false) prop.Prop.sigma in
match hpred with
| Sil.Hpointsto (_, _, Exp.Sizeof (dynamic_type, _, _)) -> dynamic_type
| _ -> typ
with Not_found -> typ in
List.find ~f:(function
| Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp
| _ -> false) prop.Prop.sigma |>
Option.value_map ~f:(function
| Sil.Hpointsto (_, _, Exp.Sizeof (dynamic_type, _, _)) -> dynamic_type
| _ -> typ_
)
~default:typ_ in
let typ_string = Typ.to_string typ in
let set_instr =
Sil.Store (field_exp, Typ.Tvoid, Exp.Const (Const.Cstr typ_string), loc) in
@ -843,7 +852,7 @@ let execute_scan_function skip_n_arguments ({ Builtin.args } as call_args)
match args with
| _ when IList.length args >= skip_n_arguments ->
let varargs = ref args in
for _ = 1 to skip_n_arguments do varargs := IList.tl !varargs done;
varargs := List.drop !varargs skip_n_arguments;
SymExec.unknown_or_scan_call
~is_scan:true
None

2
infer/src/backend/InferAnalyze.re
Unescape View File

@ -54,7 +54,7 @@ let analyze_cluster cluster_num (cluster: Cluster.t) => {
};
let output_json_makefile_stats clusters => {
let clusters_to_analyze = IList.filter ClusterMakefile.cluster_should_be_analyzed clusters;
let clusters_to_analyze = List.filter f::ClusterMakefile.cluster_should_be_analyzed clusters;
let num_files = IList.length clusters_to_analyze;
let num_procs = 0;
/* can't compute it at this stage */

7
infer/src/backend/InferPrint.re
Unescape View File

@ -33,13 +33,13 @@ let load_specfiles () => {
| Sys_error _ => []
};
let all_filepaths = IList.map (fun fname => Filename.concat dir fname) all_filenames;
IList.filter is_specs_file all_filepaths
List.filter f::is_specs_file all_filepaths
};
let specs_dirs = {
let result_specs_dir = DB.filename_to_string DB.Results_dir.specs_dir;
[result_specs_dir, ...Config.specs_library]
};
IList.flatten (IList.map specs_files_in_dir specs_dirs)
List.concat (IList.map specs_files_in_dir specs_dirs)
};
@ -543,7 +543,8 @@ let pp_tests_of_report fmt report => {
let pp_trace_elem fmt {description} => F.fprintf fmt "%s" description;
let pp_trace fmt trace =>
if Config.print_traces_in_tests {
let trace_without_empty_descs = IList.filter (fun {description} => description != "") trace;
let trace_without_empty_descs =
List.filter f::(fun {description} => description != "") trace;
F.fprintf fmt ", [%a]" (Pp.comma_seq pp_trace_elem) trace_without_empty_descs
};
let pp_row jsonbug =>

10
infer/src/backend/PropUtil.re
Unescape View File

@ -25,7 +25,7 @@ let get_name_of_objc_static_locals (curr_f: Procdesc.t) p => {
| _ => []
};
let vars_sigma = IList.map hpred_local_static p.Prop.sigma;
IList.flatten (IList.flatten vars_sigma)
List.concat (List.concat vars_sigma)
};
/* returns a list of local variables that points to an objc block in a proposition */
@ -41,7 +41,7 @@ let get_name_of_objc_block_locals p => {
| _ => []
};
let vars_sigma = IList.map hpred_local_blocks p.Prop.sigma;
IList.flatten (IList.flatten vars_sigma)
List.concat (List.concat vars_sigma)
};
let remove_abduced_retvars tenv p => {
@ -101,8 +101,8 @@ let remove_abduced_retvars tenv p => {
| Exp.BinOp _ e0 e1
| Exp.Lindex e0 e1 => exp_contains e0 || exp_contains e1
| _ => false;
IList.filter
(
List.filter
f::(
fun
| Sil.Aeq lhs rhs
| Sil.Aneq lhs rhs => exp_contains lhs || exp_contains rhs
@ -202,6 +202,6 @@ let remove_seed_vars tenv (prop: Prop.t 'a) :Prop.t Prop.normal => {
| Sil.Hpointsto (Exp.Lvar pv) _ _ => not (Pvar.is_seed pv)
| _ => true;
let sigma = prop.sigma;
let sigma' = IList.filter hpred_not_seed sigma;
let sigma' = List.filter f::hpred_not_seed sigma;
Prop.normalize tenv (Prop.set prop sigma::sigma')
};

2
infer/src/backend/StatsAggregator.re
Unescape View File

@ -33,7 +33,7 @@ let find_json_files_in_dir dir => {
{
let content = Array.to_list (Sys.readdir dir);
let content_with_path = IList.map (fun p => Filename.concat dir p) content;
IList.filter is_valid_json_file content_with_path
List.filter f::is_valid_json_file content_with_path
} :
[]
};

58
infer/src/backend/abs.ml
Unescape View File

@ -71,13 +71,13 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.subst) =
let inst_of_base = try Sil.sub_find (Ident.equal id_base) inst_public with Not_found -> assert false in
let insts_of_private_ids = Sil.sub_range inst_private in
(insts_of_private_ids, insts_of_public_ids, inst_of_base) in
let fav_insts_of_public_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_public_ids) in
let fav_insts_of_private_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_private_ids) in
let fav_insts_of_public_ids = List.concat (IList.map Sil.exp_fav_list insts_of_public_ids) in
let fav_insts_of_private_ids = List.concat (IList.map Sil.exp_fav_list insts_of_private_ids) in
let (fav_p_leftover, _) =
let sigma = p_leftover.Prop.sigma in
(sigma_fav_list sigma, sigma_fav_in_pvars_list sigma) in
let fpv_inst_of_base = Sil.exp_fpv inst_of_base in
let fpv_insts_of_private_ids = IList.flatten (IList.map Sil.exp_fpv insts_of_private_ids) in
let fpv_insts_of_private_ids = List.concat (IList.map Sil.exp_fpv insts_of_private_ids) in
(*
let fav_inst_of_base = Sil.exp_fav_list inst_of_base in
L.out "@[.... application of condition ....@\n@.";
@ -420,7 +420,7 @@ let typ_get_recursive_flds tenv typ_exp =
match typ with
| Tstruct name -> (
match Tenv.lookup tenv name with
| Some { fields } -> IList.map fst3 (IList.filter (filter typ) fields)
| Some { fields } -> IList.map fst3 (List.filter ~f:(filter typ) fields)
| None ->
L.err "@.typ_get_recursive: unexpected type expr: %a@." Exp.pp typ_exp;
[] (* ToDo: assert false *)
@ -473,7 +473,7 @@ let discover_para_candidates tenv p =
match se with
| Sil.Eexp _ | Sil.Earray _ -> ()
| Sil.Estruct (fsel, _) ->
let fsel' = IList.filter (fun (fld, _) -> is_rec_fld fld) fsel in
let fsel' = List.filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in
let process (_, nextse) =
match nextse with
| Sil.Eexp (next, _) -> add_edge (root, next)
@ -491,7 +491,7 @@ let discover_para_candidates tenv p =
| [] -> IList.rev found
| (e1, e2) :: edges_notseen ->
let edges_others = (IList.rev edges_seen) @ edges_notseen in
let edges_matched = IList.filter (fun (e1', _) -> Exp.equal e2 e1') edges_others in
let edges_matched = List.filter ~f:(fun (e1', _) -> Exp.equal e2 e1') edges_others in
let new_found =
let f found_acc (_, e3) = (e1, e2, e3) :: found_acc in
IList.fold_left f found edges_matched in
@ -509,7 +509,7 @@ let discover_para_dll_candidates tenv p =
match se with
| Sil.Eexp _ | Sil.Earray _ -> ()
| Sil.Estruct (fsel, _) ->
let fsel' = IList.filter (fun (fld, _) -> is_rec_fld fld) fsel in
let fsel' = List.filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in
let convert_to_exp acc (_, se) =
match se with
| Sil.Eexp (e, _) -> e:: acc
@ -531,7 +531,7 @@ let discover_para_dll_candidates tenv p =
| [] -> IList.rev found
| (iF, blink, flink) :: edges_notseen ->
let edges_others = (IList.rev edges_seen) @ edges_notseen in
let edges_matched = IList.filter (fun (e1', _, _) -> Exp.equal flink e1') edges_others in
let edges_matched = List.filter ~f:(fun (e1', _, _) -> Exp.equal flink e1') edges_others in
let new_found =
let f found_acc (_, _, flink2) = (iF, blink, flink, flink2) :: found_acc in
IList.fold_left f found edges_matched in
@ -627,7 +627,7 @@ let eqs_solve ids_in eqs_in =
let sub_dom = IList.map fst sub_list in
let filter id =
not (List.exists ~f:(fun id' -> Ident.equal id id') sub_dom) in
IList.filter filter ids_in in
List.filter ~f:filter ids_in in
match solve Sil.sub_empty eqs_in with
| None -> None
| Some sub -> Some (compute_ids sub, sub)
@ -703,8 +703,8 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
let (closed_paras_sll, closed_paras_dll) =
let paras_sll = discover_para tenv p in
let paras_dll = discover_para_dll tenv p in
let closed_paras_sll = IList.flatten (IList.map hpara_special_cases paras_sll) in
let closed_paras_dll = IList.flatten (IList.map hpara_special_cases_dll paras_dll) in
let closed_paras_sll = List.concat (IList.map hpara_special_cases paras_sll) in
let closed_paras_dll = List.concat (IList.map hpara_special_cases_dll paras_dll) in
begin
(*
if IList.length closed_paras_sll >= 1 then
@ -733,8 +733,8 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
let filter_dll para =
not (List.exists ~f:(eq_dll para) old_rsets) &&
not (List.exists ~f:(eq_dll para) !new_rsets) in
let todo_paras_sll = IList.filter filter_sll closed_paras_sll in
let todo_paras_dll = IList.filter filter_dll closed_paras_dll in
let todo_paras_sll = List.filter ~f:filter_sll closed_paras_sll in
let todo_paras_dll = List.filter ~f:filter_dll closed_paras_dll in
(todo_paras_sll, todo_paras_dll) in
let f_recurse () =
let todo_rsets_sll =
@ -771,7 +771,7 @@ let abstract_pure_part tenv p ~(from_abstract_footprint: bool) =
if Ident.is_primed id then Sil.fav_mem fav_sigma id
else if Ident.is_footprint id then Sil.fav_mem fav_nonpure id
else true) in
IList.filter filter pure in
List.filter ~f:filter pure in
let new_pure =
IList.fold_left
(fun pi a ->
@ -825,7 +825,7 @@ let abstract_gc tenv p =
Sil.fav_is_empty fav_a
||
IList.intersect Ident.compare (Sil.fav_to_list fav_a) (Sil.fav_to_list fav_p_without_pi) in
let new_pi = IList.filter strong_filter pi in
let new_pi = List.filter ~f:strong_filter pi in
let prop = Prop.normalize tenv (Prop.set p ~pi:new_pi) in
match Prop.prop_iter_create prop with
| None -> prop
@ -882,11 +882,11 @@ let get_cycle root prop =
let get_points_to e =
match e with
| Sil.Eexp(e', _) ->
(try
Some(IList.find (fun hpred -> match hpred with
| Sil.Hpointsto(e'', _, _) -> Exp.equal e'' e'
| _ -> false) sigma)
with _ -> None)
List.find
~f:(fun hpred -> match hpred with
| Sil.Hpointsto (e'', _, _) -> Exp.equal e'' e'
| _ -> false)
sigma
| _ -> None in
let print_cycle cyc =
(L.d_str "Cycle= ";
@ -962,10 +962,8 @@ let get_var_retain_cycle prop_ =
when Exp.equal e e' && Typ.is_block_type typ -> true
| _, _ -> false in
let find v =
try
let hp = IList.find (is_pvar v) sigma in
Some (Sil.hpred_get_lhs hp)
with Not_found -> None in
List.find ~f:(is_pvar v) sigma |>
Option.map ~f:Sil.hpred_get_lhs in
let find_block v =
if (List.exists ~f:(is_hpred_block v) sigma) then
Some (Exp.Lvar Sil.block_pvar)
@ -987,7 +985,7 @@ let get_var_retain_cycle prop_ =
| hp:: sigma' ->
let cycle = get_cycle hp prop_ in
L.d_strln "Filtering pvar in cycle ";
let cycle' = IList.flatten (IList.map find_or_block cycle) in
let cycle' = List.concat (IList.map find_or_block cycle) in
if List.is_empty cycle' then do_sigma sigma'
else cycle' in
do_sigma sigma
@ -1007,8 +1005,8 @@ let cycle_has_weak_or_unretained_or_assign_field tenv cycle =
let equal_fn (fn', _, _) = Ident.equal_fieldname fn fn' in
match Tenv.lookup tenv name with
| Some { fields; statics } -> (
try trd3 (IList.find equal_fn (fields @ statics))
with Not_found -> []
List.find ~f:equal_fn (fields @ statics) |>
Option.value_map ~f:trd3 ~default:[]
)
| None -> []
)
@ -1241,9 +1239,9 @@ let get_local_stack cur_sigma init_sigma =
let filter_local_stack olds = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) -> not (List.exists ~f:(Pvar.equal pvar) olds)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> false in
let init_stack = IList.filter filter_stack init_sigma in
let init_stack = List.filter ~f:filter_stack init_sigma in
let init_stack_pvars = IList.map get_stack_var init_stack in
let cur_local_stack = IList.filter (filter_local_stack init_stack_pvars) cur_sigma in
let cur_local_stack = List.filter ~f:(filter_local_stack init_stack_pvars) cur_sigma in
let cur_local_stack_pvars = IList.map get_stack_var cur_local_stack in
(cur_local_stack, cur_local_stack_pvars)
@ -1261,7 +1259,7 @@ let remove_local_stack sigma pvars =
let filter_non_stack = function
| Sil.Hpointsto (Exp.Lvar pvar, _, _) -> not (List.exists ~f:(Pvar.equal pvar) pvars)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> true in
IList.filter filter_non_stack sigma
List.filter ~f:filter_non_stack sigma
(** [prop_set_fooprint p p_foot] removes a local stack from [p_foot],
and sets proposition [p_foot] as footprint of [p]. *)

56
infer/src/backend/absarray.ml
Unescape View File

@ -76,14 +76,16 @@ end = struct
| Sil.Estruct (fsel, _), Tstruct name, Field (fld, _) :: syn_offs' -> (
match Tenv.lookup tenv name with
| Some { fields } ->
let se' = snd (IList.find (fun (f', _) -> Ident.equal_fieldname f' fld) fsel) in
let t' = snd3 (IList.find (fun (f', _, _) -> Ident.equal_fieldname f' fld) fields) in
let se' =
snd (List.find_exn ~f:(fun (f', _) -> Ident.equal_fieldname f' fld) fsel) in
let t' =
snd3 (List.find_exn ~f:(fun (f', _, _) -> Ident.equal_fieldname f' fld) fields) in
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| None ->
fail ()
)
| Sil.Earray (_, esel, _), Typ.Tarray (t', _), Index ind :: syn_offs' ->
let se' = snd (IList.find (fun (i', _) -> Exp.equal i' ind) esel) in
let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| _ ->
fail ()
@ -96,9 +98,9 @@ end = struct
| Sil.Estruct (fsel, inst), Tstruct name, Field (fld, _) :: syn_offs' -> (
match Tenv.lookup tenv name with
| Some { fields } ->
let se' = snd (IList.find (fun (f', _) -> Ident.equal_fieldname f' fld) fsel) in
let se' = snd (List.find_exn ~f:(fun (f', _) -> Ident.equal_fieldname f' fld) fsel) in
let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) ->
(List.find_exn ~f:(fun (f', _, _) ->
Ident.equal_fieldname f' fld) fields) in
let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let fsel' =
@ -110,7 +112,7 @@ end = struct
assert false
)
| Sil.Earray (len, esel, inst), Tarray (t', _), Index idx :: syn_offs' ->
let se' = snd (IList.find (fun (i', _) -> Exp.equal i' idx) esel) in
let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in
let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let esel' =
IList.map (fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel in
@ -150,7 +152,7 @@ end = struct
let filter = function
| Sil.Hpointsto (e, _, _) -> Exp.equal root e
| _ -> false in
let hpred = IList.find filter sigma in
let hpred = List.find_exn ~f:filter sigma in
(sigma, hpred, syn_offs)
(** Find a sub strexp with the given property. Can raise [Not_found] *)
@ -177,11 +179,12 @@ end = struct
| [] -> ()
| (f, se) :: fsel' ->
begin
try
let t = snd3 (IList.find (fun (f', _, _) -> Ident.equal_fieldname f' f) ftal) in
find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t
with Not_found ->
L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find")
match List.find ~f:(fun (f', _, _) -> Ident.equal_fieldname f' f) ftal with
| Some (_, t, _) ->
find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t
| None ->
L.d_strln
("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find")
end;
find_offset_fsel sigma_other hpred root offs fsel' ftal typ
and find_offset_esel sigma_other hpred root offs esel t = match esel with
@ -261,18 +264,6 @@ end = struct
| _ -> assert false in
let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in
replace_hpred (sigma, hpred, syn_offs) hpred'
(*
(** Get the partition of the sigma: the unmatched part of the sigma and the matched hpred *)
let get_sigma_partition (sigma, hpred, _) =
let sigma_unmatched = IList.filter (fun hpred' -> not (hpred' == hpred)) sigma in
(sigma_unmatched, hpred)
(** Replace the strexp and the unmatched part of the sigma by the given inputs *)
let replace_strexp_sigma footprint_part ((_, hpred, syn_offs) : t) se_in sigma_in =
let new_sigma = hpred :: sigma_in in
let sigma' = replace_strexp tenv footprint_part (new_sigma, hpred, syn_offs) se_in in
IList.sort Sil.compare_hpred sigma'
*)
end
(** This function renames expressions in [p]. The renaming is, roughly
@ -292,10 +283,9 @@ let prop_replace_path_index tenv
) acc_outer map
) [] elist_path in
let expmap_fun e' =
try
let _, fresh_e = IList.find (fun (e, _) -> Exp.equal e e') expmap_list in
fresh_e
with Not_found -> e' in
Option.value_map
~f:snd (List.find ~f:(fun (e, _) -> Exp.equal e e') expmap_list)
~default:e' in
Prop.prop_expmap expmap_fun p
(** This function uses [update] and transforms the two sigma parts of [p],
@ -376,7 +366,7 @@ let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (i
let elist_path = StrexpMatch.path_to_exps path in
let add_index i e = Prop.exp_normalize_prop tenv p (Exp.Lindex(e, i)) in
fun i -> IList.map (add_index i) elist_path in
let pointers = IList.flatten (IList.map add_index_to_paths indices) in
let pointers = List.concat (IList.map add_index_to_paths indices) in
let filter = function
| Sil.Hpointsto (_, Sil.Eexp (e, _), _) -> List.exists ~f:(Exp.equal e) pointers
| _ -> false in
@ -502,7 +492,7 @@ let strexp_do_abstract tenv
let default_indices =
match IList.map fst esel with
| [] -> []
| indices -> [IList.hd (IList.rev indices)] (* keep last key at least *) in
| indices -> [List.hd_exn (IList.rev indices)] (* keep last key at least *) in
partition_abstract should_keep abstract esel default_indices in
let do_footprint () =
match se_in with
@ -510,7 +500,7 @@ let strexp_do_abstract tenv
| _ -> assert false in
let filter_abstract d_keys should_keep abstract ksel default_keys =
let keep_ksel = IList.filter should_keep ksel in
let keep_ksel = List.filter ~f:should_keep ksel in
let keep_keys = IList.map fst keep_ksel in
let keep_keys' = if List.is_empty keep_keys then default_keys else keep_keys in
if Config.trace_absarray then (L.d_str "keep "; d_keys keep_keys'; L.d_ln ());
@ -593,7 +583,7 @@ let remove_redundant_elements tenv prop =
Sil.fav_duplicates := false;
(* L.d_str "favl_curr "; IList.iter (fun id -> Sil.d_exp (Exp.Var id)) favl_curr; L.d_ln();
L.d_str "favl_foot "; IList.iter (fun id -> Sil.d_exp (Exp.Var id)) favl_foot; L.d_ln(); *)
let num_occur l id = IList.length (IList.filter (fun id' -> Ident.equal id id') l) in
let num_occur l id = IList.length (List.filter ~f:(fun id' -> Ident.equal id id') l) in
let at_most_once v =
num_occur favl_curr v <= 1 && num_occur favl_foot v <= 1 in
at_most_once in
@ -613,7 +603,7 @@ let remove_redundant_elements tenv prop =
| _ -> true in
let remove_redundant_se fp_part = function
| Sil.Earray (len, esel, inst) ->
let esel' = IList.filter (filter_redundant_e_se fp_part) esel in
let esel' = List.filter ~f:(filter_redundant_e_se fp_part) esel in
Sil.Earray (len, esel', inst)
| se -> se in
let remove_redundant_hpred fp_part = function

2
infer/src/backend/callbacks.ml
Unescape View File

@ -122,7 +122,7 @@ let iterate_cluster_callbacks all_procs exe_env proc_names =
(* Procedures matching the given language or all if no language is specified. *)
let relevant_procedures language_opt =
Option.value_map
~f:(fun l -> IList.filter (fun p -> Config.equal_language l (get_language p)) proc_names)
~f:(fun l -> List.filter ~f:(fun p -> Config.equal_language l (get_language p)) proc_names)
~default:proc_names
language_opt in

2
infer/src/backend/crashcontext.ml
Unescape View File

@ -23,7 +23,7 @@ let frame_id_of_stackframe frame =
loc_str
let frame_id_of_summary stacktree =
let short_name = IList.hd
let short_name = List.hd_exn
(Str.split (Str.regexp "(") stacktree.Stacktree_j.method_name) in
match stacktree.Stacktree_j.location with
| None ->

123
infer/src/backend/dom.ml
Unescape View File

@ -450,13 +450,16 @@ end = struct
if n1 <> 0 then n1 else Exp.compare e2 e2'
let get_fresh_exp e1 e2 =
try
let (_, _, e) = IList.find (fun (e1', e2', _) -> Exp.equal e1 e1' && Exp.equal e2 e2') !t in
e
with Not_found ->
let e = Exp.get_undefined (JoinState.get_footprint ()) in
t := (e1, e2, e)::!t;
e
match
List.find ~f:(fun (e1', e2', _) -> Exp.equal e1 e1' && Exp.equal e2 e2') !t |>
Option.map ~f:trd3
with
| Some res ->
res
| None ->
let e = Exp.get_undefined (JoinState.get_footprint ()) in
t := (e1, e2, e)::!t;
e
let get_induced_atom tenv acc strict_lower upper e =
let ineq_lower = Prop.mk_inequality tenv (Exp.BinOp(Binop.Lt, strict_lower, e)) in
@ -478,14 +481,19 @@ end = struct
let rec f_eqs_entry ((e1, e2, e) as entry) eqs_acc t_seen = function
| [] -> eqs_acc, t_seen
| ((e1', e2', e') as entry'):: t_rest' ->
try
let n = IList.find (fun n -> add_and_chk_eq e1 e1' n && add_and_chk_eq e2 e2' n) minus2_to_2 in
let eq = add_and_gen_eq e e' n in
let eqs_acc' = eq:: eqs_acc in
f_eqs_entry entry eqs_acc' t_seen t_rest'
with Not_found ->
let t_seen' = entry':: t_seen in
f_eqs_entry entry eqs_acc t_seen' t_rest' in
(match
List.find ~f:(fun n ->
add_and_chk_eq e1 e1' n && add_and_chk_eq e2 e2' n) minus2_to_2 |>
Option.map ~f:(fun n ->
let eq = add_and_gen_eq e e' n in
let eqs_acc' = eq:: eqs_acc in
f_eqs_entry entry eqs_acc' t_seen t_rest')
with
| Some res ->
res
| None ->
let t_seen' = entry':: t_seen in
f_eqs_entry entry eqs_acc t_seen' t_rest') in
let rec f_eqs eqs_acc t_acc = function
| [] -> (eqs_acc, t_acc)
| entry:: t_rest ->
@ -505,15 +513,6 @@ end = struct
| _ -> acc in
IList.fold_left f_ineqs eqs t_minimal
(*
let lookup side e =
try
let (e1, e2, e) =
IList.find (fun (e1', e2', _) -> Exp.equal e (select side e1' e2')) !t in
Some (e, select (opposite side) e1 e2)
with Not_found ->
None
*)
end
(** {2 Modules for renaming} *)
@ -556,7 +555,7 @@ end = struct
(Ident.is_footprint id) &&
(Sil.fav_for_all (Sil.exp_fav e) (fun id -> not (Ident.is_primed id)))
| _ -> false in
let t' = IList.filter f !tbl in
let t' = List.filter ~f !tbl in
tbl := t';
t'
@ -571,7 +570,7 @@ end = struct
| Exp.Lvar _ | Exp.Var _
| Exp.BinOp (Binop.PlusA, Exp.Var _, _) ->
let is_same_e (e1, e2, _) = Exp.equal e (select side e1 e2) in
let assoc = IList.filter is_same_e !tbl in
let assoc = List.filter ~f:is_same_e !tbl in
IList.map (fun (e1, e2, _) -> select side_op e1 e2) assoc
| _ ->
L.d_str "no pattern match in check lost_little e: "; Sil.d_exp e; L.d_ln ();
@ -583,7 +582,7 @@ end = struct
let lookup_side' side e =
let f (e1, e2, _) = Exp.equal e (select side e1 e2) in
IList.filter f !tbl
List.filter ~f !tbl
let lookup_side_induced' side e =
let res = ref [] in
@ -624,7 +623,7 @@ end = struct
let to_subst_proj (side: side) vars =
let renaming_restricted =
IList.filter (function (_, _, Exp.Var i) -> Sil.fav_mem vars i | _ -> assert false) !tbl in
List.filter ~f:(function (_, _, Exp.Var i) -> Sil.fav_mem vars i | _ -> assert false) !tbl in
let sub_list_side =
IList.map
(function (e1, e2, Exp.Var i) -> (i, select side e1 e2) | _ -> assert false)
@ -644,7 +643,7 @@ end = struct
match select side e1 e2 with
| Exp.Var i -> can_rename i
| _ -> false in
IList.filter pick_id_case !tbl in
List.filter ~f:pick_id_case !tbl in
let sub_list =
let project (e1, e2, e) =
match select side e1 e2 with
@ -747,41 +746,35 @@ end = struct
(* Extend the renaming relation. At least one of e1 and e2
* should be a primed or footprint variable *)
let extend e1 e2 default_op =
try
let eq_to_e (f1, f2, _) = Exp.equal e1 f1 && Exp.equal e2 f2 in
let _, _, res = IList.find eq_to_e !tbl in
res
with Not_found ->
let fav1 = Sil.exp_fav e1 in
let fav2 = Sil.exp_fav e2 in
let no_ren1 = not (Sil.fav_exists fav1 can_rename) in
let no_ren2 = not (Sil.fav_exists fav2 can_rename) in
let some_primed () = Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in
let e =
if (no_ren1 && no_ren2) then
if (Exp.equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise IList.Fail)
else
match default_op with
| ExtDefault e -> e
| ExtFresh ->
let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in
Exp.Var (Ident.create_fresh kind) in
let entry = e1, e2, e in
push entry;
Todo.push entry;
e
(*
let get e1 e2 =
let f (e1', e2', _) = Exp.equal e1 e1' && Exp.equal e2 e2' in
match (IList.filter f !tbl) with
| [] -> None
| (_, _, e):: _ -> Some e
let pp pe f renaming =
let pp_triple f (e1, e2, e3) =
F.fprintf f "(%a,%a,%a)" (Sil.pp_exp pe) e3 (Sil.pp_exp pe) e1 (Sil.pp_exp pe) e2 in
(pp_seq pp_triple) f renaming
*)
match
List.find ~f:(fun (f1, f2, _) -> Exp.equal e1 f1 && Exp.equal e2 f2) !tbl |>
Option.map ~f:trd3
with
| Some res ->
res
| None ->
let fav1 = Sil.exp_fav e1 in
let fav2 = Sil.exp_fav e2 in
let no_ren1 = not (Sil.fav_exists fav1 can_rename) in
let no_ren2 = not (Sil.fav_exists fav2 can_rename) in
let some_primed () =
Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in
let e =
if (no_ren1 && no_ren2) then
if (Exp.equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise IList.Fail)
else
match default_op with
| ExtDefault e -> e
| ExtFresh ->
let kind =
if JoinState.get_footprint () && not (some_primed ())
then Ident.kfootprint
else Ident.kprimed in
Exp.Var (Ident.create_fresh kind) in
let entry = e1, e2, e in
push entry;
Todo.push entry;
e
end
(** {2 Functions for constructing fresh sil data types} *)
@ -1821,7 +1814,7 @@ let footprint_partial_join' tenv (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.
let pi_fp =
let pi_fp0 = Prop.get_pure efp in
let f a = Sil.fav_for_all (Sil.atom_fav a) Ident.is_footprint in
IList.filter f pi_fp0 in
List.filter ~f pi_fp0 in
let sigma_fp =
let sigma_fp0 = efp.Prop.sigma in
let f a = Sil.fav_exists (Sil.hpred_fav a) (fun a -> not (Ident.is_footprint a)) in

36
infer/src/backend/dotty.ml
Unescape View File

@ -289,7 +289,7 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list
| d:: candidates ->
if (is_allocated d) then subtract_allocated candidates
else d:: subtract_allocated candidates in
let candidate_dangling = IList.flatten (IList.map get_rhs_predicate sigma_lambda) in
let candidate_dangling = List.concat (IList.map get_rhs_predicate sigma_lambda) in
let candidate_dangling = filter_duplicate candidate_dangling [] in
let dangling = subtract_allocated candidate_dangling in
dangling_dotboxes:= dangling
@ -338,7 +338,7 @@ let set_exps_neq_zero pi =
IList.iter f pi
let box_dangling e =
let entry_e = IList.filter (fun b -> match b with
let entry_e = List.filter ~f:(fun b -> match b with
| Dotdangling(_, e', _) -> Exp.equal e e' | _ -> false ) !dangling_dotboxes in
match entry_e with
|[] -> None
@ -477,7 +477,7 @@ let compute_target_from_eexp dotnodes e p lambda =
[(LinkExpToExp, n', "")]
else
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
let nodes_e_no_struct = IList.filter is_not_struct nodes_e in
let nodes_e_no_struct = List.filter ~f:is_not_struct nodes_e in
let trg = IList.map get_coordinate_id nodes_e_no_struct in
(match trg with
| [] ->
@ -498,7 +498,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
let target_list = compute_target_array_elements dotnodes lie p f lambda in
(* below it's n+1 because n is the address, n+1 is the actual array node*)
let ff n = IList.map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate (n + 1) lambda) (strip_special_chars lab_src) (mk_coordinate m lambda) (strip_special_chars lab_trg)) target_list in
let links_from_elements = IList.flatten (IList.map ff (n:: nl)) in
let links_from_elements = List.concat (IList.map ff (n:: nl)) in
let trg_label = strip_special_chars (Exp.to_string e) in
let lnk = mk_link (LinkToArray) (mk_coordinate n lambda) "" (mk_coordinate (n + 1) lambda) trg_label in
@ -519,11 +519,11 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
) target_list in
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
let address_struct_id =
try get_coordinate_id (IList.hd (IList.filter (is_source_node_of_exp e) nodes_e))
try get_coordinate_id (List.hd_exn (List.filter ~f:(is_source_node_of_exp e) nodes_e))
with exn when SymOp.exn_not_failure exn -> assert false in
(* we need to exclude the address node from the sorce of fields. no fields should start from there*)
let nl'= IList.filter (fun id -> address_struct_id <> id) nl in
let links_from_fields = IList.flatten (IList.map ff nl') in
let nl'= List.filter ~f:(fun id -> address_struct_id <> id) nl in
let links_from_fields = List.concat (IList.map ff nl') in
let lnk_from_address_struct = if !print_full_prop then
let trg_label = strip_special_chars (Exp.to_string e) in
[mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) ""
@ -541,7 +541,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
mk_link k (mk_coordinate n lambda) ""
(mk_coordinate m lambda) (strip_special_chars lab_target)
) target_list in
let ll = IList.flatten (IList.map ff nl) in
let ll = List.concat (IList.map ff nl) in
ll @ dotty_mk_set_links dotnodes sigma' p f cycle
else dotty_mk_set_links dotnodes sigma' p f cycle)
@ -550,7 +550,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
(match src with
| [] -> assert false
| n:: _ ->
let (_, m, lab) = IList.hd (compute_target_from_eexp dotnodes e2 p lambda) in
let (_, m, lab) = List.hd_exn (compute_target_from_eexp dotnodes e2 p lambda) in
let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in
lnk:: dotty_mk_set_links dotnodes sigma' p f cycle
)
@ -635,11 +635,11 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
let tmp_nodes = ref nodes in
let tmp_links = ref links in
let remove_links_from ln =
IList.filter
(fun n' -> not (List.mem ~equal:equal_link ln n'))
List.filter
~f:(fun n' -> not (List.mem ~equal:equal_link ln n'))
!tmp_links in
let remove_node n ns =
IList.filter (fun n' -> match n' with
List.filter ~f:(fun n' -> match n' with
| Dotpointsto _ -> (get_coordinate_id n') <> (get_coordinate_id n)
| _ -> true
) ns in
@ -774,7 +774,7 @@ and dotty_pp_state f pe cycle dotnode =
| Dotpointsto(coo, e1, c) when !print_full_prop -> dotty_exp coo e1 c false
| Dotstruct(coo, e1, l, c,te) ->
let l' = if !print_full_prop then l
else IList.filter (fun edge -> in_cycle cycle edge) l in
else List.filter ~f:(fun edge -> in_cycle cycle edge) l in
print_struct f pe e1 te l' coo c
| Dotarray(coo, e1, e2, l, _, c) when !print_full_prop -> print_array f pe e1 e2 l coo c
| Dotlseg(coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop ->
@ -1119,7 +1119,7 @@ let atom_to_xml_string a =
(* return the dangling node corresponding to an expression it exists or None *)
let exp_dangling_node e =
let entry_e = IList.filter (fun b -> match b with
let entry_e = List.filter ~f:(fun b -> match b with
| VH_dangling(_, e') -> Exp.equal e e' | _ -> false ) !set_dangling_nodes in
match entry_e with
|[] -> None
@ -1202,10 +1202,10 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
| e:: l' ->
if (List.exists ~f:(Exp.equal e) seen_exp) then filter_duplicate l' seen_exp
else e:: filter_duplicate l' (e:: seen_exp) in
let rhs_exp_list = IList.flatten (IList.map get_rhs_predicate sigma) in
let rhs_exp_list = List.concat (IList.map get_rhs_predicate sigma) in
let candidate_dangling_exps = filter_duplicate rhs_exp_list [] in
(* get rid of allocated ones*)
let dangling_exps = IList.filter is_not_allocated candidate_dangling_exps in
let dangling_exps = List.filter ~f:is_not_allocated candidate_dangling_exps in
IList.map make_new_dangling dangling_exps
(* return a list of pairs (n,field_lab) where n is a target node*)
@ -1287,8 +1287,8 @@ let prop_to_set_of_visual_heaps prop =
incr global_node_counter;
while (!working_list <> []) do
set_dangling_nodes:=[];
let (n, h) = IList.hd !working_list in
working_list:= IList.tl !working_list;
let (n, h) = List.hd_exn !working_list in
working_list:= List.tl_exn !working_list;
let nodes = make_visual_heap_nodes h in
set_dangling_nodes:= make_set_dangling_nodes nodes h;
let edges = make_visual_heap_edges nodes h prop in

16
infer/src/backend/errdesc.ml
Unescape View File

@ -78,9 +78,9 @@ let find_in_node_or_preds start_node f_node_instr =
begin
visited := Procdesc.NodeSet.add node !visited;
let instrs = Procdesc.Node.get_instrs node in
match IList.find_map_opt (f_node_instr node) (IList.rev instrs) with
match List.find_map ~f:(f_node_instr node) (IList.rev instrs) with
| Some res -> Some res
| None -> IList.find_map_opt find (Procdesc.Node.get_preds node)
| None -> List.find_map ~f:find (Procdesc.Node.get_preds node)
end in
find start_node
@ -537,9 +537,9 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
Pvar.d pvar; L.d_ln ());
[pvar]
| _ -> [] in
let nullify_pvars = IList.flatten (IList.map get_nullify node_instrs) in
let nullify_pvars = List.concat (IList.map get_nullify node_instrs) in
let nullify_pvars_notmp =
IList.filter (fun pvar -> not (Pvar.is_frontend_tmp pvar)) nullify_pvars in
List.filter ~f:(fun pvar -> not (Pvar.is_frontend_tmp pvar)) nullify_pvars in
value_str_from_pvars_vpath nullify_pvars_notmp vpath
| Some (Sil.Store (lexp, _, _, _)) when is_none vpath ->
if verbose
@ -581,11 +581,9 @@ let vpath_find tenv prop _exp : DExp.t option * Typ.t option =
let typo = match texp with
| Exp.Sizeof (Tstruct name, _, _) -> (
match Tenv.lookup tenv name with
| Some {fields} -> (
match IList.find (fun (f', _, _) -> Ident.equal_fieldname f' f) fields with
| _, t, _ -> Some t
| exception Not_found -> None
)
| Some {fields} ->
List.find ~f:(fun (f', _, _) -> Ident.equal_fieldname f' f) fields |>
Option.map ~f:snd3
| _ ->
None
)

2
infer/src/backend/infer.ml
Unescape View File

@ -225,7 +225,7 @@ let capture = function
["--java-jar-compiler"; p]) @
(match IList.rev Config.buck_build_args with
| args when in_buck_mode ->
IList.map (fun arg -> ["--Xbuck"; "'" ^ arg ^ "'"]) args |> IList.flatten
IList.map (fun arg -> ["--Xbuck"; "'" ^ arg ^ "'"]) args |> List.concat
| _ -> []) @
(if not Config.debug_mode then [] else
["--debug"]) @

30
infer/src/backend/interproc.ml
Unescape View File

@ -394,8 +394,8 @@ let check_assignement_guard pdesc node =
let is_prune_exp e =
let prune_var n =
let ins = Procdesc.Node.get_instrs n in
let pi = IList.filter is_prune_instr ins in
let leti = IList.filter is_load_instr ins in
let pi = List.filter ~f:is_prune_instr ins in
let leti = List.filter ~f:is_load_instr ins in
match pi, leti with
| [Sil.Prune (Exp.Var (e1), _, _, _)], [Sil.Load (e2, e', _, _)]
| [Sil.Prune (Exp.UnOp (Unop.LNot, Exp.Var e1, _), _, _, _)],
@ -406,7 +406,7 @@ let check_assignement_guard pdesc node =
L.d_strln ("Found " ^ (Exp.to_string e') ^ " as prune var");
[e']
| _ -> [] in
let prune_vars = IList.flatten(IList.map (fun n -> prune_var n) succs) in
let prune_vars = List.concat(IList.map (fun n -> prune_var n) succs) in
IList.for_all (fun e' -> Exp.equal e' e) prune_vars in
let succs_loc = IList.map (fun n -> Procdesc.Node.get_loc n) succs in
let succs_are_all_prune_nodes () =
@ -441,10 +441,10 @@ let check_assignement_guard pdesc node =
(* at this point all successors are at the same location, so we can take the first*)
| loc_succ:: _ ->
let set_instr_at_succs_loc =
IList.filter
(fun i ->
Location.equal (Sil.instr_get_loc i) loc_succ &&
is_set_instr i)
List.filter
~f:(fun i ->
Location.equal (Sil.instr_get_loc i) loc_succ &&
is_set_instr i)
instr in
(match set_instr_at_succs_loc with
| [Sil.Store (e, _, _, _)] ->
@ -616,17 +616,17 @@ let forward_tabulate tenv pdesc wl source =
[reachable_hpreds]. *)
let get_fld_typ_path_opt src_exps sink_exp_ reachable_hpreds_ =
let strexp_matches target_exp = function
| (_, Sil.Eexp (e, _)) -> Exp.equal target_exp e
| Sil.Eexp (e, _) -> Exp.equal target_exp e
| _ -> false in
let extend_path hpred (sink_exp, path, reachable_hpreds) = match hpred with
| Sil.Hpointsto (lhs, Sil.Estruct (flds, _), Exp.Sizeof (typ, _, _)) ->
(try
let fld, _ = IList.find (fun fld -> strexp_matches sink_exp fld) flds in
let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in
(lhs, (Some fld, typ) :: path, reachable_hpreds')
with Not_found -> (sink_exp, path, reachable_hpreds))
List.find ~f:(function _, se -> strexp_matches sink_exp se) flds |>
Option.value_map ~f:(function fld, _ ->
let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in
(lhs, (Some fld, typ) :: path, reachable_hpreds'))
~default:(sink_exp, path, reachable_hpreds)
| Sil.Hpointsto (lhs, Sil.Earray (_, elems, _), Exp.Sizeof (typ, _, _)) ->
if List.exists ~f:(fun pair -> strexp_matches sink_exp pair) elems
if List.exists ~f:(function _, se -> strexp_matches sink_exp se) elems
then
let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in
(* None means "no field name" ~=~ nameless array index *)
@ -1405,7 +1405,7 @@ let interprocedural_algorithm exe_env : unit =
let summary = Specs.get_summary_unsafe "main_algorithm" proc_name in
Int.equal (Specs.get_timestamp summary) 0 in
let procs_to_analyze =
IList.filter filter_initial (Cg.get_defined_nodes call_graph) in
List.filter ~f:filter_initial (Cg.get_defined_nodes call_graph) in
let to_analyze proc_name =
match Exe_env.get_proc_desc exe_env proc_name with
| Some proc_desc ->

28
infer/src/backend/match.ml
Unescape View File

@ -41,7 +41,7 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
in if (Exp.equal e1 e2_inst) then Some(sub, vars) else None in
match e1, e2 with
| _, Exp.Var id2 when (Ident.is_primed id2 && mem_idlist id2 vars) ->
let vars_new = IList.filter (fun id -> not (Ident.equal id id2)) vars in
let vars_new = List.filter ~f:(fun id -> not (Ident.equal id id2)) vars in
let sub_new = match (Sil.extend_sub sub id2 e1) with
| None -> assert false (* happens when vars contains the same variable twice. *)
| Some sub_new -> sub_new
@ -545,7 +545,7 @@ and generate_todos_from_iel mode todos iel1 iel2 =
let corres_extend_front e1 e2 corres =
let filter (e1', e2') = (Exp.equal e1 e1') || (Exp.equal e2 e2') in
let checker e1' e2' = (Exp.equal e1 e1') && (Exp.equal e2 e2')
in match (IList.filter filter corres) with
in match (List.filter ~f:filter corres) with
| [] -> Some ((e1, e2) :: corres)
| [(e1', e2')] when checker e1' e2' -> Some corres
| _ -> None
@ -557,7 +557,7 @@ let corres_extensible corres e1 e2 =
let corres_related corres e1 e2 =
let filter (e1', e2') = (Exp.equal e1 e1') || (Exp.equal e2 e2') in
let checker e1' e2' = (Exp.equal e1 e1') && (Exp.equal e2 e2') in
match (IList.filter filter corres) with
match (List.filter ~f:filter corres) with
| [] -> Exp.equal e1 e2
| [(e1', e2')] when checker e1' e2' -> true
| _ -> false
@ -714,12 +714,12 @@ let generic_para_create tenv corres sigma1 elist1 =
let not_same_consts = function
| Exp.Const c1, Exp.Const c2 -> not (Const.equal c1 c2)
| _ -> true in
let new_corres' = IList.filter not_same_consts corres in
let new_corres' = List.filter ~f:not_same_consts corres in
let add_fresh_id pair = (pair, Ident.create_fresh Ident.kprimed) in
IList.map add_fresh_id new_corres' in
let (es_shared, ids_shared, ids_exists) =
let not_in_elist1 ((e1, _), _) = not (List.exists ~f:(Exp.equal e1) elist1) in
let corres_ids_no_elist1 = IList.filter not_in_elist1 corres_ids in
let corres_ids_no_elist1 = List.filter ~f:not_in_elist1 corres_ids in
let should_be_shared ((e1, e2), _) = Exp.equal e1 e2 in
let shared, exists = IList.partition should_be_shared corres_ids_no_elist1 in
let es_shared = IList.map (fun ((e1, _), _) -> e1) shared in
@ -739,11 +739,10 @@ let hpara_create tenv corres sigma1 root1 next1 =
let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create tenv corres sigma1 [root1; next1] in
let get_id1 e1 =
try
let is_equal_to_e1 (e1', _) = Exp.equal e1 e1' in
let _, id = IList.find is_equal_to_e1 renaming in
id
with Not_found -> assert false in
let is_equal_to_e1 (e1', _) = Exp.equal e1 e1' in
match List.find ~f:is_equal_to_e1 renaming with
| Some (_, id) -> id
| None -> assert false in
let id_root = get_id1 root1 in
let id_next = get_id1 next1 in
let hpara =
@ -762,11 +761,10 @@ let hpara_dll_create tenv corres sigma1 root1 blink1 flink1 =
let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create tenv corres sigma1 [root1; blink1; flink1] in
let get_id1 e1 =
try
let is_equal_to_e1 (e1', _) = Exp.equal e1 e1' in
let _, id = IList.find is_equal_to_e1 renaming in
id
with Not_found -> assert false in
let is_equal_to_e1 (e1', _) = Exp.equal e1 e1' in
match List.find ~f:is_equal_to_e1 renaming with
| Some (_, id) -> id
| None -> assert false in
let id_root = get_id1 root1 in
let id_blink = get_id1 blink1 in
let id_flink = get_id1 flink1 in

2
infer/src/backend/paths.ml
Unescape View File

@ -593,7 +593,7 @@ end = struct
let filter f ps =
let elements = ref [] in
PropMap.iter (fun p _ -> elements := p :: !elements) ps;
elements := IList.filter (fun p -> not (f p)) !elements;
elements := List.filter ~f:(fun p -> not (f p)) !elements;
let filtered_map = ref ps in
IList.iter (fun p -> filtered_map := PropMap.remove p !filtered_map) !elements;
!filtered_map

2
infer/src/backend/preanal.ml
Unescape View File

@ -212,7 +212,7 @@ let add_nullify_instrs pdesc tenv liveness_inv_map =
let node_add_nullify_instructions node pvars =
let loc = Procdesc.Node.get_last_loc node in
let nullify_instrs =
IList.filter is_local pvars
List.filter ~f:is_local pvars
|> IList.map (fun pvar -> Sil.Nullify (pvar, loc)) in
if nullify_instrs <> []
then Procdesc.Node.append_instrs node (IList.rev nullify_instrs) in

2
infer/src/backend/printer.ml
Unescape View File

@ -419,7 +419,7 @@ let write_proc_html source whole_seconds pdesc =
begin
let pname = Procdesc.get_proc_name pdesc in
let nodes = IList.sort Procdesc.Node.compare (Procdesc.get_nodes pdesc) in
let linenum = (Procdesc.Node.get_loc (IList.hd nodes)).Location.line in
let linenum = (Procdesc.Node.get_loc (List.hd_exn nodes)).Location.line in
let fd, fmt =
Io_infer.Html.create
(DB.Results_dir.Abs_source_dir source)

50
infer/src/backend/prop.ml
Unescape View File

@ -271,9 +271,9 @@ let create_pvar_env (sigma: sigma) : (Exp.t -> Exp.t) =
| _ -> () in
IList.iter filter sigma;
let find e =
try
snd (IList.find (fun (e1, _) -> Exp.equal e1 e) !env)
with Not_found -> e in
List.find ~f:(fun (e1, _) -> Exp.equal e1 e) !env |>
Option.map ~f:snd |>
Option.value ~default:e in
find
(** Update the object substitution given the stack variables in the prop *)
@ -412,10 +412,10 @@ let sigma_fav_in_pvars_add fav sigma =
IList.iter (hpred_fav_in_pvars_add fav) sigma
let sigma_fpv sigma =
IList.flatten (IList.map Sil.hpred_fpv sigma)
List.concat (IList.map Sil.hpred_fpv sigma)
let pi_fpv pi =
IList.flatten (IList.map Sil.atom_fpv pi)
List.concat (IList.map Sil.atom_fpv pi)
let prop_fpv prop =
(Sil.sub_fpv prop.sub) @
@ -1465,17 +1465,17 @@ module Normalize = struct
lt_list_tightened in
le_ineq_list @ lt_ineq_list in
let nonineq_list' =
IList.filter
(fun (a : Sil.atom) -> match a with
| Aneq (Const (Cint n), e)
| Aneq (e, Const (Cint n)) ->
(not (List.exists
~f:(fun (e', n') -> Exp.equal e e' && IntLit.lt n' n)
le_list_tightened)) &&
(not (List.exists
~f:(fun (n', e') -> Exp.equal e e' && IntLit.leq n n')
lt_list_tightened))
| _ -> true)
List.filter
~f:(fun (a : Sil.atom) -> match a with
| Aneq (Const (Cint n), e)
| Aneq (e, Const (Cint n)) ->
(not (List.exists
~f:(fun (e', n') -> Exp.equal e e' && IntLit.lt n' n)
le_list_tightened)) &&
(not (List.exists
~f:(fun (n', e') -> Exp.equal e e' && IntLit.leq n n')
lt_list_tightened))
| _ -> true)
nonineq_list in
(ineq_list', nonineq_list')
@ -1512,7 +1512,7 @@ module Normalize = struct
let pi' =
IList.stable_sort
Sil.compare_atom
((IList.filter filter_useful_atom nonineq_list) @ ineq_list) in
((List.filter ~f:filter_useful_atom nonineq_list) @ ineq_list) in
let pi'' = pi_sorted_remove_redundant pi' in
if equal_pi pi0 pi'' then pi0 else pi''
@ -1550,7 +1550,7 @@ module Normalize = struct
(** This function assumes that if (x,Exp.Var(y)) in sub, then compare x y = 1 *)
let sub_normalize sub =
let f (id, e) = (not (Ident.is_primed id)) && (not (Sil.ident_in_exp id e)) in
let sub' = Sil.sub_filter_pair f sub in
let sub' = Sil.sub_filter_pair ~f sub in
if Sil.equal_subst sub sub' then sub else sub'
(** Conjoin a pure atomic predicate by normal conjunction. *)
@ -1924,9 +1924,9 @@ let prop_rename_array_indices tenv prop =
let rec select_minimal_indices indices_seen = function
| [] -> IList.rev indices_seen
| index:: indices_rest ->
let indices_seen' = IList.filter (not_same_base_lt_offsets index) indices_seen in
let indices_seen' = List.filter ~f:(not_same_base_lt_offsets index) indices_seen in
let indices_seen_new = index:: indices_seen' in
let indices_rest_new = IList.filter (not_same_base_lt_offsets index) indices_rest in
let indices_rest_new = List.filter ~f:(not_same_base_lt_offsets index) indices_rest in
select_minimal_indices indices_seen_new indices_rest_new in
let minimal_indices = select_minimal_indices [] indices in
let subst = compute_reindexing_from_indices minimal_indices in
@ -1936,7 +1936,7 @@ let prop_rename_array_indices tenv prop =
let compute_renaming fav =
let ids = Sil.fav_to_list fav in
let ids_primed, ids_nonprimed = IList.partition Ident.is_primed ids in
let ids_footprint = IList.filter Ident.is_footprint ids_nonprimed in
let ids_footprint = List.filter ~f:Ident.is_footprint ids_nonprimed in
let id_base_primed = Ident.create Ident.kprimed 0 in
let id_base_footprint = Ident.create Ident.kfootprint 0 in
@ -2190,7 +2190,7 @@ let remove_seed_captured_vars_block tenv captured_vars prop =
| _ -> false in
let sigma = prop.sigma in
let sigma' =
IList.filter (fun hpred -> not (hpred_seed_captured hpred)) sigma in
List.filter ~f:(fun hpred -> not (hpred_seed_captured hpred)) sigma in
Normalize.normalize tenv (set prop ~sigma:sigma')
(** {2 Prop iterators} *)
@ -2425,7 +2425,7 @@ let rec strexp_gc_fields (fav: Sil.fav) (se : Sil.strexp) =
| Estruct (fsel, inst) ->
let fselo = IList.map (fun (f, se) -> (f, strexp_gc_fields fav se)) fsel in
let fsel' =
let fselo' = IList.filter (function | (_, Some _) -> true | _ -> false) fselo in
let fselo' = List.filter ~f:(function | (_, Some _) -> true | _ -> false) fselo in
IList.map (function (f, seo) -> (f, unSome seo)) fselo' in
if [%compare.equal: (Ident.fieldname * Sil.strexp) list] fsel fsel' then Some se
else Some (Sil.Estruct (fsel', inst))
@ -2567,8 +2567,8 @@ module CategorizePreconditions = struct
let check_sigma sigma =
IList.for_all hpred_filter sigma in
check_pi pre.pi && check_sigma pre.sigma in
let pres_no_constraints = IList.filter (check_pre hpred_is_var) preconditions in
let pres_only_allocation = IList.filter (check_pre hpred_only_allocation) preconditions in
let pres_no_constraints = List.filter ~f:(check_pre hpred_is_var) preconditions in
let pres_only_allocation = List.filter ~f:(check_pre hpred_only_allocation) preconditions in
match preconditions, pres_no_constraints, pres_only_allocation with
| [], _, _ ->
NoPres

7
infer/src/backend/propgraph.ml
Unescape View File

@ -79,7 +79,7 @@ let edge_from_source g n footprint_part is_hpred =
match edge_get_source hpred with
| Some e -> Exp.equal n e
| None -> false in
match IList.filter starts_from edges with
match List.filter ~f:starts_from edges with
| [] -> None
| edge:: _ -> Some edge
@ -106,8 +106,7 @@ let edge_equal e1 e2 = match e1, e2 with
(** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e],
searching the footprint part if [footprint_part] is true. *)
let contains_edge (footprint_part: bool) (g: t) (e: edge) =
try ignore (IList.find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true
with Not_found -> false
List.exists ~f:(fun e' -> edge_equal e e') (get_edges footprint_part g)
(** [iter_edges footprint_part f g] iterates function [f] on the edges in [g] in the same order as returned by [get_edges];
if [footprint_part] is true the edges are taken from the footprint part. *)
@ -166,7 +165,7 @@ let compute_edge_diff (oldedge: edge) (newedge: edge) : Obj.t list = match olded
compute_exp_diff e1 e2
| Eatom (Sil.Apred (_, es1)), Eatom (Sil.Apred (_, es2))
| Eatom (Sil.Anpred (_, es1)), Eatom (Sil.Anpred (_, es2)) ->
IList.flatten (try IList.map2 compute_exp_diff es1 es2 with IList.Fail -> [])
List.concat (try IList.map2 compute_exp_diff es1 es2 with IList.Fail -> [])
| Esub_entry (_, e1), Esub_entry (_, e2) ->
compute_exp_diff e1 e2
| _ -> [Obj.repr newedge]

2
infer/src/backend/propset.ml
Unescape View File

@ -72,7 +72,7 @@ let to_proplist pset =
(** Apply function to all the elements of [propset], removing those where it returns [None]. *)
let map_option tenv f pset =
let plisto = IList.map f (to_proplist pset) in
let plisto = IList.filter (function | Some _ -> true | None -> false) plisto in
let plisto = List.filter ~f:(function | Some _ -> true | None -> false) plisto in
let plist = IList.map (function Some p -> p | None -> assert false) plisto in
from_proplist tenv plist

12
infer/src/backend/prover.ml
Unescape View File

@ -20,10 +20,10 @@ let decrease_indent_when_exception thunk =
with exn when SymOp.exn_not_failure exn -> (L.d_decrease_indent 1; raise exn)
let compute_max_from_nonempty_int_list l =
IList.hd (IList.rev (IList.sort IntLit.compare_value l))
uw (List.max_elt ~cmp:IntLit.compare_value l)
let compute_min_from_nonempty_int_list l =
IList.hd (IList.sort IntLit.compare_value l)
uw (List.min_elt ~cmp:IntLit.compare_value l)
let rec list_rev_acc acc = function
| [] -> acc
@ -129,7 +129,7 @@ end = struct
let remove_redundancy constraints =
let constraints' = sort_then_remove_redundancy constraints in
IList.filter (fun entry -> List.exists ~f:(equal entry) constraints') constraints
List.filter ~f:(fun entry -> List.exists ~f:(equal entry) constraints') constraints
let rec combine acc_todos acc_seen constraints_new constraints_old =
match constraints_new, constraints_old with
@ -477,7 +477,7 @@ end = struct
| Exp.Const (Const.Cint n1) -> Some n1
| _ ->
let e_upper_list =
IList.filter (function
List.filter ~f:(function
| e', Exp.Const (Const.Cint _) -> Exp.equal e1 e'
| _, _ -> false) leqs in
let upper_list =
@ -494,7 +494,7 @@ end = struct
| Exp.Sizeof _ -> Some IntLit.zero
| _ ->
let e_lower_list =
IList.filter (function
List.filter ~f:(function
| Exp.Const (Const.Cint _), e' -> Exp.equal e1 e'
| _, _ -> false) lts in
let lower_list =
@ -2143,7 +2143,7 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2
let filter (id, e) =
Ident.is_normal id && Sil.fav_for_all (Sil.exp_fav e) Ident.is_normal in
let sub1_base =
Sil.sub_filter_pair filter prop1.Prop.sub in
Sil.sub_filter_pair ~f:filter prop1.Prop.sub in
let pi1, pi2 = Prop.get_pure prop1, Prop.get_pure prop2 in
let sigma1, sigma2 = prop1.Prop.sigma, prop2.Prop.sigma in
let subs = pre_check_pure_implication tenv calc_missing (prop1.Prop.sub, sub1_base) pi1 pi2 in

138
infer/src/backend/rearrange.ml
Unescape View File

@ -105,8 +105,10 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
| Tstruct name, (Off_fld (f, _)) :: off' -> (
match Tenv.lookup tenv name with
| Some ({ fields; statics; } as struct_typ) -> (
match IList.find (fun (f', _, _) -> Ident.equal_fieldname f f') (fields @ statics) with
| _, t', _ ->
match List.find
~f:(fun (f', _, _) -> Ident.equal_fieldname f f')
(fields @ statics) with
| Some (_, t', _) ->
let atoms', se', res_t' =
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp t' off' inst in
@ -117,7 +119,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
IList.sort StructTyp.compare_field (IList.map replace_typ_of_f fields) in
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ;
(atoms', se, t)
| exception Not_found ->
| None ->
fail t off __POS__
)
| None ->
@ -206,10 +208,10 @@ let rec _strexp_extend_values
| (Off_fld (f, _)) :: off', Sil.Estruct (fsel, inst'), Tstruct name -> (
match Tenv.lookup tenv name with
| Some ({ fields; statics; } as struct_typ) -> (
match IList.find (fun (f', _, _) -> Ident.equal_fieldname f f') (fields @ statics) with
| _, typ', _ -> (
match IList.find (fun (f', _) -> Ident.equal_fieldname f f') fsel with
| _, se' ->
match List.find ~f:(fun (f', _, _) -> Ident.equal_fieldname f f') (fields @ statics) with
| Some (_, typ', _) -> (
match List.find ~f:(fun (f', _) -> Ident.equal_fieldname f f') fsel with
| Some (_, se') ->
let atoms_se_typ_list' =
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se' typ' off' inst in
@ -217,7 +219,9 @@ let rec _strexp_extend_values
let replace_fse ((f1, _) as ft1) =
if Ident.equal_fieldname f1 f then (f1, res_se') else ft1 in
let res_fsel' =
IList.sort [%compare: Ident.fieldname * Sil.strexp] (IList.map replace_fse fsel) in
IList.sort
[%compare: Ident.fieldname * Sil.strexp]
(IList.map replace_fse fsel) in
let replace_fta ((f1, _, a1) as fta1) =
if Ident.equal_fieldname f f1 then (f1, res_typ', a1) else fta1 in
let fields' =
@ -225,11 +229,12 @@ let rec _strexp_extend_values
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ;
(res_atoms', Sil.Estruct (res_fsel', inst'), typ) :: acc in
IList.fold_left replace [] atoms_se_typ_list'
| exception Not_found ->
| None ->
let atoms', se', res_typ' =
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in
let res_fsel' = IList.sort [%compare: Ident.fieldname * Sil.strexp] ((f, se'):: fsel) in
let res_fsel' =
IList.sort [%compare: Ident.fieldname * Sil.strexp] ((f, se'):: fsel) in
let replace_fta (f', t', a') =
if Ident.equal_fieldname f' f then (f, res_typ', a') else (f', t', a') in
let fields' =
@ -237,7 +242,7 @@ let rec _strexp_extend_values
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ;
[(atoms', Sil.Estruct (res_fsel', inst'), typ)]
)
| exception Not_found ->
| None ->
raise (Exceptions.Missing_fld (f, __POS__))
)
| None ->
@ -260,8 +265,8 @@ let rec _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst
| (Off_index e) :: off', Sil.Earray (len, esel, inst_arr), Tarray (typ', len_for_typ') -> (
bounds_check tenv pname orig_prop len e (State.get_loc ());
match IList.find (fun (e', _) -> Exp.equal e e') esel with
| _, se' ->
match List.find ~f:(fun (e', _) -> Exp.equal e e') esel with
| Some (_, se') ->
let atoms_se_typ_list' =
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se' typ' off' inst in
@ -276,7 +281,7 @@ let rec _strexp_extend_values
else
raise (Exceptions.Bad_footprint __POS__) in
IList.fold_left replace [] atoms_se_typ_list'
| exception Not_found ->
| None ->
array_case_analysis_index pname tenv orig_prop
footprint_part kind max_stamp
len esel
@ -330,7 +335,7 @@ and array_case_analysis_index pname tenv orig_prop
[(atoms, array_new, typ_new)]
end in
let rec handle_case acc isel_seen_rev = function
| [] -> IList.flatten (IList.rev (res_new:: acc))
| [] -> List.concat (IList.rev (res_new:: acc))
| (i, se) as ise :: isel_unseen ->
let atoms_se_typ_list =
_strexp_extend_values
@ -397,7 +402,7 @@ let strexp_extend_values
let atoms_se_typ_list_filtered =
let check_neg_atom atom = Prover.check_atom tenv Prop.prop_emp (Prover.atom_negate tenv atom) in
let check_not_inconsistent (atoms, _, _) = not (List.exists ~f:check_neg_atom atoms) in
IList.filter check_not_inconsistent atoms_se_typ_list in
List.filter ~f:check_not_inconsistent atoms_se_typ_list in
if Config.trace_rearrange then L.d_strln "exiting strexp_extend_values";
let len, st = match te with
| Exp.Sizeof(_, len, st) -> (len, st)
@ -468,10 +473,10 @@ let prop_iter_check_fields_ptsto_shallow tenv iter lexp =
| (Sil.Off_fld (fld, _)):: off' ->
(match se with
| Sil.Estruct (fsel, _) ->
(try
let _, se' = IList.find (fun (fld', _) -> Ident.equal_fieldname fld fld') fsel in
check_offset se' off'
with Not_found -> Some fld)
(match List.find ~f:(fun (fld', _) -> Ident.equal_fieldname fld fld') fsel with
| Some (_, se') ->
check_offset se' off'
| None -> Some fld)
| _ -> Some fld)
| (Sil.Off_index _):: _ -> None in
check_offset se offset
@ -669,7 +674,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
None
else
None in
IList.find_map_opt annot_extract_guarded_by_str item_annot in
List.find_map ~f:annot_extract_guarded_by_str item_annot in
let extract_suppress_warnings_str item_annot =
let annot_suppress_warnings_str ((annot: Annot.t), _) =
if Annotations.annot_ends_with annot Annotations.suppress_lint
@ -681,7 +686,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
None
else
None in
IList.find_map_opt annot_suppress_warnings_str item_annot in
List.find_map ~f:annot_suppress_warnings_str item_annot in
(* if [fld] is annotated with @GuardedBy("mLock"), return mLock *)
let get_guarded_by_fld_str fld typ =
match StructTyp.get_field_type_and_annotation ~lookup fld typ with
@ -709,7 +714,7 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
match StructTyp.get_field_type_and_annotation ~lookup fld typ with
| Some (fld_typ, _) when f fld fld_typ -> Some (strexp, fld_typ)
| _ -> None in
IList.find_map_opt match_one flds in
List.find_map ~f:match_one flds in
(* sometimes, programmers will write @GuardedBy("T.f") with the meaning "guarded by the field f
of the object of type T in the current state." note that this is ambiguous when there are
@ -725,13 +730,14 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
begin
match get_fld_strexp_and_typ typ typ_matches_guarded_by flds with
| Some (Sil.Eexp (matching_exp, _), _) ->
IList.find_map_opt
(function
| Sil.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof (fld_typ, _, _))
when Exp.equal lhs_exp matching_exp ->
get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds
| _ ->
None)
List.find_map
~f:(function
| Sil.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof (fld_typ, _, _))
when Exp.equal lhs_exp matching_exp ->
get_fld_strexp_and_typ
fld_typ (is_guarded_by_fld field_part) matching_flds
| _ ->
None)
sigma
| _ ->
None
@ -739,37 +745,37 @@ let add_guarded_by_constraints tenv prop lexp pdesc =
| _ ->
None in
IList.find_map_opt
(function
| Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof (typ, _, _))
| Sil.Hpointsto (_, Sil.Eexp (Const (Cclass clazz) as lhs_exp, _), Exp.Sizeof (typ, _, _))
when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) ->
Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ)
| Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof (typ, _, _)) ->
begin
(* first, try to find a field that exactly matches the guarded-by string *)
match get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with
| None when guarded_by_str_is_this guarded_by_str0 ->
(* if the guarded-by string is "OuterClass.this", look for "this$n" for some n.
note that this is a bit sketchy when there are mutliple this$n's, but there's
nothing we can do to disambiguate them. *)
get_fld_strexp_and_typ
typ
(fun f _ -> Ident.java_fieldname_is_outer_instance f)
flds
| None ->
(* can't find an exact match. try a different convention. *)
match_on_field_type typ flds
| Some _ as res_opt ->
res_opt
end
| Sil.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof (typ, _, _))
when (guarded_by_str_is_current_class_this guarded_by_str0 pname ||
guarded_by_str_is_super_class_this guarded_by_str0 pname
) && Pvar.is_this pvar ->
Some (rhs_exp, typ)
| _ ->
None)
List.find_map
~f:(function
| Sil.Hpointsto ((Const (Cclass clazz) as lhs_exp), _, Exp.Sizeof (typ, _, _))
| Sil.Hpointsto (_, Sil.Eexp (Const (Cclass clazz) as lhs_exp, _), Exp.Sizeof (typ, _, _))
when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) ->
Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ)
| Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof (typ, _, _)) ->
begin
(* first, try to find a field that exactly matches the guarded-by string *)
match get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with
| None when guarded_by_str_is_this guarded_by_str0 ->
(* if the guarded-by string is "OuterClass.this", look for "this$n" for some n.
note that this is a bit sketchy when there are mutliple this$n's, but there's
nothing we can do to disambiguate them. *)
get_fld_strexp_and_typ
typ
(fun f _ -> Ident.java_fieldname_is_outer_instance f)
flds
| None ->
(* can't find an exact match. try a different convention. *)
match_on_field_type typ flds
| Some _ as res_opt ->
res_opt
end
| Sil.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof (typ, _, _))
when (guarded_by_str_is_current_class_this guarded_by_str0 pname ||
guarded_by_str_is_super_class_this guarded_by_str0 pname
) && Pvar.is_this pvar ->
Some (rhs_exp, typ)
| _ ->
None)
sigma in
(* warn if the access to [lexp] is not protected by the [guarded_by_fld_str] lock *)
let enforce_guarded_access_ accessed_fld guarded_by_str prop =
@ -981,7 +987,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
let filter it =
let p = Prop.prop_iter_to_prop tenv it in
not (Prover.check_inconsistency tenv p) in
IList.filter filter (IList.map handle_case atoms_se_te_list)
List.filter ~f:filter (IList.map handle_case atoms_se_te_list)
| _ -> [iter]
end in
begin
@ -1109,9 +1115,9 @@ let type_at_offset tenv texp off =
| (Off_fld (f, _)) :: off', Tstruct name -> (
match Tenv.lookup tenv name with
| Some { fields } -> (
match IList.find (fun (f', _, _) -> Ident.equal_fieldname f f') fields with
| _, typ', _ -> strip_offset off' typ'
| exception Not_found -> None
match List.find ~f:(fun (f', _, _) -> Ident.equal_fieldname f f') fields with
| Some (_, typ', _) -> strip_offset off' typ'
| None -> None
)
| None ->
None
@ -1209,7 +1215,7 @@ let rec iter_rearrange
else
iter_rearrange pname tenv (Prop.lexp_normalize_prop tenv prop' lexp) typ prop' iter' inst in
let rec f_many_iters iters_lst = function
| [] -> IList.flatten (IList.rev iters_lst)
| [] -> List.concat (IList.rev iters_lst)
| iter':: iters' ->
let iters_res' = f_one_iter iter' in
f_many_iters (iters_res':: iters_lst) iters' in

2
infer/src/backend/state.ml
Unescape View File

@ -215,7 +215,7 @@ let mk_find_duplicate_nodes proc_desc : (Procdesc.Node.t -> Procdesc.NodeSet.t)
let duplicates =
let equal_normalized_instrs (_, normalized_instrs') =
List.equal ~equal:Sil.equal_instr node_normalized_instrs normalized_instrs' in
IList.filter equal_normalized_instrs elements in
List.filter ~f:equal_normalized_instrs elements in
IList.fold_left
(fun nset (node', _) -> Procdesc.NodeSet.add node' nset)
Procdesc.NodeSet.empty duplicates

81
infer/src/backend/symExec.ml
Unescape View File

@ -46,7 +46,7 @@ let unroll_type tenv (typ: Typ.t) (off: Sil.offset) =
(** Given a node, returns a list of pvar of blocks that have been nullified in the block. *)
let get_blocks_nullified node =
let null_blocks = IList.flatten(IList.map (fun i -> match i with
let null_blocks = List.concat (IList.map (fun i -> match i with
| Sil.Nullify(pvar, _) when Sil.is_block_pvar pvar -> [pvar]
| _ -> []) (Procdesc.Node.get_instrs node)) in
null_blocks
@ -142,8 +142,8 @@ let rec apply_offlist
match Tenv.lookup tenv name with
| Some ({fields} as struct_typ) -> (
let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in
match IList.find (fun fse -> Ident.equal_fieldname fld (fst fse)) fsel with
| _, se' ->
match List.find ~f:(fun fse -> Ident.equal_fieldname fld (fst fse)) fsel with
| Some (_, se') ->
let res_e', res_se', res_t', res_pred_insts_op' =
apply_offlist
pdesc tenv p fp_root nullify_struct
@ -156,7 +156,7 @@ let rec apply_offlist
let fields' = IList.map replace_fta fields in
ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ;
(res_e', res_se, typ, res_pred_insts_op')
| exception Not_found ->
| None ->
(* This case should not happen. The rearrangement should
have materialized all the accessed cells. *)
pp_error();
@ -172,26 +172,25 @@ let rec apply_offlist
| (Sil.Off_index idx) :: offlist', Sil.Earray (len, esel, inst1), Typ.Tarray (t', len') -> (
let nidx = Prop.exp_normalize_prop tenv p idx in
try
let idx_ese', se' = IList.find (fun ese -> Prover.check_equal tenv p nidx (fst ese)) esel in
let res_e', res_se', res_t', res_pred_insts_op' =
apply_offlist
pdesc tenv p fp_root nullify_struct
(root_lexp, se', t') offlist' f inst lookup_inst in
let replace_ese ese =
if Exp.equal idx_ese' (fst ese)
then (idx_ese', res_se')
else ese in
let res_se = Sil.Earray (len, IList.map replace_ese esel, inst1) in
let res_t = Typ.Tarray (res_t', len') in
(res_e', res_se, res_t, res_pred_insts_op')
with Not_found ->
(* return a nondeterministic value if the index is not found after rearrangement *)
L.d_str "apply_offlist: index "; Sil.d_exp idx;
L.d_strln " not materialized -- returning nondeterministic value";
let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in
(res_e', strexp, typ, None)
)
match List.find ~f:(fun ese -> Prover.check_equal tenv p nidx (fst ese)) esel with
| Some (idx_ese', se') ->
let res_e', res_se', res_t', res_pred_insts_op' =
apply_offlist
pdesc tenv p fp_root nullify_struct
(root_lexp, se', t') offlist' f inst lookup_inst in
let replace_ese ese =
if Exp.equal idx_ese' (fst ese)
then (idx_ese', res_se')
else ese in
let res_se = Sil.Earray (len, IList.map replace_ese esel, inst1) in
let res_t = Typ.Tarray (res_t', len') in
(res_e', res_se, res_t, res_pred_insts_op')
| None ->
(* return a nondeterministic value if the index is not found after rearrangement *)
L.d_str "apply_offlist: index "; Sil.d_exp idx;
L.d_strln " not materialized -- returning nondeterministic value";
let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in
(res_e', strexp, typ, None))
| (Sil.Off_index _) :: _, _, _ ->
(* This case should not happen. The rearrangement should
have materialized all the accessed cells. *)
@ -423,10 +422,9 @@ let check_arith_norm_exp tenv pname exp prop =
(** Check if [cond] is testing for NULL a pointer already dereferenced *)
let check_already_dereferenced tenv pname cond prop =
let find_hpred lhs =
try Some (IList.find (function
List.find ~f:(function
| Sil.Hpointsto (e, _, _) -> Exp.equal e lhs
| _ -> false) prop.Prop.sigma)
with Not_found -> None in
| _ -> false) prop.Prop.sigma in
let rec is_check_zero = function
| Exp.Var id ->
Some id
@ -568,7 +566,7 @@ let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Procname.t
let target_receiver_typ = get_receiver_typ target_pname actual_receiver_typ in
Prover.Subtyping_check.check_subtype tenv target_receiver_typ actual_receiver_typ in
let resolved_pname = do_resolve callee_pname receiver_exp actual_receiver_typ in
let feasible_targets = IList.filter may_dispatch_to targets in
let feasible_targets = List.filter ~f:may_dispatch_to targets in
(* make sure [resolved_pname] is not a duplicate *)
if List.mem ~equal:Procname.equal feasible_targets resolved_pname
then feasible_targets
@ -748,7 +746,7 @@ let handle_objc_instance_method_call_or_skip tenv actual_pars path callee_pname
let propset = prune_ne tenv ~positive:false receiver Exp.zero pre_with_attr_or_null in
if Propset.is_empty propset then []
else
let prop = IList.hd (Propset.to_proplist propset) in
let prop = List.hd_exn (Propset.to_proplist propset) in
let path = Paths.Path.add_description path path_description in
[(prop, path)] in
res_null @ (res ())
@ -1161,7 +1159,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
else
proc_call (Option.value_exn resolved_summary_opt)
(call_args prop resolved_pname n_actual_params ret_id loc) in
IList.flatten (IList.map do_call sentinel_result)
List.concat (IList.map do_call sentinel_result)
)
)
| Sil.Call (ret_id, fun_exp, actual_params, loc, call_flags) -> (* Call via function pointer *)
@ -1244,7 +1242,7 @@ and instrs ?(mask_errors=false) tenv pdesc instrs ppl =
("Generated Instruction Failed with: " ^
(Localise.to_string err_name)^loc ); L.d_ln();
[(p, path)] in
let f plist instr = IList.flatten (IList.map (exe_instr instr) plist) in
let f plist instr = List.concat (IList.map (exe_instr instr) plist) in
IList.fold_left f ppl instrs
and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname callee_loc =
@ -1301,11 +1299,11 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
(* bind actual passed by ref to the abduced value pointed to by the synthetic pvar *)
let prop' =
let filtered_sigma =
IList.filter
(function
| Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual ->
false
| _ -> true)
List.filter
~f:(function
| Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual ->
false
| _ -> true)
prop.Prop.sigma in
Prop.normalize tenv (Prop.set prop ~sigma:filtered_sigma) in
IList.fold_left
@ -1341,7 +1339,7 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
not is_const
| None ->
true in
IList.filter is_not_const actuals_by_ref in
List.filter ~f:is_not_const actuals_by_ref in
IList.fold_left do_actual_by_ref prop non_const_actuals_by_ref
and check_untainted tenv exp taint_kind caller_pname callee_pname prop =
@ -1391,11 +1389,10 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots
| param_nums ->
let check_taint_if_nums_match (prop_acc, param_num) (actual_exp, _actual_typ) =
let prop_acc' =
try
let _, taint_kind =
IList.find (fun (num, _) -> Int.equal num param_num) param_nums in
check_untainted tenv actual_exp taint_kind caller_pname callee_pname prop_acc
with Not_found -> prop_acc in
match List.find ~f:(fun (num, _) -> Int.equal num param_num) param_nums with
| Some (_, taint_kind) ->
check_untainted tenv actual_exp taint_kind caller_pname callee_pname prop_acc
| None -> prop_acc in
prop_acc', param_num + 1 in
IList.fold_left
check_taint_if_nums_match

169
infer/src/backend/tabulation.ml
Unescape View File

@ -156,7 +156,7 @@ let process_splitting
let sub = Sil.sub_join sub1 sub2 in
let sub1_inverse =
let sub1_list = Sil.sub_to_list sub1 in
let sub1_list' = IList.filter (function (_, Exp.Var _) -> true | _ -> false) sub1_list in
let sub1_list' = List.filter ~f:(function (_, Exp.Var _) -> true | _ -> false) sub1_list in
let sub1_inverse_list =
IList.map
(function (id, Exp.Var id') -> (id', Exp.Var id) | _ -> assert false)
@ -243,7 +243,7 @@ let process_splitting
| _ ->
L.d_warning "Missing fields in complex pred: "; Sil.d_hpred hpred; L.d_ln ();
false in
IList.filter filter sigma in
List.filter ~f:filter sigma in
let norm_frame = Prop.sigma_sub sub' frame in
{ sub = sub';
frame = norm_frame;
@ -342,14 +342,14 @@ let check_dereferences tenv callee_pname actual_pre sub spec_pre formal_params =
a less interesting PRECONDITION_NOT_MET
* whenever possible *)
(* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *)
Some
(try
IList.find
(fun err -> match err with
| (Deref_null _, _) -> true
| _ -> false )
deref_err_list
with Not_found -> deref_err)
(match
List.find
~f:(fun err -> match err with
| (Deref_null _, _) -> true
| _ -> false )
deref_err_list with
| Some x -> Some x
| None -> Some deref_err)
else Some deref_err
let post_process_sigma tenv (sigma: Sil.hpred list) loc : Sil.hpred list =
@ -720,7 +720,8 @@ let combine tenv
let post_sigma = sigma_star_fld tenv post_p.Prop.sigma split.frame_fld in
let post_sigma' = sigma_star_typ post_sigma split.frame_typ in
Prop.set post_p ~sigma:post_sigma' in
let post_p1 = Prop.prop_sigma_star (prop_copy_footprint_pure tenv actual_pre post_p') split.frame in
let post_p1 =
Prop.prop_sigma_star (prop_copy_footprint_pure tenv actual_pre post_p') split.frame in
let handle_null_case_analysis sigma =
let id_assigned_to_null id =
@ -838,7 +839,10 @@ let check_taint_on_variadic_function tenv callee_pname caller_pname actual_param
| [(tp, _)] when tp < 0 ->
(* All actual params from abs(tp) should not be tainted. If we find one we give the warning *)
let tp_abs = abs tp in
L.d_strln ("Checking tainted actual parameters from parameter number "^ (string_of_int tp_abs) ^ " onwards.");
L.d_strln
("Checking tainted actual parameters from parameter number " ^
(string_of_int tp_abs) ^
" onwards.");
let actual_params' = n_tail actual_params tp_abs in
L.d_str "Paramters to be checked: [ ";
IList.iter(fun (e,_) ->
@ -903,7 +907,7 @@ let mk_posts tenv ret_id prop callee_pname callee_attrs posts =
Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero
| _ -> false)
prop.Prop.sigma in
IList.filter (fun (prop, _) -> not (returns_null prop)) posts
List.filter ~f:(fun (prop, _) -> not (returns_null prop)) posts
else posts in
let mk_retval_tainted posts =
match Taint.returns_tainted callee_pname (Some callee_attrs) with
@ -982,7 +986,7 @@ let do_taint_check tenv caller_pname callee_pname calling_prop missing_pi sub ac
untaint_atoms)
taint_untaint_exp_map) in
check_taint_on_variadic_function tenv callee_pname caller_pname actual_params calling_prop;
IList.filter not_untaint_atom missing_pi_sub
List.filter ~f:not_untaint_atom missing_pi_sub
let class_cast_exn tenv pname_opt texp1 texp2 exp ml_loc =
let desc =
@ -1081,7 +1085,7 @@ let exe_spec
| _ -> false in
(* missing fields minus hidden fields *)
let missing_fld_nohidden =
IList.filter (fun hp -> not (hpred_missing_hidden hp)) missing_fld in
List.filter ~f:(fun hp -> not (hpred_missing_hidden hp)) missing_fld in
if not !Config.footprint && split.missing_sigma <> [] then
begin
L.d_strln "Implication error: missing_sigma not empty in re-execution";
@ -1099,15 +1103,16 @@ let remove_constant_string_class tenv prop =
let filter = function
| Sil.Hpointsto (Exp.Const (Const.Cstr _ | Const.Cclass _), _, _) -> false
| _ -> true in
let sigma = IList.filter filter prop.Prop.sigma in
let sigmafp = IList.filter filter prop.Prop.sigma_fp in
let sigma = List.filter ~f:filter prop.Prop.sigma in
let sigmafp = List.filter ~f:filter prop.Prop.sigma_fp in
let prop' = Prop.set prop ~sigma ~sigma_fp:sigmafp in
Prop.normalize tenv prop'
(** existentially quantify the path identifier generated
by the prover to keep track of expansions of lhs paths
and remove pointsto's whose lhs is a constant string *)
let quantify_path_idents_remove_constant_strings tenv (prop: Prop.normal Prop.t) : Prop.normal Prop.t =
let quantify_path_idents_remove_constant_strings tenv (prop: Prop.normal Prop.t)
: Prop.normal Prop.t =
let fav = Prop.prop_fav prop in
Sil.fav_filter_ident fav Ident.is_path;
remove_constant_string_class tenv (Prop.exist_quantify tenv fav prop)
@ -1120,7 +1125,7 @@ let prop_pure_to_footprint tenv (p: 'a Prop.t) : Prop.normal Prop.t =
let a_fav = Sil.atom_fav a in
Sil.fav_for_all a_fav Ident.is_footprint in
let pure = Prop.get_pure p in
let new_footprint_atoms = IList.filter is_footprint_atom_not_attribute pure in
let new_footprint_atoms = List.filter ~f:is_footprint_atom_not_attribute pure in
if List.is_empty new_footprint_atoms
then p
else (* add pure fact to footprint *)
@ -1141,7 +1146,8 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
IList.partition (fun vr -> vr.vr_pi <> []) valid_res in
let _, valid_res_cons_pre_missing =
IList.partition (fun vr -> vr.incons_pre_missing) valid_res in
let deref_errors = IList.filter (function Dereference_error _ -> true | _ -> false) invalid_res in
let deref_errors =
List.filter ~f:(function Dereference_error _ -> true | _ -> false) invalid_res in
let print_pi pi =
L.d_str "pi: "; Prop.d_pi pi; L.d_ln () in
let call_desc kind_opt = Localise.desc_precondition_not_met kind_opt callee_pname loc in
@ -1151,64 +1157,65 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
if List.is_empty valid_res_cons_pre_missing then
(* no valid results where actual pre and missing are consistent *)
begin
if deref_errors <> [] then (* dereference error detected *)
let extend_path path_opt path_pos_opt = match path_opt with
| None -> ()
| Some path_post ->
let old_path, _ = State.get_path () in
let new_path =
Paths.Path.add_call
(include_subtrace callee_pname) old_path callee_pname path_post in
State.set_path new_path path_pos_opt in
match IList.hd deref_errors with
| Dereference_error (Deref_minusone, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Dangling_pointer_dereference
(Some PredSymb.DAminusone, desc, __POS__))
| Dereference_error (Deref_undef_exp, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Dangling_pointer_dereference
(Some PredSymb.DAuninit, desc, __POS__))
| Dereference_error (Deref_null pos, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
if Localise.is_parameter_not_null_checked_desc desc then
raise (Exceptions.Parameter_not_null_checked (desc, __POS__))
else if Localise.is_field_not_null_checked_desc desc then
raise (Exceptions.Field_not_null_checked (desc, __POS__))
else if (Localise.is_empty_vector_access_desc desc) then
raise (Exceptions.Empty_vector_access (desc, __POS__))
else raise (Exceptions.Null_dereference (desc, __POS__))
| Dereference_error (Deref_freed _, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Use_after_free (desc, __POS__))
| Dereference_error (Deref_undef (_, _, pos), desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
raise (Exceptions.Skip_pointer_dereference (desc, __POS__))
| Prover_checks _
| Cannot_combine
| Missing_sigma_not_empty
| Missing_fld_not_empty ->
trace_call Specs.CallStats.CR_not_met;
assert false
else (* no dereference error detected *)
let desc =
if List.exists ~f:(function Cannot_combine -> true | _ -> false) invalid_res then
call_desc (Some Localise.Pnm_dangling)
else if List.exists ~f:(function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn tenv check callee_pname loc __POS__ in
raise exn
| _ -> false) invalid_res then
call_desc (Some Localise.Pnm_bounds)
else call_desc None in
trace_call Specs.CallStats.CR_not_met;
raise (Exceptions.Precondition_not_met (desc, __POS__))
match deref_errors with
| error :: _ -> (* dereference error detected *)
let extend_path path_opt path_pos_opt = match path_opt with
| None -> ()
| Some path_post ->
let old_path, _ = State.get_path () in
let new_path =
Paths.Path.add_call
(include_subtrace callee_pname) old_path callee_pname path_post in
State.set_path new_path path_pos_opt in
(match error with
| Dereference_error (Deref_minusone, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Dangling_pointer_dereference
(Some PredSymb.DAminusone, desc, __POS__))
| Dereference_error (Deref_undef_exp, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Dangling_pointer_dereference
(Some PredSymb.DAuninit, desc, __POS__))
| Dereference_error (Deref_null pos, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
if Localise.is_parameter_not_null_checked_desc desc then
raise (Exceptions.Parameter_not_null_checked (desc, __POS__))
else if Localise.is_field_not_null_checked_desc desc then
raise (Exceptions.Field_not_null_checked (desc, __POS__))
else if (Localise.is_empty_vector_access_desc desc) then
raise (Exceptions.Empty_vector_access (desc, __POS__))
else raise (Exceptions.Null_dereference (desc, __POS__))
| Dereference_error (Deref_freed _, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Use_after_free (desc, __POS__))
| Dereference_error (Deref_undef (_, _, pos), desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
raise (Exceptions.Skip_pointer_dereference (desc, __POS__))
| Prover_checks _
| Cannot_combine
| Missing_sigma_not_empty
| Missing_fld_not_empty ->
trace_call Specs.CallStats.CR_not_met;
assert false)
| [] -> (* no dereference error detected *)
let desc =
if List.exists ~f:(function Cannot_combine -> true | _ -> false) invalid_res then
call_desc (Some Localise.Pnm_dangling)
else if List.exists ~f:(function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn tenv check callee_pname loc __POS__ in
raise exn
| _ -> false) invalid_res then
call_desc (Some Localise.Pnm_bounds)
else call_desc None in
trace_call Specs.CallStats.CR_not_met;
raise (Exceptions.Precondition_not_met (desc, __POS__))
end
else (* combine the valid results, and store diverging states *)
let process_valid_res vr =
@ -1224,10 +1231,10 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
vr.vr_cons_res in
IList.map
(fun (p, path) -> (prop_pure_to_footprint tenv p, path))
(IList.flatten (IList.map process_valid_res valid_res))
(List.concat (IList.map process_valid_res valid_res))
end
else if valid_res_no_miss_pi <> [] then
IList.flatten (IList.map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
List.concat (IList.map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
else if List.is_empty valid_res_miss_pi then
raise (Exceptions.Precondition_not_met (call_desc None, __POS__))
else
@ -1243,7 +1250,7 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re
| Some cover ->
L.d_strln "Found minimum cover";
IList.iter print_pi (IList.map fst cover);
IList.flatten (IList.map snd cover)
List.concat (IList.map snd cover)
end in
trace_call Specs.CallStats.CR_success;
let res =

32
infer/src/backend/taint.ml
Unescape View File

@ -306,24 +306,21 @@ let attrs_opt_get_annots = function
let returns_tainted callee_pname callee_attrs_opt =
let procname_matches taint_info =
Procname.equal taint_info.PredSymb.taint_source callee_pname in
try
let taint_info = IList.find procname_matches sources in
Some taint_info.PredSymb.taint_kind
with Not_found ->
let ret_annot, _ = attrs_opt_get_annots callee_attrs_opt in
if Annotations.ia_is_integrity_source ret_annot
then Some PredSymb.Tk_integrity_annotation
else if Annotations.ia_is_privacy_source ret_annot
then Some PredSymb.Tk_privacy_annotation
else None
match List.find ~f:procname_matches sources with
| Some taint_info ->
Some taint_info.PredSymb.taint_kind
| None ->
let ret_annot, _ = attrs_opt_get_annots callee_attrs_opt in
if Annotations.ia_is_integrity_source ret_annot
then Some PredSymb.Tk_integrity_annotation
else if Annotations.ia_is_privacy_source ret_annot
then Some PredSymb.Tk_privacy_annotation
else None
let find_callee taint_infos callee_pname =
try
Some
(IList.find
(fun (taint_info, _) -> Procname.equal taint_info.PredSymb.taint_source callee_pname)
taint_infos)
with Not_found -> None
List.find
~f:(fun (taint_info, _) -> Procname.equal taint_info.PredSymb.taint_source callee_pname)
taint_infos
(** returns list of zero-indexed argument numbers of [callee_pname] that may be tainted *)
let accepts_sensitive_params callee_pname callee_attrs_opt =
@ -361,8 +358,7 @@ let has_taint_annotation fieldname (struct_typ: StructTyp.t) =
(* add tainting attributes to a list of paramenters *)
let get_params_to_taint tainted_param_nums formal_params =
let get_taint_kind index =
try Some (IList.find (fun (taint_index, _) -> Int.equal index taint_index) tainted_param_nums)
with Not_found -> None in
List.find ~f:(fun (taint_index, _) -> Int.equal index taint_index) tainted_param_nums in
let collect_params_to_taint params_to_taint_acc (index, param) =
match get_taint_kind index with
| Some (_, taint_kind) -> (param, taint_kind) :: params_to_taint_acc

19
infer/src/base/CommandLineOption.ml
Unescape View File

@ -181,7 +181,7 @@ let pad_and_xform doc_width left_width desc =
wrap_line "" doc_width s
else [s] in
IList.map wrap_line lines in
let doc = indent_doc (String.concat ~sep:"\n" (IList.flatten wrapped_lines)) in
let doc = indent_doc (String.concat ~sep:"\n" (List.concat wrapped_lines)) in
xdesc {desc with doc}
let align desc_list =
@ -325,7 +325,7 @@ type 'a t =
let string_json_decoder ~long json = [dashdash long; YBU.to_string json]
let list_json_decoder json_decoder json = IList.flatten (YBU.convert_each json_decoder json)
let list_json_decoder json_decoder json = List.concat (YBU.convert_each json_decoder json)
let mk_set var value ?(deprecated=[]) ~long ?short ?parse_mode ?(meta="") doc =
let setter () = var := value in
@ -544,6 +544,7 @@ let mk_rest ?(parse_mode=Infer []) doc =
let set_curr_speclist_for_parse_action ~incomplete ~usage parse_action =
let full_speclist = ref [] in
let curr_usage status =
prerr_endline (String.concat_array ~sep:" " !args_to_parse) ;
Arg.usage !curr_speclist usage ;
@ -626,8 +627,8 @@ let set_curr_speclist_for_parse_action ~incomplete ~usage parse_action =
opt = "" ||
IList.for_all (fun (opt', _, doc') ->
(doc <> "" && doc' = "") || (not (String.equal opt opt'))) speclist in
let unique_exe_speclist = IList.filter (is_not_dup_with_doc !curr_speclist) exe_speclist in
curr_speclist := IList.filter (is_not_dup_with_doc unique_exe_speclist) !curr_speclist @
let unique_exe_speclist = List.filter ~f:(is_not_dup_with_doc !curr_speclist) exe_speclist in
curr_speclist := List.filter ~f:(is_not_dup_with_doc unique_exe_speclist) !curr_speclist @
(match header with
| Some s -> (to_arg_spec_triple (mk_header_spec s)):: unique_exe_speclist
| None -> unique_exe_speclist)
@ -682,10 +683,10 @@ let decode_inferconfig_to_argv path =
let one_config_item result (key, json_val) =
try
let {decode_json} =
IList.find
(fun {long; short} ->
String.equal key long
|| (* for deprecated options *) String.equal key short)
List.find_exn
~f:(fun {long; short} ->
String.equal key long
|| (* for deprecated options *) String.equal key short)
!desc_list in
decode_json json_val @ result
with
@ -704,7 +705,7 @@ let env_var_sep = '^'
let encode_argv_to_env argv =
String.concat ~sep:(String.make 1 env_var_sep)
(IList.filter (fun arg ->
(List.filter ~f:(fun arg ->
not (String.contains arg env_var_sep)
|| (
warnf "Ignoring unsupported option containing '%c' character: %s@\n"

2
infer/src/base/Config.ml
Unescape View File

@ -49,7 +49,7 @@ let string_to_analyzer =
("bufferoverrun", Bufferoverrun)]
let string_of_analyzer a =
IList.find (fun (_, a') -> equal_analyzer a a') string_to_analyzer |> fst
List.find_exn ~f:(fun (_, a') -> equal_analyzer a a') string_to_analyzer |> fst
let clang_frontend_action_symbols = [
("lint", `Lint);

26
infer/src/base/IList.ml
Unescape View File

@ -7,16 +7,11 @@
* of patent rights can be found in the PATENTS file in the same directory.
*)
type 'a t = 'a list [@@deriving compare]
let exists = List.exists
let filter = List.filter
let find = List.find
let fold_left = List.fold_left
let fold_left2 = List.fold_left2
let for_all = List.for_all
let for_all2 = List.for_all2
let hd = List.hd
let iter = List.iter
let iter2 = List.iter2
let iteri = List.iteri
@ -28,7 +23,6 @@ let rev_append = List.rev_append
let rev_map = List.rev_map
let sort = List.sort
let stable_sort = List.stable_sort
let tl = List.tl
let rec last = function
| [] -> None
@ -45,13 +39,6 @@ let fold_lefti (f : 'a -> int -> 'b -> 'a) a l =
fold_left (fun (i, acc) e -> i +1, f acc i e) (0, a) l
|> snd
(** tail-recursive variant of List.flatten *)
let flatten =
let rec flatten acc l = match l with
| [] -> acc
| x:: l' -> flatten (rev_append x acc) l' in
fun l -> rev (flatten [] l)
let flatten_options list =
fold_left (fun list -> function | Some x -> x:: list | None -> list) [] list
|> rev
@ -198,17 +185,6 @@ let rec find_map_opt f = function
then e'
else find_map_opt f l'
(** Like find_map_opt, but with indices *)
let find_mapi_opt (f : int -> 'a -> 'b option) l =
let rec find_mapi_opt_ f i = function
| [] -> None
| e :: l' ->
let e' = f i e in
if e' <> None
then e'
else find_mapi_opt_ f (i + 1) l' in
find_mapi_opt_ f 0 l
let to_string f l =
let rec aux l =
match l with
@ -223,7 +199,7 @@ let mem_assoc equal a l =
(** Like List.assoc but without builtin equality *)
let assoc equal a l =
snd (find (fun x -> equal a (fst x)) l)
snd (List.find (fun x -> equal a (fst x)) l)
let range i j =
let rec aux n acc =

13
infer/src/base/IList.mli
Unescape View File

@ -7,22 +7,13 @@
* of patent rights can be found in the PATENTS file in the same directory.
*)
type 'a t = 'a list [@@deriving compare]
val filter : ('a -> bool) -> 'a list -> 'a list
(** tail-recursive variant of List.flatten *)
val flatten : 'a list list -> 'a list
(** Remove all None elements from the list. *)
val flatten_options : ('a option) list -> 'a list
val find : ('a -> bool) -> 'a list -> 'a
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
val fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
val for_all : ('a -> bool) -> 'a list -> bool
val for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val hd : 'a list -> 'a
val iter : ('a -> unit) -> 'a list -> unit
val iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
val iteri : (int -> 'a -> unit) -> 'a list -> unit
@ -54,7 +45,6 @@ val rev_map : ('a -> 'b) -> 'a list -> 'b list
val sort : ('a -> 'a -> int) -> 'a list -> 'a list
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
val tl : 'a list -> 'a list
(** last element, if any *)
val last : 'a list -> 'a option
@ -95,9 +85,6 @@ val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
(** Return the first non-None result found when applying f to elements of l *)
val find_map_opt : ('a -> 'b option) -> 'a list -> 'b option
(** Like find_map_opt, but with indices *)
val find_mapi_opt : (int -> 'a -> 'b option) -> 'a list -> 'b option
val to_string : ('a -> string) -> 'a list -> string
(** Creates an list, inclusive. E.g. `range 2 4` -> [2, 3, 4].

3
infer/src/base/SourceFile.ml
Unescape View File

@ -128,8 +128,7 @@ let of_header header_file =
let file_opt = match ext_opt with
| Some ext when List.mem ~equal:String.equal header_exts ext -> (
let possible_files = IList.map (fun ext -> file_no_ext ^ "." ^ ext) source_exts in
try Some (IList.find path_exists possible_files)
with Not_found -> None
List.find ~f:path_exists possible_files
)
| _ -> None in
Option.map ~f:from_abs_path file_opt

4
infer/src/bufferoverrun/arrayBlk.ml
Unescape View File

@ -97,7 +97,7 @@ struct
let s1 = Itv.get_symbols arr.offset in
let s2 = Itv.get_symbols arr.size in
let s3 = Itv.get_symbols arr.stride in
IList.flatten [s1; s2; s3]
List.concat [s1; s2; s3]
let normalize : t -> t
= fun arr ->
@ -176,7 +176,7 @@ let subst : astate -> Itv.Bound.t Itv.SubstMap.t -> astate
let get_symbols : astate -> Itv.Symbol.t list
= fun a ->
IList.flatten (IList.map (fun (_, ai) -> ArrInfo.get_symbols ai) (bindings a))
List.concat (IList.map (fun (_, ai) -> ArrInfo.get_symbols ai) (bindings a))
let normalize : astate -> astate
= fun a -> map ArrInfo.normalize a

4
infer/src/bufferoverrun/bufferOverrunChecker.ml
Unescape View File

@ -49,7 +49,7 @@ struct
= fun pname ret params node mem ->
match ret with
| Some (id, _) ->
let (typ, size) = get_malloc_info (IList.hd params |> fst) in
let (typ, size) = get_malloc_info (List.hd_exn params |> fst) in
let size = Sem.eval size mem (CFG.loc node) |> Dom.Val.get_itv in
let v = Sem.eval_array_alloc pname node typ Itv.zero size 0 1 in
Dom.Mem.add_stack (Loc.of_id id) v mem
@ -59,7 +59,7 @@ struct
: Procname.t -> (Ident.t * Typ.t) option -> (Exp.t * Typ.t) list -> CFG.node
-> Dom.Mem.t -> Dom.Mem.t
= fun pname ret params node mem ->
model_malloc pname ret (IList.tl params) node mem
model_malloc pname ret (List.tl_exn params) node mem
let model_natual_itv : (Ident.t * Typ.t) option -> Dom.Mem.t -> Dom.Mem.t
= fun ret mem ->

2
infer/src/bufferoverrun/bufferOverrunDomain.ml
Unescape View File

@ -491,7 +491,7 @@ struct
let get_symbols : astate -> Itv.Symbol.t list
= fun mem ->
IList.flatten (IList.map (fun (_, v) -> Val.get_symbols v) (bindings mem))
List.concat (IList.map (fun (_, v) -> Val.get_symbols v) (bindings mem))
let get_return : astate -> Val.t
= fun mem ->

22
infer/src/checkers/BoundedCallTree.ml
Unescape View File

@ -122,19 +122,19 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
failwith "Proc type not supported by crashcontext: block" in
String.equal frame.Stacktrace.method_str (Procname.get_method caller) &&
matches_class caller in
let all_frames = IList.flatten
let all_frames = List.concat
(IList.map (fun trace -> trace.Stacktrace.frames) traces) in
begin
try
let frame = IList.find matches_proc all_frames in
let new_astate = Domain.add pn astate in
if Stacktrace.frame_matches_location frame loc then begin
let pdesc = proc_data.ProcData.pdesc in
output_json_summary pdesc new_astate loc "call_site" get_proc_desc
end;
new_astate
with
Not_found -> astate
match List.find ~f:matches_proc all_frames with
| Some frame ->
let new_astate = Domain.add pn astate in
if Stacktrace.frame_matches_location frame loc then begin
let pdesc = proc_data.ProcData.pdesc in
output_json_summary pdesc new_astate loc "call_site" get_proc_desc
end;
new_astate
| None ->
astate
end
| Sil.Call _ ->
(* We currently ignore calls through function pointers in C and

4
infer/src/checkers/SimpleChecker.ml
Unescape View File

@ -90,8 +90,8 @@ module Make (Spec : Spec) : S = struct
then
(* should never fail since keys in the invariant map should always be real node id's *)
let node =
IList.find
(fun node -> Procdesc.Node.equal_id node_id (Procdesc.Node.get_id node))
List.find_exn
~f:(fun node -> Procdesc.Node.equal_id node_id (Procdesc.Node.get_id node))
nodes in
Domain.iter
(fun astate ->

8
infer/src/checkers/Siof.ml
Unescape View File

@ -47,7 +47,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
&& not (Pvar.is_compile_constant pv)
&& not (is_compile_time_constructed pdesc pv) in
let globals_accesses =
Exp.get_vars e |> snd |> IList.filter is_dangerous_global
Exp.get_vars e |> snd |> List.filter ~f:is_dangerous_global
|> IList.map (fun v -> (v, loc)) in
GlobalsAccesses.of_list globals_accesses
@ -149,12 +149,12 @@ let report_siof trace pdesc gname loc =
let has_foreign_sink (_, path) =
List.exists
~f:(fun (sink, _) ->
GlobalsAccesses.exists (is_foreign tu_opt)
(SiofTrace.Sink.kind sink))
GlobalsAccesses.exists (is_foreign tu_opt)
(SiofTrace.Sink.kind sink))
path in
SiofTrace.get_reportable_sink_paths trace ~trace_of_pname
|> IList.filter has_foreign_sink
|> List.filter ~f:has_foreign_sink
|> IList.iter report_one_path
let siof_check pdesc gname = function

2
infer/src/checkers/Stacktrace.ml
Unescape View File

@ -101,7 +101,7 @@ let of_json filename json =
Yojson.Basic.Util.to_list (extract_json_member frames_key)
|> IList.map Yojson.Basic.Util.to_string
|> IList.map String.strip
|> IList.filter (fun s -> s <> "")
|> List.filter ~f:(fun s -> s <> "")
|> IList.map parse_stack_frame in
make exception_name frames

6
infer/src/checkers/ThreadSafety.ml
Unescape View File

@ -152,7 +152,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
let truncate = function
| base, []
| base, _ :: [] -> base, []
| base, accesses -> base, IList.rev (IList.tl (IList.rev accesses)) in
| base, accesses -> base, IList.rev (List.tl_exn (IList.rev accesses)) in
(* we don't want to warn on writes to the field if it is (a) thread-confined, or (b) volatile *)
let is_safe_write access_path tenv =
@ -714,8 +714,8 @@ let report_thread_safety_violations ( _, tenv, pname, pdesc) trace =
let pp_accesses fmt sink =
let _, accesses = PathDomain.Sink.kind sink in
AccessPath.pp_access_list fmt accesses in
let initial_sink, _ = IList.hd (IList.rev sinks) in
let final_sink, _ = IList.hd sinks in
let initial_sink, _ = List.last_exn sinks in
let final_sink, _ = List.hd_exn sinks in
let initial_sink_site = PathDomain.Sink.call_site initial_sink in
let final_sink_site = PathDomain.Sink.call_site final_sink in
let desc_of_sink sink =

12
infer/src/checkers/Trace.ml
Unescape View File

@ -104,10 +104,10 @@ module Expander (TraceElem : TraceElem.S) = struct
CallSite.Set.mem (TraceElem.call_site callee_elem) seen in
(* find sinks that are the same kind as the caller, but have a different procname *)
let matching_elems =
IList.filter
(fun callee_elem ->
[%compare.equal : TraceElem.Kind.t] (TraceElem.kind callee_elem) elem_kind &&
not (is_recursive callee_elem seen_acc'))
List.filter
~f:(fun callee_elem ->
[%compare.equal : TraceElem.Kind.t] (TraceElem.kind callee_elem) elem_kind &&
not (is_recursive callee_elem seen_acc'))
elems in
(* arbitrarily pick one elem and explore it further *)
match matching_elems with
@ -208,8 +208,8 @@ module Make (Spec : Spec) = struct
let pp_sources = pp_elems Source.call_site in
let pp_sinks = pp_elems Sink.call_site in
let original_source = fst (IList.hd sources_passthroughs) in
let final_sink = fst (IList.hd sinks_passthroughs) in
let original_source = fst (List.hd_exn sources_passthroughs) in
let final_sink = fst (List.hd_exn sinks_passthroughs) in
F.fprintf
fmt
"Error: %a -> %a. Full trace:@.%a@.Current procedure %a %a@.%a"

4
infer/src/checkers/annotations.ml
Unescape View File

@ -86,8 +86,8 @@ let ia_contains ia ann_name =
List.exists ~f:(class_name_matches ann_name) ia
let ia_get ia ann_name =
try Some (fst (IList.find (class_name_matches ann_name) ia))
with Not_found -> None
List.find ~f:(class_name_matches ann_name) ia |>
Option.map ~f:fst
let pdesc_has_parameter_annot pdesc predicate =
let _, param_annotations = (Procdesc.get_attributes pdesc).ProcAttributes.method_annotation in

4
infer/src/checkers/checkDeadCode.ml
Unescape View File

@ -75,8 +75,8 @@ let check_final_state tenv proc_name proc_desc final_s =
if tot_nodes <> tot_visited then
begin
let not_visited =
IList.filter
(fun n -> not (Procdesc.NodeSet.mem n (State.get_visited final_s)))
List.filter
~f:(fun n -> not (Procdesc.NodeSet.mem n (State.get_visited final_s)))
proc_nodes in
let do_node n =
let loc = Procdesc.Node.get_loc n in

2
infer/src/checkers/checkTraceCallSequence.ml
Unescape View File

@ -122,7 +122,7 @@ module State = struct
(** Map a function to the elements of the set, and filter out inconsistencies. *)
let map2 (f : Elem.t -> Elem.t list) (s : t) : t =
let l = ElemSet.elements s in
let l' = IList.filter Elem.is_consistent (IList.flatten (IList.map f l)) in
let l' = List.filter ~f:Elem.is_consistent (List.concat (IList.map f l)) in
IList.fold_right ElemSet.add l' ElemSet.empty
let map (f : Elem.t -> Elem.t) s =

19
infer/src/checkers/checkers.ml
Unescape View File

@ -220,7 +220,7 @@ let callback_check_write_to_parcel_java
match typ with
| Typ.Tptr (Tstruct name, _) -> (
match Tenv.lookup tenv name with
| Some { methods } -> IList.filter is_parcel_constructor methods
| Some { methods } -> List.filter ~f:is_parcel_constructor methods
| None -> []
)
| _ -> [] in
@ -261,11 +261,11 @@ let callback_check_write_to_parcel_java
let r_call_descs =
IList.map node_to_call_desc
(IList.filter is_serialization_node
(List.filter ~f:is_serialization_node
(Procdesc.get_sliced_slope r_desc is_serialization_node)) in
let w_call_descs =
IList.map node_to_call_desc
(IList.filter is_serialization_node
(List.filter ~f:is_serialization_node
(Procdesc.get_sliced_slope w_desc is_serialization_node)) in
let rec check_match = function
@ -332,7 +332,7 @@ let callback_monitor_nullcheck { Callbacks.proc_desc; idenv; proc_name } =
| Typ.Tstruct _ -> true
| Typ.Tptr (Typ.Tstruct _, _) -> true
| _ -> false in
IList.filter is_class_type formals in
List.filter ~f:is_class_type formals in
IList.map fst class_formals) in
let equal_formal_param exp formal_name = match exp with
| Exp.Lvar pvar ->
@ -368,7 +368,7 @@ let callback_monitor_nullcheck { Callbacks.proc_desc; idenv; proc_name } =
begin
let was_not_found formal_name =
not (Exp.Set.exists (fun exp -> equal_formal_param exp formal_name) !checks_to_formals) in
let missing = IList.filter was_not_found formal_names in
let missing = List.filter ~f:was_not_found formal_names in
let loc = Procdesc.get_loc proc_desc in
let pp_file_loc fmt () =
F.fprintf fmt "%a:%d" SourceFile.pp loc.Location.file loc.Location.line in
@ -420,18 +420,15 @@ let callback_find_deserialization { Callbacks.proc_desc; get_proc_desc; idenv; p
let reverse_find_instr f node =
(* this is not really sound but for the moment a sufficient approximation *)
let has_instr node =
try ignore(IList.find f (Procdesc.Node.get_instrs node)); true
with Not_found -> false in
List.exists ~f (Procdesc.Node.get_instrs node) in
let preds =
Procdesc.Node.get_generated_slope
node
(fun n -> Procdesc.Node.get_sliced_preds n has_instr) in
let instrs =
IList.flatten
List.concat
(IList.map (fun n -> IList.rev (Procdesc.Node.get_instrs n)) preds) in
try
Some (IList.find f instrs)
with Not_found -> None in
List.find ~f instrs in
let get_return_const proc_name' =
try

2
infer/src/checkers/fragmentRetainsViewChecker.ml
Unescape View File

@ -39,7 +39,7 @@ let callback_fragment_retains_view_java
match Tenv.lookup tenv class_typename with
| Some { fields } when AndroidFramework.is_fragment tenv class_typename ->
let declared_view_fields =
IList.filter (is_declared_view_typ class_typename) fields in
List.filter ~f:(is_declared_view_typ class_typename) fields in
let fields_nullified = PatternMatch.get_fields_nullified proc_desc in
(* report if a field is declared by C, but not nulled out in C.onDestroyView *)
IList.iter

12
infer/src/checkers/patternMatch.ml
Unescape View File

@ -48,7 +48,7 @@ let rec supertype_find_map_opt tenv f name =
| Some ({supers} as struct_typ) ->
begin
match f name struct_typ with
| None -> IList.find_map_opt (supertype_find_map_opt tenv f) supers
| None -> List.find_map ~f:(supertype_find_map_opt tenv f) supers
| result -> result
end
| None ->
@ -134,9 +134,11 @@ let get_field_type_name tenv
| Tstruct name | Tptr (Tstruct name, _) -> (
match Tenv.lookup tenv name with
| Some { fields } -> (
match IList.find (function | (fn, _, _) -> Ident.equal_fieldname fn fieldname) fields with
| _, ft, _ -> Some (get_type_name ft)
| exception Not_found -> None
match List.find
~f:(function | (fn, _, _) -> Ident.equal_fieldname fn fieldname)
fields with
| Some (_, ft, _) -> Some (get_type_name ft)
| None -> None
)
| None -> None
)
@ -405,7 +407,7 @@ let check_current_class_attributes check tenv = function
let rec find_superclasses_with_attributes check tenv tname =
match Tenv.lookup tenv tname with
| Some (struct_typ) ->
let result_from_supers = IList.flatten
let result_from_supers = List.concat
(IList.map (find_superclasses_with_attributes check tenv) struct_typ.supers)
in
if check struct_typ.annots then

9
infer/src/checkers/printfArgs.ml
Unescape View File

@ -46,12 +46,9 @@ let add_printf_like_function plf =
let printf_like_function
(proc_name: Procname.t): printf_signature option =
try
Some (
IList.find
(fun printf -> String.equal printf.unique_id (Procname.to_unique_id proc_name))
!printf_like_functions)
with Not_found -> None
List.find
~f:(fun printf -> String.equal printf.unique_id (Procname.to_unique_id proc_name))
!printf_like_functions
let default_format_type_name
(format_type: string): string =

4
infer/src/clang/CType_decl.ml
Unescape View File

@ -128,7 +128,7 @@ let get_translate_as_friend_decl decl_list =
let named_decl_tuple_opt = Clang_ast_proj.get_named_decl_tuple decl in
Option.value_map ~f:is_translate_as_friend_name ~default:false named_decl_tuple_opt
| None -> false in
match get_friend_decl_opt (IList.find is_translate_as_friend_decl decl_list) with
match get_friend_decl_opt (List.find_exn ~f:is_translate_as_friend_decl decl_list) with
| Some (Clang_ast_t.ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, _, [`Type t_ptr])) ->
Some t_ptr
| _ -> None
@ -150,7 +150,7 @@ let rec get_struct_fields tenv decl =
| _ -> [] in
let base_decls = get_superclass_decls decl in
let base_class_fields = IList.map (get_struct_fields tenv) base_decls in
IList.flatten (base_class_fields @ (IList.map do_one_decl decl_list))
List.concat (base_class_fields @ (IList.map do_one_decl decl_list))
(* For a record declaration it returns/constructs the type *)
and get_record_declaration_type tenv decl =

6
infer/src/clang/ComponentKit.ml
Unescape View File

@ -233,14 +233,14 @@ let component_with_multiple_factory_methods_advice context an =
let attrs = match decl with
| ObjCMethodDecl (decl_info, _, _) -> decl_info.Clang_ast_t.di_attributes
| _ -> assert false in
let unavailable_attrs = (IList.filter is_unavailable_attr attrs) in
let unavailable_attrs = (List.filter ~f:is_unavailable_attr attrs) in
let is_available = Int.equal (IList.length unavailable_attrs) 0 in
(CAst_utils.is_objc_factory_method if_decl decl) && is_available in
let check_interface if_decl =
match if_decl with
| Clang_ast_t.ObjCInterfaceDecl (_, _, decls, _, _) ->
let factory_methods = IList.filter (is_available_factory_method if_decl) decls in
let factory_methods = List.filter ~f:(is_available_factory_method if_decl) decls in
CTL.True, IList.map (fun meth_decl -> {
CIssue.name = "COMPONENT_WITH_MULTIPLE_FACTORY_METHODS";
severity = Exceptions.Kadvice;
@ -290,7 +290,7 @@ let rec _component_initializer_with_side_effects_advice
| Clang_ast_t.DeclRefExpr (_, _, _, decl_ref_expr_info) ->
let refs = [decl_ref_expr_info.drti_decl_ref;
decl_ref_expr_info.drti_found_decl_ref] in
(match IList.find_map_opt CAst_utils.name_of_decl_ref_opt refs with
(match List.find_map ~f:CAst_utils.name_of_decl_ref_opt refs with
| Some "dispatch_after"
| Some "dispatch_async"
| Some "dispatch_sync" ->

2
infer/src/clang/cFrontend_checkers_main.ml
Unescape View File

@ -214,7 +214,7 @@ let do_frontend_checks trans_unit_ctx ast =
let is_decl_allowed decl =
let decl_info = Clang_ast_proj.get_decl_tuple decl in
CLocation.should_do_frontend_check trans_unit_ctx decl_info.Clang_ast_t.di_source_range in
let allowed_decls = IList.filter is_decl_allowed decl_list in
let allowed_decls = List.filter ~f:is_decl_allowed decl_list in
(* We analyze the top level and then all the allowed declarations *)
CFrontend_errors.invoke_set_of_checkers_on_node context (Ctl_parser_types.Decl ast);
IList.iter (do_frontend_checks_decl context) allowed_decls;

2
infer/src/clang/cMethod_trans.ml
Unescape View File

@ -151,7 +151,7 @@ let get_assume_not_null_calls param_decls =
decl_info name qt.Clang_ast_t.qt_type_ptr in
[(`ClangStmt assume_call)]
| _ -> [] in
IList.flatten (IList.map do_one_param param_decls)
List.concat (IList.map do_one_param param_decls)
let get_init_list_instrs method_decl_info =
let create_custom_instr construct_instr = `CXXConstructorInit construct_instr in

12
infer/src/clang/cTrans.ml
Unescape View File

@ -168,10 +168,10 @@ struct
(f exps, !insts)
let collect_exprs res_trans_list =
IList.flatten (IList.map (fun res_trans -> res_trans.exps) res_trans_list)
List.concat (IList.map (fun res_trans -> res_trans.exps) res_trans_list)
let collect_initid_exprs res_trans_list =
IList.flatten (IList.map (fun res_trans -> res_trans.initd_exps) res_trans_list)
List.concat (IList.map (fun res_trans -> res_trans.initd_exps) res_trans_list)
(* If e is a block and the calling node has the priority then *)
(* we need to release the priority to allow*)
@ -443,7 +443,7 @@ struct
let open Clang_ast_t in
let decl_info = Clang_ast_proj.get_decl_tuple decl in
let get_attr_opt = function DeprecatedAttr a -> Some a | _ -> None in
match IList.find_map_opt get_attr_opt decl_info.di_attributes with
match List.find_map ~f:get_attr_opt decl_info.di_attributes with
| Some attribute_info ->
(match attribute_info.ai_parameters with
| [_; arg; _; _; _; _] -> Some arg
@ -888,7 +888,7 @@ struct
Option.value_map
~f:CTrans_models.is_cf_retain_release ~default:false callee_pname_opt in
let act_params =
let params = IList.tl (collect_exprs result_trans_subexprs) in
let params = List.tl_exn (collect_exprs result_trans_subexprs) in
if Int.equal (IList.length params) (IList.length params_stmt) then
params
else (Logging.err_debug
@ -929,7 +929,7 @@ struct
let sil_loc = CLocation.get_sil_location si context in
(* first for method address, second for 'this' expression *)
assert (Int.equal (IList.length result_trans_callee.exps) 2);
let (sil_method, _) = IList.hd result_trans_callee.exps in
let (sil_method, _) = List.hd_exn result_trans_callee.exps in
let callee_pname =
match sil_method with
| Exp.Const (Const.Cfun pn) -> pn
@ -944,7 +944,7 @@ struct
let res_trans_p = IList.map (instruction' trans_state_param) params_stmt in
result_trans_callee :: res_trans_p in
(* first expr is method address, rest are params including 'this' parameter *)
let actual_params = IList.tl (collect_exprs result_trans_subexprs) in
let actual_params = List.tl_exn (collect_exprs result_trans_subexprs) in
match cxx_method_builtin_trans trans_state_pri sil_loc result_trans_subexprs callee_pname with
| Some builtin -> builtin
| _ ->

6
infer/src/clang/cTrans_utils.ml
Unescape View File

@ -723,7 +723,7 @@ let var_or_zero_in_init_list tenv e typ ~return_zero:return_zero =
IList.map (fun (fieldname, _, _) -> Exp.Lfield (e, fieldname, typ)) fields in
let lh_types = IList.map (fun (_, fieldtype, _) -> fieldtype) fields in
let exp_types = zip lh_exprs lh_types in
IList.map (fun (e, t) -> IList.flatten (var_or_zero_in_init_list' e t tns)) exp_types
IList.map (fun (e, t) -> List.concat (var_or_zero_in_init_list' e t tns)) exp_types
| None ->
assert false
)
@ -737,12 +737,12 @@ let var_or_zero_in_init_list tenv e typ ~return_zero:return_zero =
let lh_types = replicate size arrtyp in
let exp_types = zip lh_exprs lh_types in
IList.map (fun (e, t) ->
IList.flatten (var_or_zero_in_init_list' e t tns)) exp_types
List.concat (var_or_zero_in_init_list' e t tns)) exp_types
| Typ.Tint _ | Typ.Tfloat _ | Typ.Tptr _ ->
let exp = if return_zero then Sil.zero_value_of_numerical_type typ else e in
[ [(exp, typ)] ]
| Typ.Tfun _ | Typ.Tvoid | Typ.Tarray _ -> assert false in
IList.flatten (var_or_zero_in_init_list' e typ String.Set.empty)
List.concat (var_or_zero_in_init_list' e typ String.Set.empty)
(*
(** Similar to extract_item_from_singleton but for option type *)

2
infer/src/eradicate/eradicate.ml
Unescape View File

@ -232,7 +232,7 @@ struct
let rec fixpoint initializers_old =
let initializers_new = get_private_called initializers_old in
let initializers_new' =
IList.filter (fun (pn, _) -> not (Procname.Set.mem pn !seen)) initializers_new in
List.filter ~f:(fun (pn, _) -> not (Procname.Set.mem pn !seen)) initializers_new in
mark_seen initializers_new';
if initializers_new' <> [] then fixpoint initializers_new' in

2
infer/src/harness/androidFramework.ml
Unescape View File

@ -88,7 +88,7 @@ let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs =
| Some { methods } ->
(* TODO (t4645631): collect the procedures for which is_java is returning false *)
let lookup_proc lifecycle_proc =
IList.find (fun decl_proc ->
List.find_exn ~f:(fun decl_proc ->
match decl_proc with
| Procname.Java decl_proc_java ->
String.equal lifecycle_proc (Procname.java_get_method decl_proc_java)

6
infer/src/harness/inhabit.ml
Unescape View File

@ -60,8 +60,8 @@ let create_fresh_local_name () =
incr local_name_cntr;
"dummy_local" ^ string_of_int !local_name_cntr
(** more forgiving variation of IList.tl that won't raise an exception on the empty list *)
let tl_or_empty l = if List.is_empty l then l else IList.tl l
(** more forgiving variation of List.tl that won't raise an exception on the empty list *)
let tl_or_empty l = if List.is_empty l then l else List.tl_exn l
let get_non_receiver_formals formals = tl_or_empty formals
@ -106,7 +106,7 @@ let rec inhabit_typ tenv typ cfg env =
&& IList.for_all (fun (_, typ) ->
not (TypSet.mem typ env.cur_inhabiting)
) (try_get_non_receiver_formals p) in
IList.filter (fun p -> is_suitable_constructor p) methods
List.filter ~f:(fun p -> is_suitable_constructor p) methods
| _ -> []
)
| _ -> []

6
infer/src/integration/CompilationDatabase.ml
Unescape View File

@ -58,13 +58,13 @@ let decode_json_file (database : t) json_path =
| `List arguments ->
IList.iter parse_json arguments
| `Assoc l ->
let dir = match IList.find_map_opt get_dir l with
let dir = match List.find_map ~f:get_dir l with
| Some dir -> dir
| None -> exit_format_error () in
let file = match IList.find_map_opt get_file l with
let file = match List.find_map ~f:get_file l with
| Some file -> file
| None -> exit_format_error () in
let cmd = match IList.find_map_opt get_cmd l with
let cmd = match List.find_map ~f:get_cmd l with
| Some cmd -> cmd
| None -> exit_format_error () in
let command, args = parse_command_and_arguments cmd in

10
infer/src/java/jTrans.ml
Unescape View File

@ -100,20 +100,20 @@ let retrieve_fieldname fieldname =
if Int.equal (IList.length subs) 0 then
assert false
else
IList.hd (IList.rev subs)
List.hd_exn (IList.rev subs)
with _ -> assert false
let get_field_name program static tenv cn fs =
let { StructTyp.fields; statics; } = JTransType.get_class_struct_typ program tenv cn in
match
IList.find
(fun (fieldname, _, _) -> String.equal (retrieve_fieldname fieldname) (JBasics.fs_name fs))
List.find
~f:(fun (fieldname, _, _) -> String.equal (retrieve_fieldname fieldname) (JBasics.fs_name fs))
(if static then statics else fields)
with
| fieldname, _, _ ->
| Some (fieldname, _, _) ->
fieldname
| exception Not_found ->
| None ->
(* TODO: understand why fields cannot be found here *)
L.do_err "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs);
raise (Frontend_error "Cannot find fieldname")

16
infer/src/java/jTransType.ml
Unescape View File

@ -391,14 +391,14 @@ let param_type program tenv cn name vt =
let get_var_type_from_sig (context : JContext.t) var =
let program = context.program in
try
let tenv = JContext.get_tenv context in
let vt', var' =
IList.find
(fun (_, var') -> JBir.var_equal var var')
(JBir.params context.impl) in
Some (param_type program tenv context.cn var' vt')
with Not_found -> None
let tenv = JContext.get_tenv context in
List.find_map ~f:(
fun (vt', var') ->
if JBir.var_equal var var'
then Some (param_type program tenv context.cn var' vt')
else None
)
(JBir.params context.impl)
let get_var_type context var =

38
infer/src/quandary/JavaTrace.ml
Unescape View File

@ -67,11 +67,11 @@ module SourceKind = struct
| None ->
(* check the list of externally specified sources *)
let procedure = class_name ^ "." ^ method_name in
IList.find_map_opt
(fun (source_spec : QuandaryConfig.Source.t) ->
if Str.string_match source_spec.procedure procedure 0
then Some (of_string source_spec.kind)
else None)
List.find_map
~f:(fun (source_spec : QuandaryConfig.Source.t) ->
if Str.string_match source_spec.procedure procedure 0
then Some (of_string source_spec.kind)
else None)
external_sources
end
end
@ -156,7 +156,7 @@ module SinkKind = struct
let actuals_to_taint, offset =
if Procname.java_is_static pname || taint_this
then actuals, 0
else IList.tl actuals, 1 in
else List.tl_exn actuals, 1 in
IList.mapi
(fun param_num _ -> kind, param_num + offset, report_reachable)
actuals_to_taint in
@ -236,19 +236,19 @@ module SinkKind = struct
| class_name, method_name ->
(* check the list of externally specified sinks *)
let procedure = class_name ^ "." ^ method_name in
IList.find_map_opt
(fun (sink_spec : QuandaryConfig.Sink.t) ->
if Str.string_match sink_spec.procedure procedure 0
then
let kind = of_string sink_spec.kind in
try
let n = int_of_string sink_spec.index in
Some (taint_nth n kind ~report_reachable:true)
with Failure _ ->
(* couldn't parse the index, just taint everything *)
Some (taint_all kind ~report_reachable:true)
else
None)
List.find_map
~f:(fun (sink_spec : QuandaryConfig.Sink.t) ->
if Str.string_match sink_spec.procedure procedure 0
then
let kind = of_string sink_spec.kind in
try
let n = int_of_string sink_spec.index in
Some (taint_nth n kind ~report_reachable:true)
with Failure _ ->
(* couldn't parse the index, just taint everything *)
Some (taint_all kind ~report_reachable:true)
else
None)
external_sinks in
begin
match

4
infer/src/quandary/TaintAnalysis.ml
Unescape View File

@ -168,8 +168,8 @@ module Make (TaintSpecification : TaintSpec.S) = struct
TraceDomain.empty in
let pp_path_short fmt (_, sources_passthroughs, sinks_passthroughs) =
let original_source = fst (IList.hd sources_passthroughs) in
let final_sink = fst (IList.hd sinks_passthroughs) in
let original_source = fst (List.hd_exn sources_passthroughs) in
let final_sink = fst (List.hd_exn sinks_passthroughs) in
F.fprintf
fmt
"%a -> %a"

16
infer/src/unit/schedulerTests.ml
Unescape View File

@ -39,19 +39,17 @@ module MockProcCfg = struct
let equal_id = Int.equal
let succs t n =
try
let node_id = id n in
IList.find
(fun (node, _) -> equal_id (id node) node_id)
t
|> snd
with Not_found -> []
let node_id = id n in
List.find
~f:(fun (node, _) -> equal_id (id node) node_id)
t |>
Option.value_map ~f:snd ~default:[]
let preds t n =
try
let node_id = id n in
IList.filter
(fun (_, succs) ->
List.filter
~f:(fun (_, succs) ->
List.exists ~f:(fun node -> equal_id (id node) node_id) succs)
t
|> IList.map fst

Write Preview
Loading…
Cancel
Save