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

put Util.list_* functions into an IList module

Browse Source 
Summary: public
modules are better for namespacing.

How I made this diff:

1. moved list_* functions from utils.ml{,i} to iList.ml{,i}
2. shell commands:

  grep '^val ' infer/src/backend/iList.mli | cut -f 2 -d ' ' | tr '\n' ' '
  # gives a list of former list_ functions that IList implements, fed into the loops below:
  LISTNAMES=" compare equal append combine exists filter flatten flatten_options find fold_left fold_left2 for_all for_all2 hd iter iter2 length fold_right map mem nth partition rev rev_append rev_map sort split stable_sort tl drop_first drop_last rev_with_acc remove_duplicates remove_irrelevant_duplicates merge_sorted_nodup intersect mem_assoc assoc map2 to_string"
  # replace " list_*" function calls with IList.* ones
  for i in $LISTNAMES; do find . -name '*.ml' -exec sed -i -e "s/ list_$i\b/ IList.$i/g" \{\} \; ; done

  # replace (list_* functions with (IList.* ones
  for i in $LISTNAMES; do find . -name '*.ml' -exec sed -i -e "s/(list_$i\b/(IList.$i/g" \{\} \; ; done

  # ditto with [
  for i in $LISTNAMES; do find . -name '*.ml' -exec sed -i -e "s/\[list_$i\b/[IList.$i/g" \{\} \; ; done

3. Then fix up the rest by hand. In particular, stuff that called Utils.list_*
explicitely, and stuff that used the "Fail" exception that has moved to
IList. (may revisit this in the future)

Reviewed By: jeremydubreil, cristianoc

Differential Revision: D2550241

fb-gh-sync-id: cd64b10
master
Jules Villard 9 years ago committed by facebook-github-bot-1
parent f17f54939b
commit 7d0a7568f3
95 changed files with 2235 additions and 2235 deletions
Show Stats Download Patch File Download Diff File

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

@ -141,15 +141,15 @@ let find_source_dirs () =
let files_in_results_dir = Array.to_list (Sys.readdir capt_dir) in
let add_cg_files_from_dir dir =
let files = Array.to_list (Sys.readdir dir) in
list_iter (fun fname ->
IList.iter (fun fname ->
let path = Filename.concat dir fname in
if Filename.check_suffix path ".cg" then source_dirs := dir :: !source_dirs)
files in
list_iter (fun fname ->
IList.iter (fun fname ->
let dir = Filename.concat capt_dir fname in
if Sys.is_directory dir then add_cg_files_from_dir dir)
files_in_results_dir;
list_rev !source_dirs
IList.rev !source_dirs
(** {2 Filename} *)
@ -273,7 +273,7 @@ module Results_dir = struct
| [] -> base
| name:: names ->
Filename.concat (f names) (if name ==".." then Filename.parent_dir_name else name) in
f (list_rev path)
f (IList.rev path)
(** convert a path to a filename *)
let path_to_filename pk path =
@ -315,7 +315,7 @@ module Results_dir = struct
let new_path = Filename.concat (create names) name in
create_dir new_path;
new_path in
let filename, dir_path = match list_rev path with
let filename, dir_path = match IList.rev path with
| filename:: dir_path -> filename, dir_path
| [] -> raise (Failure "create_path") in
let full_fname = Filename.concat (create dir_path) filename in
@ -327,6 +327,6 @@ let global_tenv_fname () =
filename_concat (captured_dir ()) basename
let is_source_file path =
list_exists
IList.exists
(fun ext -> Filename.check_suffix path ext)
Config.source_file_extentions

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

@ -32,7 +32,7 @@ let sigma_rewrite p r : Prop.normal Prop.t option =
else
let res_pi = r.r_new_pi p p_leftover sub in
let res_sigma = Prop.sigma_sub sub r.r_new_sigma in
let p_with_res_pi = list_fold_left Prop.prop_atom_and p_leftover res_pi in
let p_with_res_pi = IList.fold_left Prop.prop_atom_and p_leftover res_pi in
let p_new = Prop.prop_sigma_star p_with_res_pi res_sigma in
Some (Prop.normalize p_new)
@ -53,42 +53,42 @@ let create_fresh_primeds_ls para =
let ids_shared =
let svars = para.Sil.svars in
let f id = Ident.create_fresh Ident.kprimed in
list_map f svars in
IList.map f svars in
let ids_tuple = (id_base, id_next, id_end, ids_shared) in
let exp_base = Sil.Var id_base in
let exp_next = Sil.Var id_next in
let exp_end = Sil.Var id_end in
let exps_shared = list_map (fun id -> Sil.Var id) ids_shared in
let exps_shared = IList.map (fun id -> Sil.Var id) ids_shared in
let exps_tuple = (exp_base, exp_next, exp_end, exps_shared) in
(ids_tuple, exps_tuple)
let create_condition_ls ids_private id_base p_leftover (inst: Sil.subst) =
let (insts_of_private_ids, insts_of_public_ids, inst_of_base) =
let f id' = list_exists (fun id'' -> Ident.equal id' id'') ids_private in
let f id' = IList.exists (fun id'' -> Ident.equal id' id'') ids_private in
let (inst_private, inst_public) = Sil.sub_domain_partition f inst in
let insts_of_public_ids = Sil.sub_range inst_public in
let inst_of_base = try Sil.sub_find (Ident.equal id_base) inst_public with Not_found -> assert false 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 = list_flatten (list_map Sil.exp_fav_list insts_of_public_ids) in
let fav_insts_of_private_ids = list_flatten (list_map Sil.exp_fav_list insts_of_private_ids) 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_p_leftover, fav_in_pvars) =
let sigma = Prop.get_sigma p_leftover 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 = list_flatten (list_map Sil.exp_fpv insts_of_private_ids) in
let fpv_insts_of_private_ids = IList.flatten (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@.";
L.out "@[<4> private ids : %a@\n@." pp_exp_list insts_of_private_ids;
L.out "@[<4> public ids : %a@\n@." pp_exp_list insts_of_public_ids;
*)
(* (not (list_intersect compare fav_inst_of_base fav_in_pvars)) && *)
(* (not (IList.intersect compare fav_inst_of_base fav_in_pvars)) && *)
(fpv_inst_of_base = []) &&
(fpv_insts_of_private_ids = []) &&
(not (list_exists Ident.is_normal fav_insts_of_private_ids)) &&
(not (Utils.list_intersect Ident.compare fav_insts_of_private_ids fav_p_leftover)) &&
(not (Utils.list_intersect Ident.compare fav_insts_of_private_ids fav_insts_of_public_ids))
(not (IList.exists Ident.is_normal fav_insts_of_private_ids)) &&
(not (IList.intersect Ident.compare fav_insts_of_private_ids fav_p_leftover)) &&
(not (IList.intersect Ident.compare fav_insts_of_private_ids fav_insts_of_public_ids))
let mk_rule_ptspts_ls impl_ok1 impl_ok2 (para: Sil.hpara) =
let (ids_tuple, exps_tuple) = create_fresh_primeds_ls para in
@ -101,12 +101,12 @@ let mk_rule_ptspts_ls impl_ok1 impl_ok2 (para: Sil.hpara) =
| [] -> L.out "@.@.ERROR (Empty Para): %a @.@." (Sil.pp_hpara pe_text) para; assert false
| hpred :: hpreds ->
let hpat = mark_impl_flag hpred in
let hpats = list_map mark_impl_flag hpreds in
let hpats = IList.map mark_impl_flag hpreds in
(hpat, hpats) in
let (ids_exist_snd, para_snd) =
let mark_impl_flag hpred = { Match.hpred = hpred; Match.flag = impl_ok2 } in
let (ids, para_body) = Sil.hpara_instantiate para exp_next exp_end exps_shared in
let para_body_hpats = list_map mark_impl_flag para_body in
let para_body_hpats = IList.map mark_impl_flag para_body in
(ids, para_body_hpats) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
@ -130,7 +130,7 @@ let mk_rule_ptsls_ls k2 impl_ok1 impl_ok2 para =
| [] -> L.out "@.@.ERROR (Empty Para): %a @.@." (Sil.pp_hpara pe_text) para; assert false
| hpred :: hpreds ->
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok1 } in
(allow_impl hpred, list_map allow_impl hpreds) in
(allow_impl hpred, IList.map allow_impl hpreds) in
let lseg_pat = { Match.hpred = Prop.mk_lseg k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
@ -152,7 +152,7 @@ let mk_rule_lspts_ls k1 impl_ok1 impl_ok2 para =
let (ids_exist, para_inst_pat) =
let (ids, para_body) = Sil.hpara_instantiate para exp_next exp_end exps_shared in
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok2 } in
let para_body_pat = list_map allow_impl para_body in
let para_body_pat = IList.map allow_impl para_body in
(ids, para_body_pat) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
@ -241,12 +241,12 @@ let mk_rule_ptspts_dll impl_ok1 impl_ok2 para =
let ids_shared =
let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in
list_map f svars in
IList.map f svars in
let exp_iF = Sil.Var id_iF in
let exp_iF' = Sil.Var id_iF' in
let exp_oB = Sil.Var id_oB in
let exp_oF = Sil.Var id_oF in
let exps_shared = list_map (fun id -> Sil.Var id) ids_shared in
let exps_shared = IList.map (fun id -> Sil.Var id) ids_shared in
let (ids_exist_fst, para_fst) = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in
let (para_fst_start, para_fst_rest) =
let mark_impl_flag hpred = { Match.hpred = hpred; Match.flag = impl_ok1 } in
@ -254,12 +254,12 @@ let mk_rule_ptspts_dll impl_ok1 impl_ok2 para =
| [] -> L.out "@.@.ERROR (Empty DLL para): %a@.@." (Sil.pp_hpara_dll pe_text) para; assert false
| hpred :: hpreds ->
let hpat = mark_impl_flag hpred in
let hpats = list_map mark_impl_flag hpreds in
let hpats = IList.map mark_impl_flag hpreds in
(hpat, hpats) in
let (ids_exist_snd, para_snd) =
let mark_impl_flag hpred = { Match.hpred = hpred; Match.flag = impl_ok2 } in
let (ids, para_body) = Sil.hpara_dll_instantiate para exp_iF' exp_iF exp_oF exps_shared in
let para_body_hpats = list_map mark_impl_flag para_body in
let para_body_hpats = IList.map mark_impl_flag para_body in
(ids, para_body_hpats) in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
@ -289,20 +289,20 @@ let mk_rule_ptsdll_dll k2 impl_ok1 impl_ok2 para =
let ids_shared =
let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in
list_map f svars in
IList.map f svars in
let exp_iF = Sil.Var id_iF in
let exp_iF' = Sil.Var id_iF' in
let exp_oB = Sil.Var id_oB in
let exp_oF = Sil.Var id_oF in
let exp_iB = Sil.Var id_iB in
let exps_shared = list_map (fun id -> Sil.Var id) ids_shared in
let exps_shared = IList.map (fun id -> Sil.Var id) ids_shared in
let (ids_exist, para_inst) = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in
let (para_inst_start, para_inst_rest) =
match para_inst with
| [] -> assert false
| hpred :: hpreds ->
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok1 } in
(allow_impl hpred, list_map allow_impl hpreds) in
(allow_impl hpred, IList.map allow_impl hpreds) in
let dllseg_pat = { Match.hpred = Prop.mk_dllseg k2 para exp_iF' exp_iF exp_oF exp_iB exps_shared; Match.flag = impl_ok2 } in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
@ -325,17 +325,17 @@ let mk_rule_dllpts_dll k1 impl_ok1 impl_ok2 para =
let ids_shared =
let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in
list_map f svars in
IList.map f svars in
let exp_iF = Sil.Var id_iF in
let exp_iF' = Sil.Var id_iF' in
let exp_oB = Sil.Var id_oB in
let exp_oB' = Sil.Var id_oB' in
let exp_oF = Sil.Var id_oF in
let exps_shared = list_map (fun id -> Sil.Var id) ids_shared in
let exps_shared = IList.map (fun id -> Sil.Var id) ids_shared in
let (ids_exist, para_inst) = Sil.hpara_dll_instantiate para exp_iF' exp_oB' exp_oF exps_shared in
let para_inst_pat =
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok2 } in
list_map allow_impl para_inst in
IList.map allow_impl para_inst in
let dllseg_pat = { Match.hpred = Prop.mk_dllseg k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared; Match.flag = impl_ok1 } in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
@ -359,14 +359,14 @@ let mk_rule_dlldll_dll k1 k2 impl_ok1 impl_ok2 para =
let ids_shared =
let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in
list_map f svars in
IList.map f svars in
let exp_iF = Sil.Var id_iF in
let exp_iF' = Sil.Var id_iF' in
let exp_oB = Sil.Var id_oB in
let exp_oB' = Sil.Var id_oB' in
let exp_oF = Sil.Var id_oF in
let exp_iB = Sil.Var id_iB in
let exps_shared = list_map (fun id -> Sil.Var id) ids_shared in
let exps_shared = IList.map (fun id -> Sil.Var id) ids_shared in
let lseg_fst_pat = { Match.hpred = Prop.mk_dllseg k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared; Match.flag = impl_ok1 } in
let lseg_snd_pat = { Match.hpred = Prop.mk_dllseg k2 para exp_iF' exp_oB' exp_oF exp_iB exps_shared; Match.flag = impl_ok2 } in
let k_res = lseg_kind_add k1 k2 in
@ -423,7 +423,7 @@ let typ_get_recursive_flds tenv te =
(match typ with
| Sil.Tvar _ -> assert false (* there should be no indirection *)
| Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> []
| Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> list_map (fun (x, y, z) -> x) (list_filter filter fld_typ_ann_list)
| Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> IList.map (fun (x, y, z) -> x) (IList.filter filter fld_typ_ann_list)
| Sil.Tarray _ -> [])
| Sil.Var _ -> [] (* type of |-> not known yet *)
| Sil.Const _ -> []
@ -467,16 +467,16 @@ let discover_para_candidates tenv p =
let edges = ref [] in
let add_edge edg = edges := edg :: !edges in
let get_edges_strexp rec_flds root se =
let is_rec_fld fld = list_exists (Sil.fld_equal fld) rec_flds in
let is_rec_fld fld = IList.exists (Sil.fld_equal fld) rec_flds in
match se with
| Sil.Eexp _ | Sil.Earray _ -> ()
| Sil.Estruct (fsel, _) ->
let fsel' = list_filter (fun (fld, _) -> is_rec_fld fld) fsel in
let fsel' = IList.filter (fun (fld, _) -> is_rec_fld fld) fsel in
let process (_, nextse) =
match nextse with
| Sil.Eexp (next, inst) -> add_edge (root, next)
| _ -> assert false in
list_iter process fsel' in
IList.iter process fsel' in
let rec get_edges_sigma = function
| [] -> ()
| Sil.Hlseg _ :: sigma_rest | Sil.Hdllseg _ :: sigma_rest ->
@ -486,13 +486,13 @@ let discover_para_candidates tenv p =
get_edges_strexp rec_flds root se;
get_edges_sigma sigma_rest in
let rec find_all_consecutive_edges found edges_seen = function
| [] -> list_rev found
| [] -> IList.rev found
| (e1, e2) :: edges_notseen ->
let edges_others = (list_rev edges_seen) @ edges_notseen in
let edges_matched = list_filter (fun (e1', _) -> Sil.exp_equal e2 e1') edges_others in
let edges_others = (IList.rev edges_seen) @ edges_notseen in
let edges_matched = IList.filter (fun (e1', _) -> Sil.exp_equal e2 e1') edges_others in
let new_found =
let f found_acc (_, e3) = (e1, e2, e3) :: found_acc in
list_fold_left f found edges_matched in
IList.fold_left f found edges_matched in
let new_edges_seen = (e1, e2) :: edges_seen in
find_all_consecutive_edges new_found new_edges_seen edges_notseen in
let sigma = Prop.get_sigma p in
@ -503,19 +503,19 @@ let discover_para_dll_candidates tenv p =
let edges = ref [] in
let add_edge edg = (edges := edg :: !edges) in
let get_edges_strexp rec_flds root se =
let is_rec_fld fld = list_exists (Sil.fld_equal fld) rec_flds in
let is_rec_fld fld = IList.exists (Sil.fld_equal fld) rec_flds in
match se with
| Sil.Eexp _ | Sil.Earray _ -> ()
| Sil.Estruct (fsel, _) ->
let fsel' = list_filter (fun (fld, _) -> is_rec_fld fld) fsel in
let fsel' = IList.filter (fun (fld, _) -> is_rec_fld fld) fsel in
let convert_to_exp acc (_, se) =
match se with
| Sil.Eexp (e, inst) -> e:: acc
| _ -> assert false in
let links = list_rev (list_fold_left convert_to_exp [] fsel') in
let links = IList.rev (IList.fold_left convert_to_exp [] fsel') in
let rec iter_pairs = function
| [] -> ()
| x:: l -> (list_iter (fun y -> add_edge (root, x, y)) l; iter_pairs l) in
| x:: l -> (IList.iter (fun y -> add_edge (root, x, y)) l; iter_pairs l) in
iter_pairs links in
let rec get_edges_sigma = function
| [] -> ()
@ -526,13 +526,13 @@ let discover_para_dll_candidates tenv p =
get_edges_strexp rec_flds root se;
get_edges_sigma sigma_rest in
let rec find_all_consecutive_edges found edges_seen = function
| [] -> list_rev found
| [] -> IList.rev found
| (iF, blink, flink) :: edges_notseen ->
let edges_others = (list_rev edges_seen) @ edges_notseen in
let edges_matched = list_filter (fun (e1', _, _) -> Sil.exp_equal flink e1') edges_others in
let edges_others = (IList.rev edges_seen) @ edges_notseen in
let edges_matched = IList.filter (fun (e1', _, _) -> Sil.exp_equal flink e1') edges_others in
let new_found =
let f found_acc (_, _, flink2) = (iF, blink, flink, flink2) :: found_acc in
list_fold_left f found edges_matched in
IList.fold_left f found edges_matched in
let new_edges_seen = (iF, blink, flink) :: edges_seen in
find_all_consecutive_edges new_found new_edges_seen edges_notseen in
let sigma = Prop.get_sigma p in
@ -542,12 +542,12 @@ let discover_para_dll_candidates tenv p =
let discover_para tenv p =
let candidates = discover_para_candidates tenv p in
let already_defined para paras =
list_exists (fun para' -> Match.hpara_iso para para') paras in
IList.exists (fun para' -> Match.hpara_iso para para') paras in
let f paras (root, next, out) =
match (discover_para_roots p root next next out) with
| None -> paras
| Some para -> if already_defined para paras then paras else para :: paras in
list_fold_left f [] candidates
IList.fold_left f [] candidates
let discover_para_dll tenv p =
(*
@ -556,12 +556,12 @@ let discover_para_dll tenv p =
*)
let candidates = discover_para_dll_candidates tenv p in
let already_defined para paras =
list_exists (fun para' -> Match.hpara_dll_iso para para') paras in
IList.exists (fun para' -> Match.hpara_dll_iso para para') paras in
let f paras (iF, oB, iF', oF) =
match (discover_para_dll_roots p iF oB iF' iF' iF oF) with
| None -> paras
| Some para -> if already_defined para paras then paras else para :: paras in
list_fold_left f [] candidates
IList.fold_left f [] candidates
(****************** Start of Predicate Discovery ******************)
(****************** Start of the ADT abs_rules ******************)
@ -572,12 +572,12 @@ type rule_set = para_ty * rule list
type abs_rules = { mutable ar_default : rule_set list }
let eqs_sub subst eqs =
list_map (fun (e1, e2) -> (Sil.exp_sub subst e1, Sil.exp_sub subst e2)) eqs
IList.map (fun (e1, e2) -> (Sil.exp_sub subst e1, Sil.exp_sub subst e2)) eqs
let eqs_solve ids_in eqs_in =
let rec solve (sub: Sil.subst) (eqs: (Sil.exp * Sil.exp) list) : Sil.subst option =
let do_default id e eqs_rest =
if not (list_exists (fun id' -> Ident.equal id id') ids_in) then None
if not (IList.exists (fun id' -> Ident.equal id id') ids_in) then None
else
let sub' = match Sil.extend_sub sub id e with
| None -> L.out "@.@.ERROR : Buggy Implementation.@.@."; assert false
@ -602,10 +602,10 @@ let eqs_solve ids_in eqs_in =
| _ :: _ -> None in
let compute_ids sub =
let sub_list = Sil.sub_to_list sub in
let sub_dom = list_map fst sub_list in
let sub_dom = IList.map fst sub_list in
let filter id =
not (list_exists (fun id' -> Ident.equal id id') sub_dom) in
list_filter filter ids_in in
not (IList.exists (fun id' -> Ident.equal id id') sub_dom) in
IList.filter filter ids_in in
match solve Sil.sub_empty eqs_in with
| None -> None
| Some sub -> Some (compute_ids sub, sub)
@ -613,7 +613,7 @@ let eqs_solve ids_in eqs_in =
let sigma_special_cases_eqs sigma =
let rec f ids_acc eqs_acc sigma_acc = function
| [] ->
[(list_rev ids_acc, list_rev eqs_acc, list_rev sigma_acc)]
[(IList.rev ids_acc, IList.rev eqs_acc, IList.rev sigma_acc)]
| Sil.Hpointsto _ as hpred :: sigma_rest ->
f ids_acc eqs_acc (hpred:: sigma_acc) sigma_rest
| Sil.Hlseg(k, para, e1, e2, es) as hpred :: sigma_rest ->
@ -644,19 +644,19 @@ let sigma_special_cases ids sigma : (Ident.t list * Sil.hpred list) list =
match (eqs_solve ids_all eqs_cur) with
| None -> acc
| Some (ids_res, sub) ->
(ids_res, list_map (Sil.hpred_sub sub) sigma_cur) :: acc in
list_fold_left f [] special_cases_eqs in
list_rev special_cases_rev
(ids_res, IList.map (Sil.hpred_sub sub) sigma_cur) :: acc in
IList.fold_left f [] special_cases_eqs in
IList.rev special_cases_rev
let hpara_special_cases hpara : Sil.hpara list =
let update_para (evars', body') = { hpara with Sil.evars = evars'; Sil.body = body'} in
let special_cases = sigma_special_cases hpara.Sil.evars hpara.Sil.body in
list_map update_para special_cases
IList.map update_para special_cases
let hpara_special_cases_dll hpara : Sil.hpara_dll list =
let update_para (evars', body') = { hpara with Sil.evars_dll = evars'; Sil.body_dll = body'} in
let special_cases = sigma_special_cases hpara.Sil.evars_dll hpara.Sil.body_dll in
list_map update_para special_cases
IList.map update_para special_cases
let abs_rules : abs_rules = { ar_default = [] }
@ -694,9 +694,9 @@ let abs_rules_apply_rsets (rsets: rule_set list) (p_in: Prop.normal Prop.t) : Pr
(true, p') in
let rec apply_rule_set p rset =
let (_, rules) = rset in
let (changed, p') = list_fold_left apply_rule (false, p) rules in
let (changed, p') = IList.fold_left apply_rule (false, p) rules in
if changed then apply_rule_set p' rset else p' in
list_fold_left apply_rule_set p_in rsets
IList.fold_left apply_rule_set p_in rsets
let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
let new_rsets = ref [] in
@ -705,16 +705,16 @@ 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 = list_flatten (list_map hpara_special_cases paras_sll) in
let closed_paras_dll = list_flatten (list_map hpara_special_cases_dll paras_dll) 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
begin
(*
if list_length closed_paras_sll >= 1 then
if IList.length closed_paras_sll >= 1 then
begin
L.out "@.... discovered predicates ....@.";
L.out "@[<4> pred : %a@\n@." pp_hpara_list closed_paras_sll;
end
if list_length closed_paras_dll >= 1 then
if IList.length closed_paras_dll >= 1 then
begin
L.out "@.... discovered predicates ....@.";
L.out "@[<4> pred : %a@\n@." pp_hpara_dll_list closed_paras_dll;
@ -726,15 +726,15 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
let eq_sll para = function (SLL para', _) -> Match.hpara_iso para para' | _ -> false in
let eq_dll para = function (DLL para', _) -> Match.hpara_dll_iso para para' | _ -> false in
let filter_sll para =
not (list_exists (eq_sll para) def_rsets) && not (list_exists (eq_sll para) !new_rsets) in
not (IList.exists (eq_sll para) def_rsets) && not (IList.exists (eq_sll para) !new_rsets) in
let filter_dll para =
not (list_exists (eq_dll para) def_rsets) && not (list_exists (eq_dll para) !new_rsets) in
let todo_paras_sll = list_filter filter_sll closed_paras_sll in
let todo_paras_dll = list_filter filter_dll closed_paras_dll in
not (IList.exists (eq_dll para) def_rsets) && not (IList.exists (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
(todo_paras_sll, todo_paras_dll) in
let f_recurse () =
let todo_rsets_sll = list_map (fun para -> (SLL para, mk_rules_for_sll para)) todo_paras_sll in
let todo_rsets_dll = list_map (fun para -> (DLL para, mk_rules_for_dll para)) todo_paras_dll in
let todo_rsets_sll = IList.map (fun para -> (SLL para, mk_rules_for_sll para)) todo_paras_sll in
let todo_rsets_dll = IList.map (fun para -> (DLL para, mk_rules_for_dll para)) todo_paras_dll in
new_rsets := !new_rsets @ todo_rsets_sll @ todo_rsets_dll;
let p' = abs_rules_apply_rsets todo_rsets_sll p in
let p'' = abs_rules_apply_rsets todo_rsets_dll p' in
@ -771,7 +771,7 @@ let is_simply_recursive tenv tname =
None
| Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) ->
begin
match (list_filter filter fld_typ_ann_list) with
match (IList.filter filter fld_typ_ann_list) with
| [(fld, _, _)] -> Some fld
| _ -> None
end
@ -784,14 +784,14 @@ let create_hpara_from_tname_flds tenv tname nfld sflds eflds inst =
| None -> assert false in
let id_base = Ident.create_fresh Ident.kprimed in
let id_next = Ident.create_fresh Ident.kprimed in
let ids_shared = list_map (fun _ -> Ident.create_fresh Ident.kprimed) sflds in
let ids_exist = list_map (fun _ -> Ident.create_fresh Ident.kprimed) eflds in
let ids_shared = IList.map (fun _ -> Ident.create_fresh Ident.kprimed) sflds in
let ids_exist = IList.map (fun _ -> Ident.create_fresh Ident.kprimed) eflds in
let exp_base = Sil.Var id_base in
let fld_sexps =
let ids = id_next :: (ids_shared @ ids_exist) in
let flds = nfld :: (sflds @ eflds) in
let f fld id = (fld, Sil.Eexp (Sil.Var id, inst)) in
try list_map2 f flds ids with Invalid_argument _ -> assert false in
try IList.map2 f flds ids with Invalid_argument _ -> assert false in
let strexp_para = Sil.Estruct (fld_sexps, inst) in
let ptsto_para = Prop.mk_ptsto exp_base strexp_para (Sil.Sizeof (typ, Sil.Subtype.exact)) in
Prop.mk_hpara id_base id_next ids_shared ids_exist [ptsto_para]
@ -803,14 +803,14 @@ let create_dll_hpara_from_tname_flds tenv tname flink blink sflds eflds inst =
let id_iF = Ident.create_fresh Ident.kprimed in
let id_oB = Ident.create_fresh Ident.kprimed in
let id_oF = Ident.create_fresh Ident.kprimed in
let ids_shared = list_map (fun _ -> Ident.create_fresh Ident.kprimed) sflds in
let ids_exist = list_map (fun _ -> Ident.create_fresh Ident.kprimed) eflds in
let ids_shared = IList.map (fun _ -> Ident.create_fresh Ident.kprimed) sflds in
let ids_exist = IList.map (fun _ -> Ident.create_fresh Ident.kprimed) eflds in
let exp_iF = Sil.Var id_iF in
let fld_sexps =
let ids = id_oF:: id_oB :: (ids_shared @ ids_exist) in
let flds = flink:: blink:: (sflds @ eflds) in
let f fld id = (fld, Sil.Eexp (Sil.Var id, inst)) in
try list_map2 f flds ids with Invalid_argument _ -> assert false in
try IList.map2 f flds ids with Invalid_argument _ -> assert false in
let strexp_para = Sil.Estruct (fld_sexps, inst) in
let ptsto_para = Prop.mk_ptsto exp_iF strexp_para (Sil.Sizeof (typ, Sil.Subtype.exact)) in
Prop.mk_dll_hpara id_iF id_oB id_oF ids_shared ids_exist [ptsto_para]
@ -831,7 +831,7 @@ let create_hpara_two_ptsto tname1 tenv nfld1 dfld tname2 nfld2 inst =
let ids = [id_next; id_exist] in
let flds = [nfld1; dfld] in
let f fld id = (fld, Sil.Eexp (Sil.Var id, inst)) in
try list_map2 f flds ids with Invalid_argument _ -> assert false in
try IList.map2 f flds ids with Invalid_argument _ -> assert false in
let fld_sexps2 =
[(nfld2, Sil.Eexp (Sil.exp_zero, inst))] in
let strexp_para1 = Sil.Estruct (fld_sexps1, inst) in
@ -857,7 +857,7 @@ let create_hpara_dll_two_ptsto tenv tname1 flink_fld1 blink_fld1 dfld tname2 nfl
let ids = [ id_blink; id_flink; id_exist] in
let flds = [ blink_fld1; flink_fld1; dfld] in
let f fld id = (fld, Sil.Eexp (Sil.Var id, inst)) in
try list_map2 f flds ids with Invalid_argument _ -> assert false in
try IList.map2 f flds ids with Invalid_argument _ -> assert false in
let fld_sexps2 =
[(nfld2, Sil.Eexp (Sil.exp_zero, inst))] in
let strexp_para1 = Sil.Estruct (fld_sexps1, inst) in
@ -917,7 +917,7 @@ let create_absrules_from_tdecl tenv tname =
let para2 = create_hpara_from_tname_flds tenv tname_HSlist2 name_next [name_down] [] Sil.inst_abstraction in
let para_nested = create_hpara_from_tname_twoflds_hpara tenv tname_HSlist2 name_next name_down para1 Sil.inst_abstraction in
let para_nested_base = create_hpara_two_ptsto tname_HSlist2 tenv name_next name_down tname_list name_down Sil.inst_abstraction in
list_iter abs_rules_add_sll [para_nested_base; para2; para_nested]
IList.iter abs_rules_add_sll [para_nested_base; para2; para_nested]
else if (not (!Config.on_the_fly)) && Sil.typename_equal tname tname_dllist then
(* L.out "@[.... Adding Abstraction Rules for Doubly-linked Lists ....@\n@."; *)
let para = create_dll_hpara_from_tname_flds tenv tname_dllist name_Flink name_Blink [] [] Sil.inst_abstraction in
@ -928,7 +928,7 @@ let create_absrules_from_tdecl tenv tname =
let para2 = create_dll_hpara_from_tname_flds tenv tname_HOdllist name_Flink name_Blink [name_down] [] Sil.inst_abstraction in
let para_nested = create_hpara_dll_from_tname_twoflds_hpara tenv tname_HOdllist name_Flink name_Blink name_down para1 Sil.inst_abstraction in
let para_nested_base = create_hpara_dll_two_ptsto tenv tname_HOdllist name_Flink name_Blink name_down tname_list name_down Sil.inst_abstraction in
list_iter abs_rules_add_dll [para_nested_base; para2; para_nested]
IList.iter abs_rules_add_dll [para_nested_base; para2; para_nested]
else if (not (!Config.on_the_fly)) then
match is_simply_recursive tenv tname with
| None -> ()
@ -952,9 +952,9 @@ let abstract_pure_part 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
list_filter filter pure in
IList.filter filter pure in
let new_pure =
list_fold_left
IList.fold_left
(fun pi a ->
match a with
| Sil.Aneq (Sil.Var name, _) -> a:: pi
@ -971,7 +971,7 @@ let abstract_pure_part p ~(from_abstract_footprint: bool) =
| _ -> pi)
| _ -> pi)
[] pi_filtered in
list_rev new_pure in
IList.rev new_pure in
let new_pure = do_pure (Prop.get_pure p) in
let eprop' = Prop.replace_pi new_pure (Prop.replace_sub Sil.sub_empty p) in
@ -989,17 +989,17 @@ let abstract_gc p =
let fav_p_without_pi = Prop.prop_fav p_without_pi in
(* let weak_filter atom =
let fav_atom = atom_fav atom in
list_intersect compare fav_p_without_pi fav_atom in *)
IList.intersect compare fav_p_without_pi fav_atom in *)
let strong_filter = function
| Sil.Aeq(e1, e2) | Sil.Aneq(e1, e2) ->
let fav_e1 = Sil.exp_fav e1 in
let fav_e2 = Sil.exp_fav e2 in
let intersect_e1 _ = list_intersect Ident.compare (Sil.fav_to_list fav_e1) (Sil.fav_to_list fav_p_without_pi) in
let intersect_e2 _ = list_intersect Ident.compare (Sil.fav_to_list fav_e2) (Sil.fav_to_list fav_p_without_pi) in
let intersect_e1 _ = IList.intersect Ident.compare (Sil.fav_to_list fav_e1) (Sil.fav_to_list fav_p_without_pi) in
let intersect_e2 _ = IList.intersect Ident.compare (Sil.fav_to_list fav_e2) (Sil.fav_to_list fav_p_without_pi) in
let no_fav_e1 = Sil.fav_is_empty fav_e1 in
let no_fav_e2 = Sil.fav_is_empty fav_e2 in
(no_fav_e1 || intersect_e1 ()) && (no_fav_e2 || intersect_e2 ()) in
let new_pi = list_filter strong_filter pi in
let new_pi = IList.filter strong_filter pi in
let prop = Prop.normalize (Prop.replace_pi new_pi p) in
match Prop.prop_iter_create prop with
| None -> prop
@ -1025,8 +1025,8 @@ let sigma_reachable root_fav sigma =
let do_hpred hpred =
let hp_fav_set = fav_to_set (Sil.hpred_fav hpred) in
let add_entry e = edges := (e, hp_fav_set) :: !edges in
list_iter add_entry (hpred_entries hpred) in
list_iter do_hpred sigma;
IList.iter add_entry (hpred_entries hpred) in
IList.iter do_hpred sigma;
let edge_fires (e, _) = match e with
| Sil.Var id ->
if (Ident.is_primed id || Ident.is_footprint id) then Ident.IdentSet.mem id !reach_set
@ -1056,14 +1056,14 @@ let get_cycle root prop =
match e with
| Sil.Eexp(e', _) ->
(try
Some(list_find (fun hpred -> match hpred with
Some(IList.find (fun hpred -> match hpred with
| Sil.Hpointsto(e'', _, _) -> Sil.exp_equal e'' e'
| _ -> false) sigma)
with _ -> None)
| _ -> None in
let print_cycle cyc =
(L.d_str "Cycle= ";
list_iter (fun ((e, t), f, e') ->
IList.iter (fun ((e, t), f, e') ->
match e, e' with
| Sil.Eexp (e, _), Sil.Eexp (e', _) ->
L.d_str ("("^(Sil.exp_to_string e)^": "^(Sil.typ_to_string t)^", "^(Ident.fieldname_to_string f)^", "^(Sil.exp_to_string e')^")")
@ -1078,7 +1078,7 @@ let get_cycle root prop =
| (f, e):: el' ->
if Sil.strexp_equal e e_root then
(et_src, f, e):: path, true
else if list_mem Sil.strexp_equal e visited then
else if IList.mem Sil.strexp_equal e visited then
path, false
else (
let visited' = (fst et_src):: visited in
@ -1115,10 +1115,10 @@ let reachable_when_in_several_hpreds sigma : Ident.t -> bool =
let add_hpred hpred =
let fav = Sil.fav_new () in
Sil.hpred_fav_add fav hpred;
list_iter (fun id -> add_id_hpred id hpred) (Sil.fav_to_list fav) in
IList.iter (fun id -> add_id_hpred id hpred) (Sil.fav_to_list fav) in
let id_in_several_hpreds id =
HpredSet.cardinal (IdMap.find id !id_hpred_map) > 1 in
list_iter add_hpred sigma;
IList.iter add_hpred sigma;
id_in_several_hpreds
@ -1160,11 +1160,11 @@ let get_var_retain_cycle _prop =
| _, _ -> false in
let find_pvar v =
try
let hp = list_find (is_pvar v) sigma in
let hp = IList.find (is_pvar v) sigma in
Some (Sil.hpred_get_lhs hp)
with Not_found -> None in
let find_block v =
if (list_exists (is_hpred_block v) sigma) then
if (IList.exists (is_hpred_block v) sigma) then
Some (Sil.Lvar Sil.block_pvar)
else None in
let sexp e = Sil.Eexp (e, Sil.Inone) in
@ -1184,7 +1184,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' = list_flatten (list_map find_pvar_or_block cycle) in
let cycle' = IList.flatten (IList.map find_pvar_or_block cycle) in
if cycle' = [] then do_sigma sigma'
else cycle' in
do_sigma sigma
@ -1202,7 +1202,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
match t with
| Sil.Tstruct(nsf, sf, _, _, _, _, _) ->
let ia = ref [] in
list_iter (fun (fn', t', ia') ->
IList.iter (fun (fn', t', ia') ->
if Ident.fieldname_equal fn fn' then ia := ia') (nsf@sf);
!ia
| _ -> [] in
@ -1219,7 +1219,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
| [] -> false
| ((e, t), fn, _):: c' ->
let ia = get_item_annotation t fn in
if (list_exists do_annotation ia) then true
if (IList.exists do_annotation ia) then true
else do_cycle c' in
do_cycle cycle
@ -1239,7 +1239,7 @@ let check_junk ?original_prop pname tenv prop =
(Ident.is_primed id || Ident.is_footprint id)
&& not (Sil.fav_mem fav_root id) && not (id_considered_reachable id)
| _ -> false in
list_for_all predicate entries in
IList.for_all predicate entries in
let hpred_in_cycle hpred = (* check if the predicate belongs to a cycle in the heap *)
let id_in_cycle id =
let set1 = sigma_reachable (Sil.fav_from_list [id]) sigma in
@ -1257,10 +1257,10 @@ let check_junk ?original_prop pname tenv prop =
Sil.strexp_fav_add fav se;
Sil.fav_mem fav id
| _ -> false in
hpred_is_loop || list_exists predicate entries in
hpred_is_loop || IList.exists predicate entries in
let rec remove_junk_recursive sigma_done sigma_todo =
match sigma_todo with
| [] -> list_rev sigma_done
| [] -> IList.rev sigma_done
| hpred :: sigma_todo' ->
let entries = hpred_entries hpred in
if should_remove_hpred entries then
@ -1286,7 +1286,7 @@ let check_junk ?original_prop pname tenv prop =
| Some (Sil.Aundef _ as a) ->
res := Some a
| _ -> ()) in
list_iter do_entry entries;
IList.iter do_entry entries;
!res in
L.d_decrease_indent 1;
let is_undefined = Option.map_default Sil.attr_is_undef false alloc_attribute in
@ -1344,7 +1344,7 @@ let check_junk ?original_prop pname tenv prop =
| None, Some _ -> false in
(alloc_attribute = None && !leaks_reported <> []) ||
(* None attribute only reported if it's the first one *)
list_mem attr_opt_equal alloc_attribute !leaks_reported in
IList.mem attr_opt_equal alloc_attribute !leaks_reported in
let ignore_leak =
!Config.allowleak || ignore_resource || is_undefined || already_reported () in
let report_and_continue =
@ -1364,7 +1364,7 @@ let check_junk ?original_prop pname tenv prop =
remove_junk_recursive [] sigma in
let rec remove_junk fp_part fav_root sigma = (* call remove_junk_once until sigma stops shrinking *)
let sigma' = remove_junk_once fp_part fav_root sigma in
if list_length sigma' = list_length sigma then sigma'
if IList.length sigma' = IList.length sigma then sigma'
else remove_junk fp_part fav_root sigma' in
let sigma_new = remove_junk false fav_sub_sigmafp (Prop.get_sigma prop) in
let sigma_fp_new = remove_junk true (Sil.fav_new ()) (Prop.get_sigma_footprint prop) in
@ -1408,12 +1408,12 @@ let get_local_stack cur_sigma init_sigma =
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> pvar
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> assert false in
let filter_local_stack old_pvars = function
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not (list_exists (Sil.pvar_equal pvar) old_pvars)
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not (IList.exists (Sil.pvar_equal pvar) old_pvars)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> false in
let init_stack = list_filter filter_stack init_sigma in
let init_stack_pvars = list_map get_stack_var init_stack in
let cur_local_stack = list_filter (filter_local_stack init_stack_pvars) cur_sigma in
let cur_local_stack_pvars = list_map get_stack_var cur_local_stack in
let init_stack = IList.filter 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_pvars = IList.map get_stack_var cur_local_stack in
(cur_local_stack, cur_local_stack_pvars)
(** Extract the footprint, add a local stack and return it as a prop *)
@ -1428,9 +1428,9 @@ let extract_footprint_for_abs (p : 'a Prop.t) : Prop.exposed Prop.t * Sil.pvar l
let remove_local_stack sigma pvars =
let filter_non_stack = function
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not (list_exists (Sil.pvar_equal pvar) pvars)
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not (IList.exists (Sil.pvar_equal pvar) pvars)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> true in
list_filter filter_non_stack sigma
IList.filter 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]. *)

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

@ -67,11 +67,11 @@ end = struct
match se, t, syn_offs with
| _, _, [] -> (se, t)
| Sil.Estruct (fsel, _), Sil.Tstruct (ftal, sftal, _, _, _, _, _), Field (fld, _) :: syn_offs' ->
let se' = snd (list_find (fun (f', se') -> Sil.fld_equal f' fld) fsel) in
let t' = (fun (x,y,z) -> y) (list_find (fun (f', t', a') -> Sil.fld_equal f' fld) ftal) in
let se' = snd (IList.find (fun (f', se') -> Sil.fld_equal f' fld) fsel) in
let t' = (fun (x,y,z) -> y) (IList.find (fun (f', t', a') -> Sil.fld_equal f' fld) ftal) in
get_strexp_at_syn_offsets se' t' syn_offs'
| Sil.Earray (size, esel, _), Sil.Tarray(t', _), Index ind :: syn_offs' ->
let se' = snd (list_find (fun (i', se') -> Sil.exp_equal i' ind) esel) in
let se' = snd (IList.find (fun (i', se') -> Sil.exp_equal i' ind) esel) in
get_strexp_at_syn_offsets se' t' syn_offs'
| _ ->
L.d_strln "Failure of get_strexp_at_syn_offsets";
@ -85,15 +85,15 @@ end = struct
| _, _, [] ->
update se t
| Sil.Estruct (fsel, inst), Sil.Tstruct (ftal, sftal, _, _, _, _, _), Field (fld, _) :: syn_offs' ->
let se' = snd (list_find (fun (f', _) -> Sil.fld_equal f' fld) fsel) in
let t' = (fun (x,y,z) -> y) (list_find (fun (f', _, _) -> Sil.fld_equal f' fld) ftal) in
let se' = snd (IList.find (fun (f', _) -> Sil.fld_equal f' fld) fsel) in
let t' = (fun (x,y,z) -> y) (IList.find (fun (f', _, _) -> Sil.fld_equal f' fld) ftal) in
let se_mod = replace_strexp_at_syn_offsets se' t' syn_offs' update in
let fsel' = list_map (fun (f'', se'') -> if Sil.fld_equal f'' fld then (fld, se_mod) else (f'', se'')) fsel in
let fsel' = IList.map (fun (f'', se'') -> if Sil.fld_equal f'' fld then (fld, se_mod) else (f'', se'')) fsel in
Sil.Estruct (fsel', inst)
| Sil.Earray (size, esel, inst), Sil.Tarray (t', _), Index idx :: syn_offs' ->
let se' = snd (list_find (fun (i', _) -> Sil.exp_equal i' idx) esel) in
let se' = snd (IList.find (fun (i', _) -> Sil.exp_equal i' idx) esel) in
let se_mod = replace_strexp_at_syn_offsets se' t' syn_offs' update in
let esel' = list_map (fun ese -> if Sil.exp_equal (fst ese) idx then (idx, se_mod) else ese) esel in
let esel' = IList.map (fun ese -> if Sil.exp_equal (fst ese) idx then (idx, se_mod) else ese) esel in
Sil.Earray (size, esel', inst)
| _ -> assert false
@ -102,10 +102,10 @@ end = struct
let rec convert acc = function
| [] -> acc
| Field (f, t) :: syn_offs' ->
let acc' = list_map (fun e -> Sil.Lfield (e, f, t)) acc in
let acc' = IList.map (fun e -> Sil.Lfield (e, f, t)) acc in
convert acc' syn_offs'
| Index idx :: syn_offs' ->
let acc' = list_map (fun e -> Sil.Lindex (e, idx)) acc in
let acc' = IList.map (fun e -> Sil.Lindex (e, idx)) acc in
convert acc' syn_offs' in
begin
convert [root] syn_offs_in
@ -116,7 +116,7 @@ end = struct
let offset_to_syn_offset = function
| Sil.Off_fld (fld, typ) -> Field (fld, typ)
| Sil.Off_index idx -> Index idx in
let syn_offs = list_map offset_to_syn_offset offs in
let syn_offs = IList.map offset_to_syn_offset offs in
(root, syn_offs)
(** path to the root, size, elements and type of a new_array *)
@ -130,14 +130,14 @@ end = struct
let filter = function
| Sil.Hpointsto (e, _, _) -> Sil.exp_equal root e
| _ -> false in
let hpred = list_find filter sigma in
let hpred = IList.find filter sigma in
(sigma, hpred, syn_offs)
(** Find a sub strexp with the given property. Can raise [Not_found] *)
let find (sigma : sigma) (pred : sigma -> strexp_data -> bool) : t list =
let found = ref [] in
let rec find_offset_sexp sigma_other hpred root offs se typ =
let offs' = list_rev offs in
let offs' = IList.rev offs in
let path = (root, offs') in
if pred sigma_other (path, se, typ) then found := (sigma, hpred, offs') :: !found
else begin
@ -153,7 +153,7 @@ end = struct
| (f, se) :: fsel' ->
begin
try
let t = (fun (x,y,z) -> y) (list_find (fun (f', t, a) -> Sil.fld_equal f' f) ftal) in
let t = (fun (x,y,z) -> y) (IList.find (fun (f', t, a) -> Sil.fld_equal 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")
@ -193,12 +193,12 @@ end = struct
(** 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 = list_filter (fun hpred' -> not (hpred' == hpred)) sigma in
let sigma_unmatched = IList.filter (fun hpred' -> not (hpred' == hpred)) sigma in
(sigma_unmatched, hpred)
(** Replace the current hpred *)
let replace_hpred ((sigma, hpred, syn_offs) : t) hpred' =
list_map (fun hpred'' -> if hpred''== hpred then hpred' else hpred'') sigma
IList.map (fun hpred'' -> if hpred''== hpred then hpred' else hpred'') sigma
(** Replace the strexp at the given offset in the given hpred *)
let hpred_replace_strexp footprint_part hpred syn_offs update =
@ -206,11 +206,11 @@ end = struct
let se_in = update se' t' in
match se', se_in with
| Sil.Earray (size, esel, inst1), Sil.Earray (_, esel_in, inst2) ->
let orig_indices = list_map fst esel in
let index_is_not_new idx = list_exists (Sil.exp_equal idx) orig_indices in
let orig_indices = IList.map fst esel in
let index_is_not_new idx = IList.exists (Sil.exp_equal idx) orig_indices in
let process_index idx =
if index_is_not_new idx then idx else (Sil.array_clean_new_index footprint_part idx) in
let esel_in' = list_map (fun (idx, se) -> process_index idx, se) esel_in in
let esel_in' = IList.map (fun (idx, se) -> process_index idx, se) esel_in in
Sil.Earray (size, esel_in', inst2)
| _, _ -> se_in in
begin
@ -232,14 +232,14 @@ end = struct
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 footprint_part (new_sigma, hpred, syn_offs) se_in in
list_sort Sil.hpred_compare sigma'
IList.sort Sil.hpred_compare sigma'
(** Replace the index in the array at a given position with the new index *)
let replace_index footprint_part ((sigma, hpred, syn_offs) : t) (index: Sil.exp) (index': Sil.exp) =
let update se' t' =
match se' with
| Sil.Earray (size, esel, inst) ->
let esel' = list_map (fun (e', se') -> if Sil.exp_equal e' index then (index', se') else (e', se')) esel in
let esel' = IList.map (fun (e', se') -> if Sil.exp_equal e' index then (index', se') else (e', se')) esel in
Sil.Earray (size, esel', inst)
| _ -> assert false in
let hpred' = hpred_replace_strexp footprint_part hpred syn_offs update in
@ -255,8 +255,8 @@ let prop_replace_path_index
=
let elist_path = StrexpMatch.path_to_exps path in
let expmap_list =
list_fold_left (fun acc_outer e_path ->
list_fold_left (fun acc_inner (old_index, new_index) ->
IList.fold_left (fun acc_outer e_path ->
IList.fold_left (fun acc_inner (old_index, new_index) ->
let old_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, old_index)) in
let new_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, new_index)) in
(old_e_path_index, new_e_path_index) :: acc_inner
@ -264,7 +264,7 @@ let prop_replace_path_index
) [] elist_path in
let expmap_fun e' =
try
let _, fresh_e = list_find (fun (e, _) -> Sil.exp_equal e e') expmap_list in
let _, fresh_e = IList.find (fun (e, _) -> Sil.exp_equal e e') expmap_list in
fresh_e
with Not_found -> e' in
Prop.prop_expmap expmap_fun p
@ -337,7 +337,7 @@ let generic_strexp_abstract
let rec match_abstract p0 matchings_cur_fp =
try
let matched, footprint_part, matchings_cur_fp' = match_select_next matchings_cur_fp in
let n = list_length (snd matchings_cur_fp') + 1 in
let n = IList.length (snd matchings_cur_fp') + 1 in
if !Config.trace_absarray then (L.d_strln ("Num of fp candidates " ^ (string_of_int n)));
let strexp_data = StrexpMatch.get_data matched in
let p1, changed = do_abstract footprint_part p0 strexp_data in
@ -354,7 +354,7 @@ let generic_strexp_abstract
if changed then find_then_abstract (bound - 1) p1 else p0
end in
let matchings_cur, matchings_fp = find_strexp_to_abstract p_in in
let num_matches = (list_length matchings_cur) + (list_length matchings_fp) in
let num_matches = (IList.length matchings_cur) + (IList.length matchings_fp) in
begin
find_then_abstract num_matches p_in
end
@ -368,12 +368,12 @@ let index_is_pointed_to (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index:
let add_index_to_paths =
let elist_path = StrexpMatch.path_to_exps path in
let add_index i e = Prop.exp_normalize_prop p (Sil.Lindex(e, i)) in
fun i -> list_map (add_index i) elist_path in
let pointers = list_flatten (list_map add_index_to_paths indices) in
fun i -> IList.map (add_index i) elist_path in
let pointers = IList.flatten (IList.map add_index_to_paths indices) in
let filter = function
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) -> list_exists (Sil.exp_equal e) pointers
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) -> IList.exists (Sil.exp_equal e) pointers
| _ -> false in
list_exists filter (Prop.get_sigma p)
IList.exists filter (Prop.get_sigma p)
(** Given [p] containing an array at [path], blur [index] in it *)
@ -417,7 +417,7 @@ let blur_array_indices
(indices: Sil.exp list) : Prop.normal Prop.t * bool
=
let f prop index = blur_array_index footprint_part prop root index in
(list_fold_left f p indices, list_length indices > 0)
(IList.fold_left f p indices, IList.length indices > 0)
(** Given [p] containing an array at [root], only keep [indices] in it *)
@ -433,7 +433,7 @@ let keep_only_indices
let (_, se, _) = StrexpMatch.get_data matched in
match se with
| Sil.Earray (size, esel, inst) ->
let esel', esel_leftover' = list_partition (fun (e, _) -> list_exists (Sil.exp_equal e) indices) esel in
let esel', esel_leftover' = IList.partition (fun (e, _) -> IList.exists (Sil.exp_equal e) indices) esel in
if esel_leftover' == [] then (sigma, false)
else begin
let se' = Sil.Earray (size, esel', inst) in
@ -454,7 +454,7 @@ let array_typ_can_abstract = function
let strexp_can_abstract sigma_rest ((_, se, typ) : StrexpMatch.strexp_data) : bool =
let can_abstract_se = match se with
| Sil.Earray (size, esel, _) ->
let len = list_length esel in
let len = IList.length esel in
len > 1
| _ -> false in
can_abstract_se && array_typ_can_abstract typ
@ -482,9 +482,9 @@ let strexp_do_abstract footprint_part p ((path, se_in, typ_in) : StrexpMatch.str
(blur_array_indices footprint_part) in
let partition_abstract should_keep abstract ksel default_keys =
let keep_ksel, remove_ksel = list_partition should_keep ksel in
let keep_ksel, remove_ksel = IList.partition should_keep ksel in
let keep_keys, remove_keys, keys =
list_map fst keep_ksel, list_map fst remove_ksel, list_map fst ksel in
IList.map fst keep_ksel, IList.map fst remove_ksel, IList.map fst ksel in
let keep_keys' = if keep_keys == [] then default_keys else keep_keys in
abstract keep_keys' keep_keys' in
let do_array_footprint esel =
@ -492,9 +492,9 @@ let strexp_do_abstract footprint_part p ((path, se_in, typ_in) : StrexpMatch.str
let should_keep (i0, _) = index_is_pointed_to p path i0 in
let abstract = prune_and_blur_indices path in
let default_indices =
match list_map fst esel with
match IList.map fst esel with
| [] -> []
| indices -> [list_hd (list_rev indices)] (* keep last key at least *) in
| indices -> [IList.hd (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
@ -502,8 +502,8 @@ let strexp_do_abstract footprint_part p ((path, se_in, typ_in) : StrexpMatch.str
| _ -> assert false in
let filter_abstract d_keys should_keep abstract ksel default_keys =
let keep_ksel = list_filter should_keep ksel in
let keep_keys = list_map fst keep_ksel in
let keep_ksel = IList.filter should_keep ksel in
let keep_keys = IList.map fst keep_ksel in
let keep_keys' = if 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 ());
abstract keep_keys' [] in
@ -553,12 +553,12 @@ let check_after_array_abstraction prop =
| Sil.Eexp _ -> ()
| Sil.Earray (_, esel, _) -> (* check that no more than 2 elements are in the array *)
let typ_elem = Sil.array_typ_elem (Some Sil.Tvoid) typ in
if list_length esel > 2 && array_typ_can_abstract typ then
if list_for_all (check_index root offs) esel then ()
if IList.length esel > 2 && array_typ_can_abstract typ then
if IList.for_all (check_index root offs) esel then ()
else report_error prop
else list_iter (fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) esel
else IList.iter (fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) esel
| Sil.Estruct (fsel, _) ->
list_iter (fun (f, se) ->
IList.iter (fun (f, se) ->
let typ_f = Sil.struct_typ_fld (Some Sil.Tvoid) f typ in
check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in
let check_hpred = function
@ -566,7 +566,7 @@ let check_after_array_abstraction prop =
let typ = Sil.texp_to_typ (Some Sil.Tvoid) texp in
check_se root [] typ se
| Sil.Hlseg _ | Sil.Hdllseg _ -> () in
let check_sigma sigma = list_iter check_hpred sigma in
let check_sigma sigma = IList.iter check_hpred sigma in
(* check_footprint_pure prop; *)
check_sigma (Prop.get_sigma prop);
check_sigma (Prop.get_sigma_footprint prop)
@ -592,9 +592,9 @@ let remove_redundant_elements prop =
let favl_curr = Sil.fav_to_list fav_curr in
let favl_foot = Sil.fav_to_list fav_foot in
Sil.fav_duplicates := false;
(* L.d_str "favl_curr "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_curr; L.d_ln();
L.d_str "favl_foot "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_foot; L.d_ln(); *)
let num_occur l id = list_length (list_filter (fun id' -> Ident.equal id id') l) in
(* L.d_str "favl_curr "; IList.iter (fun id -> Sil.d_exp (Sil.Var id)) favl_curr; L.d_ln();
L.d_str "favl_foot "; IList.iter (fun id -> Sil.d_exp (Sil.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 at_most_once v =
num_occur favl_curr v <= 1 && num_occur favl_foot v <= 1 in
at_most_once in
@ -613,7 +613,7 @@ let remove_redundant_elements prop =
| _ -> true in
let remove_redundant_se fp_part = function
| Sil.Earray (size, esel, inst) ->
let esel' = list_filter (filter_redundant_e_se fp_part) esel in
let esel' = IList.filter (filter_redundant_e_se fp_part) esel in
Sil.Earray (size, esel', inst)
| se -> se in
let remove_redundant_hpred fp_part = function
@ -621,7 +621,7 @@ let remove_redundant_elements prop =
let se' = remove_redundant_se fp_part se in
Sil.Hpointsto (e, se', te)
| hpred -> hpred in
let remove_redundant_sigma fp_part sigma = list_map (remove_redundant_hpred fp_part) sigma in
let remove_redundant_sigma fp_part sigma = IList.map (remove_redundant_hpred fp_part) sigma in
let sigma' = remove_redundant_sigma false (Prop.get_sigma prop) in
let foot_sigma' = remove_redundant_sigma true (Prop.get_sigma_footprint prop) in
if !modified then

48
infer/src/backend/autounit.ml
Unescape View File

@ -57,7 +57,7 @@ end = struct
let ev = ref IdMap.empty in
let add_var id =
ev := IdMap.add id (new_range ()) !ev in
list_iter add_var vars;
IList.iter add_var vars;
!ev
let gt_bottom i r =
@ -82,20 +82,20 @@ end = struct
(** normalize [r]: the excluded elements must be strictly between bottom and top *)
let normalize r =
r.excluded <- list_filter (fun i -> geq_bottom i r && leq_top i r) r.excluded;
r.excluded <- IList.filter (fun i -> geq_bottom i r && leq_top i r) r.excluded;
let rec normalize_bottom () = match r.bottom with
| None -> ()
| Some i ->
if list_mem Sil.Int.eq i r.excluded then begin
r.excluded <- list_filter (Sil.Int.neq i) r.excluded;
if IList.mem Sil.Int.eq i r.excluded then begin
r.excluded <- IList.filter (Sil.Int.neq i) r.excluded;
r.bottom <- Some (i ++ Sil.Int.one);
normalize_bottom ()
end in
let rec normalize_top () = match r.top with
| None -> ()
| Some i ->
if list_mem Sil.Int.eq i r.excluded then begin
r.excluded <- list_filter (Sil.Int.neq i) r.excluded;
if IList.mem Sil.Int.eq i r.excluded then begin
r.excluded <- IList.filter (Sil.Int.neq i) r.excluded;
r.top <- Some (i -- Sil.Int.one);
normalize_top ()
end in
@ -111,7 +111,7 @@ end = struct
(** exclude one element from the range *)
let add_excluded r id i =
if geq_bottom i r && leq_top i r && not (list_mem Sil.Int.eq i r.excluded)
if geq_bottom i r && leq_top i r && not (IList.mem Sil.Int.eq i r.excluded)
then begin
r.excluded <- i :: r.excluded;
normalize r;
@ -140,9 +140,9 @@ end = struct
let choose id rng =
if debug then F.fprintf F.std_formatter "choosing %a@." (pp_range id) rng;
let found = ref None in
let num_iter = list_length rng.excluded in
let num_iter = IList.length rng.excluded in
let try_candidate candidate =
if geq_bottom candidate rng && leq_top candidate rng && not (list_mem Sil.Int.eq candidate rng.excluded)
if geq_bottom candidate rng && leq_top candidate rng && not (IList.mem Sil.Int.eq candidate rng.excluded)
then (found := Some candidate; rng.bottom <- Some candidate; rng.top <- Some candidate; rng.excluded <- []) in
let search_up () =
let base = match rng.bottom with None -> Sil.Int.zero | Some n -> n in
@ -183,7 +183,7 @@ end = struct
| Sil.Aneq (e1, e2) ->
do_neq e1 e2 in
changed := false;
list_iter do_atom pi;
IList.iter do_atom pi;
if !changed then pi_iter do_le do_lt do_neq pi
(** Collect constraints on [vars] from [pi], and return a satisfying instantiation *)
@ -193,7 +193,7 @@ end = struct
let atom_is_relevant a =
let fav = Sil.atom_fav a in
Sil.fav_for_all fav (fun id -> Sil.fav_mem vars_fav id) in
let pi_relevant = list_filter atom_is_relevant pi in
let pi_relevant = IList.filter atom_is_relevant pi in
let ev = new_eval vars in
let update_top rng id n_op = match rng.top, n_op with
| Some _, Some n -> add_top rng id n
@ -259,7 +259,7 @@ end = struct
let rng = IdMap.find id ev in
pi_iter do_le do_lt do_neq pi_relevant;
choose id rng in
list_iter do_ident vars;
IList.iter do_ident vars;
if debug then F.fprintf F.std_formatter "solution to pure constraints:@.%a@." pp_eval ev;
let solution = IdMap.map (function { bottom = Some n } -> n | _ -> assert false) ev in
solution
@ -337,10 +337,10 @@ let create_idmap sigma : idmap =
| Sil.Hlseg (k, hpar, e, f, el) ->
do_lhs_e e (Sil.Tptr (Sil.Tvoid, Sil.Pk_pointer));
do_se (Sil.Eexp (f, Sil.inst_none)) (Sil.Tptr (Sil.Tvoid, Sil.Pk_pointer));
list_iter (fun e -> do_se (Sil.Eexp (e, Sil.inst_none)) Sil.Tvoid) el
IList.iter (fun e -> do_se (Sil.Eexp (e, Sil.inst_none)) Sil.Tvoid) el
| hpred ->
L.err "do_hpred not implemented %a@." (Sil.pp_hpred pe) hpred in
list_iter do_hpred sigma;
IList.iter do_hpred sigma;
!idmap
module Code : sig
@ -356,10 +356,10 @@ end = struct
type t = string list ref
let indent = ref ""
let to_list code =
list_rev !code
IList.rev !code
let pp fmt code =
let doit line = F.fprintf fmt "%s@\n" line in
list_iter doit (to_list code);
IList.iter doit (to_list code);
F.fprintf fmt "@."
let empty () = ref []
let add_line code l =
@ -420,7 +420,7 @@ let pp_texp_for_malloc fmt =
| Sil.Tptr (t, pk) ->
Sil.Tptr (handle_arr_size t, pk)
| Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) ->
Sil.Tstruct (list_map (fun (f, t, a) -> (f, handle_arr_size t, a)) ftal, sftal, csu, nameo, supers, def_mthds, iann)
Sil.Tstruct (IList.map (fun (f, t, a) -> (f, handle_arr_size t, a)) ftal, sftal, csu, nameo, supers, def_mthds, iann)
| Sil.Tarray (t, e) ->
Sil.Tarray (handle_arr_size t, e) in
function
@ -439,9 +439,9 @@ let gen_sigma code proc_name spec_num env idmap sigma =
Code.add_from_pp code' pp
| Sil.Estruct (fsel, _) ->
let accessor = if need_deref then "->" else "." in
list_iter (fun (f, se) -> do_strexp code' (base ^ accessor ^ Ident.fieldname_to_string f) false se) fsel
IList.iter (fun (f, se) -> do_strexp code' (base ^ accessor ^ Ident.fieldname_to_string f) false se) fsel
| Sil.Earray (size, esel, _) ->
list_iter (fun (e, se) ->
IList.iter (fun (e, se) ->
let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in
let index = pp_to_string pp () in
do_strexp code' (base ^ "[" ^ index ^ "]") false se) esel in
@ -474,7 +474,7 @@ let gen_sigma code proc_name spec_num env idmap sigma =
Code.add_from_pp code pp2
| hpred ->
L.err "gen_hpred not implemented: %a@." (Sil.pp_hpred pe) hpred in
list_iter gen_hpred sigma;
IList.iter gen_hpred sigma;
Code.append code post_code
(* generate code corresponding to equalities in the pure part *)
@ -484,7 +484,7 @@ let gen_init_equalities code pure =
let pp f () = F.fprintf f "%a = %a;" (pp_id_c pe) id (pp_exp_c pe) e in
Code.add_from_pp code pp
| _ -> () in
list_iter do_atom pure
IList.iter do_atom pure
(** generate variable declarations *)
let gen_var_decl code idmap parameters =
@ -496,7 +496,7 @@ let gen_var_decl code idmap parameters =
let pp_var f () = pp_id_c pe f id in
let pp f () = F.fprintf f "%a;" (Sil.pp_type_decl pe pp_var pp_exp_c) typ in
Code.add_from_pp code pp in
list_iter do_parameter parameters;
IList.iter do_parameter parameters;
IdMap.iter do_vinfo idmap
(** initialize variables not requiring allocation *)
@ -544,7 +544,7 @@ let gen_hpara code proc_name spec_num env id hpara =
let idmap = create_idmap hpara.Sil.body in
let idmap_ex =
let filter i =
list_exists (Ident.equal i) hpara.Sil.evars in
IList.exists (Ident.equal i) hpara.Sil.evars in
filter_idmap filter idmap in
let idmap_no_next =
let filter i =
@ -637,7 +637,7 @@ let genmain proc_numspecs_list =
Code.add_line code line done in
Code.add_line code "int main() {";
Code.set_indent " ";
list_iter do_one_proc proc_numspecs_list;
IList.iter do_one_proc proc_numspecs_list;
Code.add_line code "printf(\"unit test terminated\\n\");";
Code.add_line code "return 0;";
Code.set_indent "";

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

@ -50,10 +50,10 @@ let check_access access_opt de_opt =
let find_formal_ids node = (* find ids obtained by a letref on a formal parameter *)
let node_instrs = Cfg.Node.get_instrs node in
let formals = Cfg.Procdesc.get_formals (Cfg.Node.get_proc_desc node) in
let formal_names = list_map (fun (s, _) -> Mangled.from_string s) formals in
let formal_names = IList.map (fun (s, _) -> Mangled.from_string s) formals in
let is_formal pvar =
let name = Sil.pvar_get_name pvar in
list_exists (Mangled.equal name) formal_names in
IList.exists (Mangled.equal name) formal_names in
let formal_ids = ref [] in
let process_formal_letref = function
| Sil.Letderef (id, Sil.Lvar pvar, _, _) ->
@ -61,7 +61,7 @@ let check_access access_opt de_opt =
!Config.curr_language = Config.Java && Sil.pvar_is_this pvar in
if not is_java_this && is_formal pvar then formal_ids := id :: !formal_ids
| _ -> () in
list_iter process_formal_letref node_instrs;
IList.iter process_formal_letref node_instrs;
!formal_ids in
let formal_param_used_in_call = ref false in
let has_call_or_sets_null node =
@ -81,14 +81,14 @@ let check_access access_opt de_opt =
| Sil.Call (_, _, etl, _, _) ->
let formal_ids = find_formal_ids node in
let arg_is_formal_param (e, t) = match e with
| Sil.Var id -> list_exists (Ident.equal id) formal_ids
| Sil.Var id -> IList.exists (Ident.equal id) formal_ids
| _ -> false in
if list_exists arg_is_formal_param etl then formal_param_used_in_call := true;
if IList.exists arg_is_formal_param etl then formal_param_used_in_call := true;
true
| Sil.Set (_, _, e, _) ->
exp_is_null e
| _ -> false in
list_exists filter (Cfg.Node.get_instrs node) in
IList.exists filter (Cfg.Node.get_instrs node) in
let local_access_found = ref false in
let do_node node =
if (Cfg.Node.get_loc node).Location.line = line_number && has_call_or_sets_null node then

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

@ -40,15 +40,15 @@ let inline_synthetic_method ret_ids etl proc_desc proc_name loc_call : Sil.instr
let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in
found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
when list_length ret_ids = list_length ret_ids'
&& list_length etl' = list_length etl ->
when IList.length ret_ids = IList.length ret_ids'
&& IList.length etl' = IList.length etl ->
let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in
found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
when list_length ret_ids = list_length ret_ids'
&& list_length etl' + 1 = list_length etl ->
let etl1 = match list_rev etl with (* remove last element *)
| _ :: l -> list_rev l
when IList.length ret_ids = IList.length ret_ids'
&& IList.length etl' + 1 = IList.length etl ->
let etl1 = match IList.rev etl with (* remove last element *)
| _ :: l -> IList.rev l
| [] -> assert false in
let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl1, loc_call, cf) in
found instr instr'
@ -79,7 +79,7 @@ let proc_inline_synthetic_methods cfg proc_desc : unit =
modified := true;
instr' in
let instrs = Cfg.Node.get_instrs node in
let instrs' = list_map do_instr instrs in
let instrs' = IList.map do_instr instrs in
if !modified then Cfg.Node.replace_instrs node instrs' in
Cfg.Procdesc.iter_nodes node_inline_synthetic_methods proc_desc
@ -148,7 +148,7 @@ let iterate_procedure_callbacks all_procs exe_env proc_name =
Option.may
(fun (idenv, tenv, proc_name, proc_desc, language) ->
list_iter
IList.iter
(fun (language_opt, proc_callback) ->
let language_matches = match language_opt with
| Some language -> language = procedure_language
@ -172,25 +172,25 @@ let iterate_cluster_callbacks all_procs exe_env proc_names =
with Not_found -> None in
let procedure_definitions =
list_map (get_procedure_definition exe_env) proc_names
|> list_flatten_options in
IList.map (get_procedure_definition exe_env) proc_names
|> IList.flatten_options in
let environment =
list_map
IList.map
(fun (idenv, tenv, proc_name, proc_desc, _) -> (idenv, tenv, proc_name, proc_desc))
procedure_definitions in
(** Procedures matching the given language or all if no language is specified. *)
let relevant_procedures language_opt =
Option.map_default
(fun l -> list_filter (fun p -> l = get_language p) proc_names)
(fun l -> IList.filter (fun p -> l = get_language p) proc_names)
proc_names
language_opt in
list_iter
IList.iter
(fun (language_opt, cluster_callback) ->
let proc_names = relevant_procedures language_opt in
if list_length proc_names > 0 then
if IList.length proc_names > 0 then
cluster_callback all_procs get_procdesc environment)
!cluster_callbacks
@ -210,7 +210,7 @@ let iterate_callbacks store_summary call_graph exe_env =
| _ -> "unknown" in
let cluster proc_names =
let cluster_map =
list_fold_left
IList.fold_left
(fun map proc_name ->
let proc_cluster = cluster_id proc_name in
let bucket = try StringMap.find proc_cluster map with Not_found -> [] in
@ -218,7 +218,7 @@ let iterate_callbacks store_summary call_graph exe_env =
StringMap.empty
proc_names in
(* Return all values of the map *)
list_map snd (StringMap.bindings cluster_map) in
IList.map snd (StringMap.bindings cluster_map) in
let reset_summary proc_name =
let attributes_opt =
Specs.proc_resolve_attributes proc_name in
@ -228,20 +228,18 @@ let iterate_callbacks store_summary call_graph exe_env =
if should_reset
then Specs.reset_summary call_graph proc_name attributes_opt in
(* Make sure summaries exists. *)
list_iter reset_summary procs_to_analyze;
IList.iter reset_summary procs_to_analyze;
(* Invoke callbacks. *)
list_iter
IList.iter
(iterate_procedure_callbacks originally_defined_procs exe_env)
procs_to_analyze;
list_iter
IList.iter
(iterate_cluster_callbacks originally_defined_procs exe_env)
(cluster procs_to_analyze);
list_iter store_summary procs_to_analyze;
IList.iter store_summary procs_to_analyze;
Config.curr_language := saved_language

116
infer/src/backend/cfg.ml
Unescape View File

@ -73,7 +73,7 @@ module Node = struct
let id_map = ref IntMap.empty in
(* formals are the same if their types are the same *)
let formals_eq formals1 formals2 =
list_equal (fun (_, typ1) (_, typ2) -> Sil.typ_compare typ1 typ2) formals1 formals2 in
IList.equal (fun (_, typ1) (_, typ2) -> Sil.typ_compare typ1 typ2) formals1 formals2 in
let nodes_eq n1s n2s =
(* nodes are the same if they have the same id, instructions, and succs/preds up to renaming
with [exp_map] and [id_map] *)
@ -89,7 +89,7 @@ module Node = struct
id_map := IntMap.add id1 id2 !id_map;
0 in
let instrs_eq instrs1 instrs2 =
list_equal
IList.equal
(fun i1 i2 ->
let n, exp_map' = Sil.instr_compare_structural i1 i2 !exp_map in
exp_map := exp_map';
@ -97,11 +97,11 @@ module Node = struct
instrs1
instrs2 in
id_compare n1 n2 = 0 &&
list_equal id_compare n1.nd_succs n2.nd_succs &&
list_equal id_compare n1.nd_preds n2.nd_preds &&
IList.equal id_compare n1.nd_succs n2.nd_succs &&
IList.equal id_compare n1.nd_preds n2.nd_preds &&
instrs_eq n1.nd_instrs n2.nd_instrs in
try
list_for_all2 node_eq n1s n2s
IList.for_all2 node_eq n1s n2s
with Invalid_argument _ -> false in
let att1 = pd1.pd_attributes and att2 = pd2.pd_attributes in
att1.ProcAttributes.is_defined = att2.ProcAttributes.is_defined &&
@ -202,8 +202,8 @@ module Node = struct
let do_node acc n =
visited := NodeSet.add n !visited;
if f n then NodeSet.singleton n
else NodeSet.union acc (slice_nodes (list_filter (fun s -> not (NodeSet.mem s !visited)) n.nd_succs)) in
list_fold_left do_node NodeSet.empty nodes in
else NodeSet.union acc (slice_nodes (IList.filter (fun s -> not (NodeSet.mem s !visited)) n.nd_succs)) in
IList.fold_left do_node NodeSet.empty nodes in
NodeSet.elements (slice_nodes node.nd_succs)
let get_sliced_preds node f =
@ -212,8 +212,8 @@ module Node = struct
let do_node acc n =
visited := NodeSet.add n !visited;
if f n then NodeSet.singleton n
else NodeSet.union acc (slice_nodes (list_filter (fun s -> not (NodeSet.mem s !visited)) n.nd_preds)) in
list_fold_left do_node NodeSet.empty nodes in
else NodeSet.union acc (slice_nodes (IList.filter (fun s -> not (NodeSet.mem s !visited)) n.nd_preds)) in
IList.fold_left do_node NodeSet.empty nodes in
NodeSet.elements (slice_nodes node.nd_preds)
let get_exn node = node.nd_exn
@ -224,7 +224,7 @@ module Node = struct
let set_succs_exn node succs exn =
node.nd_succs <- succs;
node.nd_exn <- exn;
list_iter (fun n -> n.nd_preds <- (node :: n.nd_preds)) succs
IList.iter (fun n -> n.nd_preds <- (node :: n.nd_preds)) succs
(** Get the predecessors of the node *)
let get_preds node = node.nd_preds
@ -234,9 +234,9 @@ module Node = struct
let visited = ref NodeSet.empty in
let rec nodes n =
visited := NodeSet.add n !visited;
let succs = list_filter (fun n -> not (NodeSet.mem n !visited)) (generator n) in
match list_length succs with
| 1 -> n:: (nodes (list_hd succs))
let succs = IList.filter (fun n -> not (NodeSet.mem n !visited)) (generator n) in
match IList.length succs with
| 1 -> n:: (nodes (IList.hd succs))
| _ -> [n] in
nodes start_node
@ -288,14 +288,14 @@ module Node = struct
| _ -> callees
end
| _ -> callees in
list_fold_left collect [] (get_instrs node)
IList.fold_left collect [] (get_instrs node)
(** Get the location of the node *)
let get_loc n = n.nd_loc
(** Get the source location of the last instruction in the node *)
let get_last_loc n =
match list_rev (get_instrs n) with
match IList.rev (get_instrs n) with
| instr :: _ -> Sil.instr_get_loc instr
| [] -> n.nd_loc
@ -366,7 +366,7 @@ module Node = struct
(proc_desc_get_ret_var pdesc, ret_type) in
let construct_decl (x, typ) =
(Sil.mk_pvar x proc_name, typ) in
let ptl = ret_var :: list_map construct_decl locals in
let ptl = ret_var :: IList.map construct_decl locals in
let instr = Sil.Declare_locals (ptl, loc) in
prepend_instrs_temps node [instr] []
@ -375,7 +375,7 @@ module Node = struct
let remove_node' filter_out_fun cfg node =
let remove_node_in_cfg nodes =
list_filter filter_out_fun nodes in
IList.filter filter_out_fun nodes in
cfg.node_list := remove_node_in_cfg !(cfg.node_list)
let remove_node cfg node =
@ -390,7 +390,7 @@ module Node = struct
(if remove_nodes then
let pdesc = pdesc_tbl_find cfg name in
let proc_nodes =
list_fold_right (fun node set -> NodeSet.add node set)
IList.fold_right (fun node set -> NodeSet.add node set)
pdesc.pd_nodes NodeSet.empty in
remove_node_set cfg proc_nodes);
pdesc_tbl_remove cfg name
@ -418,7 +418,7 @@ module Node = struct
| None ->
node.nd_dist_exit <- Some dist;
next_nodes := node.nd_preds @ !next_nodes in
list_iter do_node nodes;
IList.iter do_node nodes;
if !next_nodes != [] then mark_distance (dist + 1) !next_nodes in
mark_distance 0 [exit_node]
@ -488,8 +488,8 @@ module Node = struct
let nodes = proc_desc_get_nodes proc_desc in
let do_node node =
incr num_nodes;
num_edges := !num_edges + list_length (get_succs node) in
list_iter do_node nodes;
num_edges := !num_edges + IList.length (get_succs node) in
IList.iter do_node nodes;
let cyclo = !num_edges - !num_nodes + 2 * num_connected in (* formula for cyclomatic complexity *)
cyclo
@ -545,19 +545,19 @@ module Node = struct
pp_to_string pp ()
let proc_desc_iter_nodes f proc_desc =
list_iter f (list_rev (proc_desc_get_nodes proc_desc))
IList.iter f (IList.rev (proc_desc_get_nodes proc_desc))
let proc_desc_fold_nodes f acc proc_desc =
(*list_fold_left (fun acc node -> f acc node) acc (list_rev (proc_desc_get_nodes proc_desc))*)
list_fold_left f acc (list_rev (proc_desc_get_nodes proc_desc))
(*list_fold_left (fun acc node -> f acc node) acc (IList.rev (proc_desc_get_nodes proc_desc))*)
IList.fold_left f acc (IList.rev (proc_desc_get_nodes proc_desc))
(** iterate over the calls from the procedure: (callee,location) pairs *)
let proc_desc_iter_calls f pdesc =
let do_node node =
list_iter
IList.iter
(fun callee_pname -> f (callee_pname, get_loc node))
(get_callees node) in
list_iter do_node (proc_desc_get_nodes pdesc)
IList.iter do_node (proc_desc_get_nodes pdesc)
let proc_desc_iter_slope f proc_desc =
let visited = ref NodeSet.empty in
@ -587,19 +587,19 @@ module Node = struct
let proc_desc_iter_slope_calls f proc_desc =
let do_node node =
list_iter
IList.iter
(fun callee_pname -> f callee_pname)
(get_callees node) in
proc_desc_iter_slope do_node proc_desc
let proc_desc_iter_instrs f proc_desc =
let do_node node =
list_iter (fun i -> f node i) (get_instrs node) in
IList.iter (fun i -> f node i) (get_instrs node) in
proc_desc_iter_nodes do_node proc_desc
let proc_desc_fold_instrs f acc proc_desc =
let fold_node acc node =
list_fold_left (fun acc instr -> f acc node instr) acc (get_instrs node) in
IList.fold_left (fun acc instr -> f acc node instr) acc (get_instrs node) in
proc_desc_fold_nodes fold_node acc proc_desc
end
@ -690,11 +690,11 @@ let get_all_procs cfg =
(** Get the procedures whose body is defined in this cfg *)
let get_defined_procs cfg =
list_filter Procdesc.is_defined (get_all_procs cfg)
IList.filter Procdesc.is_defined (get_all_procs cfg)
(** Get the objc procedures whose body is generated *)
let get_objc_generated_procs cfg =
list_filter (
IList.filter (
fun procdesc ->
(Procdesc.get_attributes procdesc).ProcAttributes.is_generated) (get_all_procs cfg)
@ -713,7 +713,7 @@ let add_removetemps_instructions cfg =
let loc = Node.get_last_loc node in
let temps = Node.get_temps node in
if temps != [] then Node.append_instrs_temps node [Sil.Remove_temps (temps, loc)] [] in
list_iter do_node all_nodes
IList.iter do_node all_nodes
(** add instructions to perform abstraction *)
let add_abstraction_instructions cfg =
@ -722,10 +722,10 @@ let add_abstraction_instructions cfg =
| Node.Exit_node _ -> true
| _ -> false in
let succ_nodes = Node.get_succs node in
if list_exists is_exit succ_nodes then true
if IList.exists is_exit succ_nodes then true
else match succ_nodes with
| [] -> false
| [h] -> list_length (Node.get_preds h) > 1
| [h] -> IList.length (Node.get_preds h) > 1
| _ -> false in
let node_requires_abstraction node =
match Node.get_kind node with
@ -741,7 +741,7 @@ let add_abstraction_instructions cfg =
let do_node node =
let loc = Node.get_last_loc node in
if node_requires_abstraction node then Node.append_instrs_temps node [Sil.Abstract loc] [] in
list_iter do_node all_nodes
IList.iter do_node all_nodes
let get_name_of_parameter (curr_f : Procdesc.t) (x, typ) =
Sil.mk_pvar (Mangled.from_string x) (Procdesc.get_proc_name curr_f)
@ -760,8 +760,8 @@ let get_name_of_objc_static_locals (curr_f : Procdesc.t) p =
match hpred with
| Sil.Hpointsto(e, _, _) -> [local_static e]
| _ -> [] in
let vars_sigma = list_map hpred_local_static (Prop.get_sigma p) in
list_flatten (list_flatten vars_sigma)
let vars_sigma = IList.map hpred_local_static (Prop.get_sigma p) in
IList.flatten (IList.flatten vars_sigma)
(* returns a list of local variables that points to an objc block in a proposition *)
let get_name_of_objc_block_locals p =
@ -774,8 +774,8 @@ let get_name_of_objc_block_locals p =
match hpred with
| Sil.Hpointsto(e, _, _) -> [local_blocks e]
| _ -> [] in
let vars_sigma = list_map hpred_local_blocks (Prop.get_sigma p) in
list_flatten (list_flatten vars_sigma)
let vars_sigma = IList.map hpred_local_blocks (Prop.get_sigma p) in
IList.flatten (IList.flatten vars_sigma)
let remove_abducted_retvars p =
(* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] *)
@ -785,10 +785,10 @@ let remove_abducted_retvars p =
| Sil.Eexp (Sil.Const (Sil.Cexn e), _) -> Sil.ExpSet.add e exps
| Sil.Eexp (e, _) -> Sil.ExpSet.add e exps
| Sil.Estruct (flds, _) ->
list_fold_left (fun exps (_, strexp) -> collect_exps exps strexp) exps flds
IList.fold_left (fun exps (_, strexp) -> collect_exps exps strexp) exps flds
| Sil.Earray (_, elems, _) ->
list_fold_left (fun exps (index, strexp) -> collect_exps exps strexp) exps elems in
IList.fold_left (fun exps (index, strexp) -> collect_exps exps strexp) exps elems in
let rec compute_reachable_hpreds_rec sigma (reach, exps) =
let add_hpred_if_reachable (reach, exps) = function
| Sil.Hpointsto (lhs, rhs, _) as hpred when Sil.ExpSet.mem lhs exps ->
@ -796,7 +796,7 @@ let remove_abducted_retvars p =
let exps' = collect_exps exps rhs in
(reach', exps')
| _ -> reach, exps in
let reach', exps' = list_fold_left add_hpred_if_reachable (reach, exps) sigma in
let reach', exps' = IList.fold_left add_hpred_if_reachable (reach, exps) sigma in
if (Sil.HpredSet.cardinal reach) = (Sil.HpredSet.cardinal reach') then (reach, exps)
else compute_reachable_hpreds_rec sigma (reach', exps') in
let reach_hpreds, reach_exps =
@ -808,14 +808,14 @@ let remove_abducted_retvars p =
| Sil.UnOp (_, e, _) | Sil.Cast (_, e) | Sil.Lfield (e, _, _) -> exp_contains e
| Sil.BinOp (_, e0, e1) | Sil.Lindex (e0, e1) -> exp_contains e0 || exp_contains e1
| _ -> false in
list_filter
IList.filter
(function
| Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) -> exp_contains lhs || exp_contains rhs)
pi in
Sil.HpredSet.elements reach_hpreds, reach_pi in
(* separate the abducted pvars from the normal ones, deallocate the abducted ones*)
let abducted_pvars, normal_pvars =
list_fold_left
IList.fold_left
(fun pvars hpred ->
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, _, _) ->
@ -827,7 +827,7 @@ let remove_abducted_retvars p =
(Prop.get_sigma p) in
let _, p' = Prop.deallocate_stack_vars p abducted_pvars in
let normal_pvar_set =
list_fold_left
IList.fold_left
(fun normal_pvar_set pvar -> Sil.ExpSet.add (Sil.Lvar pvar) normal_pvar_set)
Sil.ExpSet.empty
normal_pvars in
@ -836,7 +836,7 @@ let remove_abducted_retvars p =
Prop.normalize (Prop.replace_pi pi_reach (Prop.replace_sigma sigma_reach p'))
let remove_locals (curr_f : Procdesc.t) p =
let names_of_locals = list_map (get_name_of_local curr_f) (Procdesc.get_locals curr_f) in
let names_of_locals = IList.map (get_name_of_local curr_f) (Procdesc.get_locals curr_f) in
let names_of_locals' = match !Config.curr_language with
| Config.C_CPP -> (* in ObjC to deal with block we need to remove static locals *)
let names_of_static_locals = get_name_of_objc_static_locals curr_f p in
@ -847,7 +847,7 @@ let remove_locals (curr_f : Procdesc.t) p =
(removed, if !Config.angelic_execution then remove_abducted_retvars p' else p')
let remove_formals (curr_f : Procdesc.t) p =
let names_of_formals = list_map (get_name_of_parameter curr_f) (Procdesc.get_formals curr_f) in
let names_of_formals = IList.map (get_name_of_parameter curr_f) (Procdesc.get_formals curr_f) in
Prop.deallocate_stack_vars p names_of_formals
(** remove the return variable from the prop *)
@ -874,7 +874,7 @@ let remove_seed_vars (prop: 'a Prop.t) : Prop.normal Prop.t =
| Sil.Hpointsto(Sil.Lvar pv, _, _) -> not (Sil.pvar_is_seed pv)
| _ -> true in
let sigma = Prop.get_sigma prop in
let sigma' = list_filter hpred_not_seed sigma in
let sigma' = IList.filter hpred_not_seed sigma in
Prop.normalize (Prop.replace_sigma sigma' prop)
(** checks whether a cfg is connected or not *)
@ -887,26 +887,26 @@ let check_cfg_connectedness cfg =
let succs = Node.get_succs n in
let preds = Node.get_preds n in
match Node.get_kind n with
| Node.Start_node _ -> (list_length succs = 0) || (list_length preds > 0)
| Node.Exit_node _ -> (list_length succs > 0) || (list_length preds = 0)
| Node.Start_node _ -> (IList.length succs = 0) || (IList.length preds > 0)
| Node.Exit_node _ -> (IList.length succs > 0) || (IList.length preds = 0)
| Node.Stmt_node _ | Node.Prune_node _
| Node.Skip_node _ -> (list_length succs = 0) || (list_length preds = 0)
| Node.Skip_node _ -> (IList.length succs = 0) || (IList.length preds = 0)
| Node.Join_node ->
(* Join node has the exception that it may be without predecessors and pointing to an exit node *)
(* if the if brances end with a return *)
(match succs with
| [n'] when is_exit_node n' -> false
| _ -> (list_length preds = 0)) in
| _ -> (IList.length preds = 0)) in
let do_pdesc pd =
let pname = Procname.to_string (Procdesc.get_proc_name pd) in
let nodes = Procdesc.get_nodes pd in
let broken = list_exists broken_node nodes in
let broken = IList.exists broken_node nodes in
if broken then
L.out "\n ***BROKEN CFG: '%s'\n" pname
else
L.out "\n ***CONNECTED CFG: '%s'\n" pname in
let pdescs = get_all_procs cfg in
list_iter do_pdesc pdescs
IList.iter do_pdesc pdescs
(** Given a mangled name of a block return its procdesc if exists*)
let get_block_pdesc cfg block =
@ -915,7 +915,7 @@ let get_block_pdesc cfg block =
let name = Procdesc.get_proc_name pd in
(Procname.to_string name) = (Mangled.to_string block) in
try
let block_pdesc = list_find is_block_pdesc pdescs in
let block_pdesc = IList.find is_block_pdesc pdescs in
Some block_pdesc
with Not_found -> None
@ -929,10 +929,10 @@ let remove_seed_captured_vars_block captured_vars prop =
let hpred_seed_captured = function
| Sil.Hpointsto(Sil.Lvar pv, _, _) ->
let pname = Sil.pvar_get_name pv in
(Sil.pvar_is_seed pv) && (list_mem is_captured pname captured_vars)
(Sil.pvar_is_seed pv) && (IList.mem is_captured pname captured_vars)
| _ -> false in
let sigma = Prop.get_sigma prop in
let sigma' = list_filter (fun hpred -> not (hpred_seed_captured hpred)) sigma in
let sigma' = IList.filter (fun hpred -> not (hpred_seed_captured hpred)) sigma in
Prop.normalize (Prop.replace_sigma sigma' prop)
(** Serializer for control flow graphs *)
@ -984,7 +984,7 @@ let save_attributes filename cfg =
(Location.to_string loc);
*)
AttributesTable.store_attributes attributes' in
list_iter save_proc (get_all_procs cfg)
IList.iter save_proc (get_all_procs cfg)
(** Save a cfg into a file *)
let store_cfg_to_file (filename : DB.filename) (save_sources : bool) (cfg : cfg) =

34
infer/src/backend/cg.ml
Unescape View File

@ -167,7 +167,7 @@ let node_map_iter f g =
let table = ref [] in
Procname.Hash.iter (fun node info -> table := (node, info) :: !table) g.node_map;
let cmp ((n1: Procname.t), _) ((n2: Procname.t), _) = Procname.compare n1 n2 in
list_iter (fun (n, info) -> f n info) (list_sort cmp !table)
IList.iter (fun (n, info) -> f n info) (IList.sort cmp !table)
(** If not None, restrict defined nodes to the given set,
and mark them as disabled. *)
@ -191,8 +191,8 @@ let get_nodes (g: t) =
!nodes
let map_option f l =
let lo = list_filter (function | Some _ -> true | None -> false) (list_map f l) in
list_map (function Some p -> p | None -> assert false) lo
let lo = IList.filter (function | Some _ -> true | None -> false) (IList.map f l) in
IList.map (function Some p -> p | None -> assert false) lo
let compute_calls g node =
{ in_calls = Procname.Set.cardinal (get_ancestors g node);
@ -210,10 +210,10 @@ let get_calls (g: t) node =
let get_all_nodes (g: t) =
let nodes = Procname.Set.elements (get_nodes g) in
list_map (fun node -> (node, get_calls g node)) nodes
IList.map (fun node -> (node, get_calls g node)) nodes
let get_nodes_and_calls (g: t) =
list_filter (fun (n, calls) -> node_defined g n) (get_all_nodes g)
IList.filter (fun (n, calls) -> node_defined g n) (get_all_nodes g)
let node_get_num_ancestors g n =
(n, Procname.Set.cardinal (get_ancestors g n))
@ -280,7 +280,7 @@ let get_nodes_and_defined_children (g: t) =
let nodes = ref Procname.Set.empty in
node_map_iter (fun n info -> if info.defined then nodes := Procname.Set.add n !nodes) g;
let nodes_list = Procname.Set.elements !nodes in
list_map (fun n -> (n, get_defined_children g n)) nodes_list
IList.map (fun n -> (n, get_defined_children g n)) nodes_list
type nodes_and_edges =
(node * bool * bool) list * (* nodes with defined and disabled flag *)
@ -302,8 +302,8 @@ let get_nodes_and_edges (g: t) : nodes_and_edges =
let get_defined_nodes (g: t) =
let (nodes, _) = get_nodes_and_edges g in
let get_node (node, _, _) = node in
list_map get_node
(list_filter (fun (_, defined, _) -> defined)
IList.map get_node
(IList.filter (fun (_, defined, _) -> defined)
nodes)
@ -312,8 +312,8 @@ let get_defined_nodes (g: t) =
let get_originally_defined_nodes (g: t) =
let (nodes, _) = get_nodes_and_edges g in
let get_node (node, _, _) = node in
list_map get_node
(list_filter
IList.map get_node
(IList.filter
(fun (_, defined, disabled) -> defined || disabled)
nodes)
@ -328,8 +328,8 @@ let get_nLOC (g: t) =
(** [extend cg1 gc2] extends [cg1] in place with nodes and edges from [gc2]; undefined nodes become defined if at least one side is. *)
let extend cg_old cg_new =
let nodes, edges = get_nodes_and_edges cg_new in
list_iter (fun (node, defined, disabled) -> _add_node cg_old node defined disabled) nodes;
list_iter (fun (nfrom, nto) -> add_edge cg_old nfrom nto) edges
IList.iter (fun (node, defined, disabled) -> _add_node cg_old node defined disabled) nodes;
IList.iter (fun (nfrom, nto) -> add_edge cg_old nfrom nto) edges
(** Begin support for serialization *)
@ -341,12 +341,12 @@ let load_from_file (filename : DB.filename) : t option =
match Serialization.from_file callgraph_serializer filename with
| None -> None
| Some (source, nLOC, (nodes, edges)) ->
list_iter
IList.iter
(fun (node, defined, disabled) ->
if defined then add_defined_node g node;
if disabled then add_disabled_node g node)
nodes;
list_iter (fun (nfrom, nto) -> add_edge g nfrom nto) edges;
IList.iter (fun (nfrom, nto) -> add_edge g nfrom nto) edges;
g.source <- source;
g.nLOC <- nLOC;
Some g
@ -357,7 +357,7 @@ let store_to_file (filename : DB.filename) (call_graph : t) =
let pp_graph_dotty get_specs (g: t) fmt =
let nodes_with_calls = get_all_nodes g in
let num_specs n = try list_length (get_specs n) with exn when exn_not_timeout exn -> - 1 in
let num_specs n = try IList.length (get_specs n) with exn when exn_not_timeout exn -> - 1 in
let get_color (n, calls) =
if num_specs n != 0 then "green" else "red" in
let get_shape (n, calls) =
@ -367,8 +367,8 @@ let pp_graph_dotty get_specs (g: t) fmt =
let pp_node_label fmt (n, calls) =
F.fprintf fmt "\"%a | calls=%d %d | specs=%d)\"" Procname.pp n calls.in_calls calls.out_calls (num_specs n) in
F.fprintf fmt "digraph {@\n";
list_iter (fun nc -> F.fprintf fmt "%a [shape=box,label=%a,color=%s,shape=%s]@\n" pp_node nc pp_node_label nc (get_color nc) (get_shape nc)) nodes_with_calls;
list_iter (fun (s, d) -> F.fprintf fmt "%a -> %a@\n" pp_node s pp_node d) (get_edges g);
IList.iter (fun nc -> F.fprintf fmt "%a [shape=box,label=%a,color=%s,shape=%s]@\n" pp_node nc pp_node_label nc (get_color nc) (get_shape nc)) nodes_with_calls;
IList.iter (fun (s, d) -> F.fprintf fmt "%a -> %a@\n" pp_node s pp_node d) (get_edges g);
F.fprintf fmt "}@."
(** Print the current call graph as a dotty file. If the filename is [None], use the current file dir inside the DB dir. *)

24
infer/src/backend/cluster.ml
Unescape View File

@ -75,7 +75,7 @@ let create_ondemand source_dir =
| None ->
[[ce]]
| Some defined_procs ->
list_map mk_cluster defined_procs in
IList.map mk_cluster defined_procs in
clusters
let create_bottomup source_file naprocs active_procs =
@ -86,16 +86,16 @@ let create_bottomup source_file naprocs active_procs =
ce_ondemand = None;
}
let cluster_nfiles cluster = list_length cluster
let cluster_nfiles cluster = IList.length cluster
let cluster_naprocs cluster =
list_fold_left (fun n ce -> ce.ce_naprocs + n) 0 cluster
IList.fold_left (fun n ce -> ce.ce_naprocs + n) 0 cluster
let clusters_nfiles clusters =
list_fold_left (fun n cluster -> cluster_nfiles cluster + n) 0 clusters
IList.fold_left (fun n cluster -> cluster_nfiles cluster + n) 0 clusters
let clusters_naprocs clusters =
list_fold_left (fun n cluster -> cluster_naprocs cluster + n) 0 clusters
IList.fold_left (fun n cluster -> cluster_naprocs cluster + n) 0 clusters
let print_clusters_stats clusters =
let pp_cluster num cluster =
@ -104,7 +104,7 @@ let print_clusters_stats clusters =
(cluster_nfiles cluster)
(cluster_naprocs cluster) in
let i = ref 0 in
list_iter
IList.iter
(fun cluster ->
incr i;
pp_cluster !i cluster)
@ -112,7 +112,7 @@ let print_clusters_stats clusters =
let cluster_split_prefix (cluster : t) size =
let rec split (cluster_seen : t) (cluster_todo : t) n =
if n <= 0 then (list_rev cluster_seen, cluster_todo)
if n <= 0 then (IList.rev cluster_seen, cluster_todo)
else match cluster_todo with
| [] -> raise Not_found
| ce :: todo' -> split (ce :: cluster_seen) todo' (n - ce.ce_naprocs) in
@ -137,7 +137,7 @@ let combine_split_clusters (clusters : t list) max_size desired_size =
L.err "current size: %d@." !current_size;
assert false
end;
let next_cluster = list_hd !old_clusters in
let next_cluster = IList.hd !old_clusters in
let next_size = cluster_naprocs next_cluster in
let new_size = !current_size + next_size in
if (new_size > max_size || new_size > desired_size) && !current_size > 0 then
@ -152,13 +152,13 @@ let combine_split_clusters (clusters : t list) max_size desired_size =
current := [];
current_size := 0;
new_clusters := !new_clusters @ [next_cluster'];
old_clusters := next_cluster'' :: (list_tl !old_clusters)
old_clusters := next_cluster'' :: (IList.tl !old_clusters)
end
else
begin
current := !current @ next_cluster;
current_size := !current_size + next_size;
old_clusters := list_tl !old_clusters
old_clusters := IList.tl !old_clusters
end
done;
if !current_size > 0 then new_clusters := !new_clusters @ [!current];
@ -175,8 +175,8 @@ let get_active_procs cluster =
let add proc =
if not (Procname.Set.mem proc !procset) then
procset := Procname.Set.add proc !procset in
list_iter add cluster_elem.ce_active_procs in
list_iter do_cluster_elem cluster;
IList.iter add cluster_elem.ce_active_procs in
IList.iter do_cluster_elem cluster;
Some !procset
let cl_name n = "cl" ^ string_of_int n

6
infer/src/backend/clusterMakefile.ml
Unescape View File

@ -39,7 +39,7 @@ let create_cluster_makefile_and_exit
let fmt = Format.formatter_of_out_channel outc in
let file_to_cluster = ref DB.SourceFileMap.empty in
let cluster_nr = ref 0 in
let tot_clusters_nr = list_length clusters in
let tot_clusters_nr = IList.length clusters in
let do_cluster cluster =
incr cluster_nr;
let dependent_clusters = ref IntSet.empty in
@ -69,12 +69,12 @@ let create_cluster_makefile_and_exit
file_to_cluster :=
DB.SourceFileMap.add source_file !cluster_nr !file_to_cluster;
() (* L.err "file %s has %d children@." file (StringSet.cardinal children) *) in
list_iter do_file cluster;
IList.iter do_file cluster;
Cluster.pp_cluster_dependency
!cluster_nr tot_clusters_nr cluster print_files fmt (IntSet.elements !dependent_clusters);
(* L.err "cluster %d has %d dependencies@."
!cluster_nr (IntSet.cardinal !dependent_clusters) *) in
pp_prolog fmt tot_clusters_nr;
list_iter do_cluster clusters;
IList.iter do_cluster clusters;
pp_epilog fmt ();
exit 0

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

@ -49,19 +49,19 @@ let sigma_equal sigma1 sigma2 =
match (sigma1_rest, sigma2_rest) with
| [], [] -> ()
| [], _:: _ | _:: _, [] ->
(L.d_strln "failure reason 1"; raise Fail)
(L.d_strln "failure reason 1"; raise IList.Fail)
| hpred1:: sigma1_rest', hpred2:: sigma2_rest' ->
if Sil.hpred_equal hpred1 hpred2 then f sigma1_rest' sigma2_rest'
else (L.d_strln "failure reason 2"; raise Fail) in
let sigma1_sorted = list_sort Sil.hpred_compare sigma1 in
let sigma2_sorted = list_sort Sil.hpred_compare sigma2 in
else (L.d_strln "failure reason 2"; raise IList.Fail) in
let sigma1_sorted = IList.sort Sil.hpred_compare sigma1 in
let sigma2_sorted = IList.sort Sil.hpred_compare sigma2 in
f sigma1_sorted sigma2_sorted
let sigma_get_start_lexps_sort sigma =
let exp_compare_neg e1 e2 = - (Sil.exp_compare e1 e2) in
let filter e = Sil.fav_for_all (Sil.exp_fav e) Ident.is_normal in
let lexps = Sil.hpred_list_get_lexps filter sigma in
list_sort exp_compare_neg lexps
IList.sort exp_compare_neg lexps
(** {2 Utility functions for side} *)
@ -163,14 +163,14 @@ end = struct
let new_c = lookup_const' const_tbl new_r in
let old_c = lookup_const' const_tbl old_r in
let res_c = Sil.ExpSet.union new_c old_c in
if Sil.ExpSet.cardinal res_c > 1 then (L.d_strln "failure reason 3"; raise Fail);
if Sil.ExpSet.cardinal res_c > 1 then (L.d_strln "failure reason 3"; raise IList.Fail);
Hashtbl.replace tbl old_r new_r;
Hashtbl.replace const_tbl new_r res_c
let replace_const' tbl const_tbl e c =
let r = find' tbl e in
let set = Sil.ExpSet.add c (lookup_const' const_tbl r) in
if Sil.ExpSet.cardinal set > 1 then (L.d_strln "failure reason 4"; raise Fail);
if Sil.ExpSet.cardinal set > 1 then (L.d_strln "failure reason 4"; raise IList.Fail);
Hashtbl.replace const_tbl r set
let add side e e' =
@ -186,34 +186,34 @@ end = struct
| true, true -> union' tbl const_tbl e e'
| true, false -> replace_const' tbl const_tbl e e'
| false, true -> replace_const' tbl const_tbl e' e
| _ -> L.d_strln "failure reason 5"; raise Fail
| _ -> L.d_strln "failure reason 5"; raise IList.Fail
end
| Sil.Var id, Sil.Const _ | Sil.Var id, Sil.Lvar _ ->
if (can_rename id) then replace_const' tbl const_tbl e e'
else (L.d_strln "failure reason 6"; raise Fail)
else (L.d_strln "failure reason 6"; raise IList.Fail)
| Sil.Const _, Sil.Var id' | Sil.Lvar _, Sil.Var id' ->
if (can_rename id') then replace_const' tbl const_tbl e' e
else (L.d_strln "failure reason 7"; raise Fail)
else (L.d_strln "failure reason 7"; raise IList.Fail)
| _ ->
if not (Sil.exp_equal e e') then (L.d_strln "failure reason 8"; raise Fail) else ()
if not (Sil.exp_equal e e') then (L.d_strln "failure reason 8"; raise IList.Fail) else ()
let check side es =
let f = function Sil.Var id -> can_rename id | _ -> false in
let vars, nonvars = list_partition f es in
let vars, nonvars = IList.partition f es in
let tbl, const_tbl =
match side with
| Lhs -> equiv_tbl1, const_tbl1
| Rhs -> equiv_tbl2, const_tbl2
in
if (list_length nonvars > 1) then false
if (IList.length nonvars > 1) then false
else
match vars, nonvars with
| [], _ | [_], [] -> true
| v:: vars', _ ->
let r = find' tbl v in
let set = lookup_const' const_tbl r in
(list_for_all (fun v' -> Sil.exp_equal (find' tbl v') r) vars') &&
(list_for_all (fun c -> Sil.ExpSet.mem c set) nonvars)
(IList.for_all (fun v' -> Sil.exp_equal (find' tbl v') r) vars') &&
(IList.for_all (fun c -> Sil.ExpSet.mem c set) nonvars)
end
@ -240,7 +240,7 @@ end = struct
let get_lexp_set' sigma =
let lexp_lst = Sil.hpred_list_get_lexps (fun _ -> true) sigma in
list_fold_left (fun set e -> Sil.ExpSet.add e set) Sil.ExpSet.empty lexp_lst
IList.fold_left (fun set e -> Sil.ExpSet.add e set) Sil.ExpSet.empty lexp_lst
let init sigma1 sigma2 =
lexps1 := get_lexp_set' sigma1;
lexps2 := get_lexp_set' sigma2
@ -276,13 +276,13 @@ module CheckJoinPre : InfoLossCheckerSig = struct
let side_op = opposite side in
match e with
| Sil.Lvar _ -> false
| Sil.Var id when Ident.is_normal id -> list_length es >= 1
| Sil.Var id when Ident.is_normal id -> IList.length es >= 1
| Sil.Var id ->
if !Config.join_cond = 0 then
list_exists (Sil.exp_equal Sil.exp_zero) es
IList.exists (Sil.exp_equal Sil.exp_zero) es
else if Dangling.check side e then
begin
let r = list_exists (fun e' -> not (Dangling.check side_op e')) es in
let r = IList.exists (fun e' -> not (Dangling.check side_op e')) es in
if r then begin
L.d_str ".... Dangling Check (dang e:"; Sil.d_exp e;
L.d_str ") (? es:"; Sil.d_exp_list es; L.d_strln ") ....";
@ -292,7 +292,7 @@ module CheckJoinPre : InfoLossCheckerSig = struct
end
else
begin
let r = list_exists (Dangling.check side_op) es in
let r = IList.exists (Dangling.check side_op) es in
if r then begin
L.d_str ".... Dangling Check (notdang e:"; Sil.d_exp e;
L.d_str ") (? es:"; Sil.d_exp_list es; L.d_strln ") ....";
@ -325,7 +325,7 @@ module CheckJoinPost : InfoLossCheckerSig = struct
let fail_case side e es =
match e with
| Sil.Lvar _ -> false
| Sil.Var id when Ident.is_normal id -> list_length es >= 1
| Sil.Var id when Ident.is_normal id -> IList.length es >= 1
| Sil.Var id -> false
| _ -> false
@ -476,7 +476,7 @@ end = struct
let get_fresh_exp e1 e2 =
try
let (_, _, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e1 e1' && Sil.exp_equal e2 e2') !t in
let (_, _, e) = IList.find (fun (e1', e2', _) -> Sil.exp_equal e1 e1' && Sil.exp_equal e2 e2') !t in
e
with Not_found ->
let e = Sil.exp_get_undefined (JoinState.get_footprint ()) in
@ -485,7 +485,7 @@ end = struct
let lookup side e =
try
let (e1, e2, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e (select side e1' e2')) !t in
let (e1, e2, e) = IList.find (fun (e1', e2', _) -> Sil.exp_equal e (select side e1' e2')) !t in
Some (e, select (opposite side) e1 e2)
with Not_found ->
None
@ -495,10 +495,10 @@ end = struct
let ineq_upper = Prop.mk_inequality (Sil.BinOp(Sil.Le, e, upper)) in
ineq_lower:: ineq_upper:: acc
let minus2_to_2 = list_map Sil.Int.of_int [-2; -1; 0; 1; 2]
let minus2_to_2 = IList.map Sil.Int.of_int [-2; -1; 0; 1; 2]
let get_induced_pi () =
let t_sorted = list_sort entry_compare !t in
let t_sorted = IList.sort entry_compare !t in
let add_and_chk_eq e1 e1' n =
match e1, e1' with
@ -511,7 +511,7 @@ end = struct
| [] -> eqs_acc, t_seen
| ((e1', e2', e') as entry'):: t_rest' ->
try
let n = list_find (fun n -> add_and_chk_eq e1 e1' n && add_and_chk_eq e2 e2' n) minus2_to_2 in
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'
@ -534,7 +534,7 @@ end = struct
let e_upper1 = Sil.exp_int upper1 in
get_induced_atom acc e_strict_lower1 e_upper1 e
| _ -> acc in
list_fold_left f_ineqs eqs t_minimal
IList.fold_left f_ineqs eqs t_minimal
end
@ -577,7 +577,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' = list_filter f !tbl in
let t' = IList.filter f !tbl in
tbl := t';
t'
@ -592,19 +592,19 @@ end = struct
| Sil.Lvar _ | Sil.Var _
| Sil.BinOp (Sil.PlusA, Sil.Var _, _) ->
let is_same_e (e1, e2, _) = Sil.exp_equal e (select side e1 e2) in
let assoc = list_filter is_same_e !tbl in
list_map (fun (e1, e2, _) -> select side_op e1 e2) assoc
let assoc = IList.filter 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 ();
raise Fail in
raise IList.Fail in
lost_little side e assoc_es in
let lhs_es = list_map (fun (e1, _, _) -> e1) !tbl in
let rhs_es = list_map (fun (_, e2, _) -> e2) !tbl in
(list_for_all (f Rhs) rhs_es) && (list_for_all (f Lhs) lhs_es)
let lhs_es = IList.map (fun (e1, _, _) -> e1) !tbl in
let rhs_es = IList.map (fun (_, e2, _) -> e2) !tbl in
(IList.for_all (f Rhs) rhs_es) && (IList.for_all (f Lhs) lhs_es)
let lookup_side' side e =
let f (e1, e2, _) = Sil.exp_equal e (select side e1 e2) in
list_filter f !tbl
IList.filter f !tbl
let lookup_side_induced' side e =
let res = ref [] in
@ -621,8 +621,8 @@ end = struct
res := v'::!res
| _ -> () in
begin
list_iter f !tbl;
list_rev !res
IList.iter f !tbl;
IList.rev !res
end
(* Return the triple whose side is [e], if it exists unique *)
@ -633,30 +633,30 @@ end = struct
let r = lookup_side' side e in
match r with
| [(e1, e2, id) as t] -> if todo then Todo.push t; id
| _ -> L.d_strln "failure reason 9"; raise Fail
| _ -> L.d_strln "failure reason 9"; raise IList.Fail
end
| Sil.Var _ | Sil.Const _ | Sil.Lvar _ -> if todo then Todo.push (e, e, e); e
| _ -> L.d_strln "failure reason 10"; raise Fail
| _ -> L.d_strln "failure reason 10"; raise IList.Fail
let lookup side e = lookup' false side e
let lookup_todo side e = lookup' true side e
let lookup_list side l = list_map (lookup side) l
let lookup_list_todo side l = list_map (lookup_todo side) l
let lookup_list side l = IList.map (lookup side) l
let lookup_list_todo side l = IList.map (lookup_todo side) l
let to_subst_proj (side: side) vars =
let renaming_restricted =
list_filter (function (_, _, Sil.Var i) -> Sil.fav_mem vars i | _ -> assert false) !tbl in
IList.filter (function (_, _, Sil.Var i) -> Sil.fav_mem vars i | _ -> assert false) !tbl in
let sub_list_side =
list_map
IList.map
(function (e1, e2, Sil.Var i) -> (i, select side e1 e2) | _ -> assert false)
renaming_restricted in
let sub_list_side_sorted =
list_sort (fun (i, e) (i', e') -> Sil.exp_compare e e') sub_list_side in
IList.sort (fun (i, e) (i', e') -> Sil.exp_compare e e') sub_list_side in
let rec find_duplicates =
function
| (i, e):: ((i', e'):: l' as t) -> Sil.exp_equal e e' || find_duplicates t
| _ -> false in
if find_duplicates sub_list_side_sorted then (L.d_strln "failure reason 11"; raise Fail)
if find_duplicates sub_list_side_sorted then (L.d_strln "failure reason 11"; raise IList.Fail)
else Sil.sub_of_list sub_list_side
let to_subst_emb (side : side) =
@ -665,25 +665,25 @@ end = struct
match select side e1 e2 with
| Sil.Var i -> can_rename i
| _ -> false in
list_filter pick_id_case !tbl in
IList.filter pick_id_case !tbl in
let sub_list =
let project (e1, e2, e) =
match select side e1 e2 with
| Sil.Var i -> (i, e)
| _ -> assert false in
list_map project renaming_restricted in
IList.map project renaming_restricted in
let sub_list_sorted =
let compare (i, _) (i', _) = Ident.compare i i' in
list_sort compare sub_list in
IList.sort compare sub_list in
let rec find_duplicates = function
| (i, _):: ((i', _):: l' as t) -> Ident.equal i i' || find_duplicates t
| _ -> false in
if find_duplicates sub_list_sorted then (L.d_strln "failure reason 12"; raise Fail)
if find_duplicates sub_list_sorted then (L.d_strln "failure reason 12"; raise IList.Fail)
else Sil.sub_of_list sub_list_sorted
let get e1 e2 =
let f (e1', e2', _) = Sil.exp_equal e1 e1' && Sil.exp_equal e2 e2' in
match (list_filter f !tbl) with
match (IList.filter f !tbl) with
| [] -> None
| (_, _, e):: _ -> Some e
@ -768,7 +768,7 @@ end = struct
let extend e1 e2 default_op =
try
let eq_to_e (f1, f2, _) = Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2 in
let _, _, res = list_find eq_to_e !tbl in
let _, _, res = IList.find eq_to_e !tbl in
res
with Not_found ->
let fav1 = Sil.exp_fav e1 in
@ -778,7 +778,7 @@ end = struct
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 (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise Fail)
if (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise IList.Fail)
else
match default_op with
| ExtDefault e -> e
@ -860,13 +860,13 @@ let ident_same_kind_primed_footprint id1 id2 =
let ident_partial_join (id1: Ident.t) (id2: Ident.t) =
match Ident.is_normal id1, Ident.is_normal id2 with
| true, true ->
if Ident.equal id1 id2 then Sil.Var id1 else (L.d_strln "failure reason 14"; raise Fail)
if Ident.equal id1 id2 then Sil.Var id1 else (L.d_strln "failure reason 14"; raise IList.Fail)
| true, _ | _, true ->
Rename.extend (Sil.Var id1) (Sil.Var id2) Rename.ExtFresh
| _ ->
begin
if not (ident_same_kind_primed_footprint id1 id2) then
(L.d_strln "failure reason 15"; raise Fail)
(L.d_strln "failure reason 15"; raise IList.Fail)
else
let e1 = Sil.Var id1 in
let e2 = Sil.Var id2 in
@ -877,7 +877,7 @@ let ident_partial_meet (id1: Ident.t) (id2: Ident.t) =
match Ident.is_normal id1, Ident.is_normal id2 with
| true, true ->
if Ident.equal id1 id2 then Sil.Var id1
else (L.d_strln "failure reason 16"; raise Fail)
else (L.d_strln "failure reason 16"; raise IList.Fail)
| true, _ ->
let e1, e2 = Sil.Var id1, Sil.Var id2 in
Rename.extend e1 e2 (Rename.ExtDefault(e1))
@ -890,7 +890,7 @@ let ident_partial_meet (id1: Ident.t) (id2: Ident.t) =
else if Ident.is_footprint id1 && Ident.equal id1 id2 then
let e = Sil.Var id1 in Rename.extend e e (Rename.ExtDefault(e))
else
(L.d_strln "failure reason 17"; raise Fail)
(L.d_strln "failure reason 17"; raise IList.Fail)
(** {2 Join and Meet for Exps} *)
@ -901,10 +901,10 @@ let const_partial_join c1 c2 =
| Sil.Cstr _, Sil.Cstr _
| Sil.Cclass _, Sil.Cclass _
| Sil.Cattribute _, Sil.Cattribute _ ->
(L.d_strln "failure reason 18"; raise Fail)
(L.d_strln "failure reason 18"; raise IList.Fail)
| _ ->
if (!Config.abs_val >= 2) then FreshVarExp.get_fresh_exp (Sil.Const c1) (Sil.Const c2)
else (L.d_strln "failure reason 19"; raise Fail)
else (L.d_strln "failure reason 19"; raise IList.Fail)
let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
(* L.d_str "exp_partial_join "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *)
@ -915,7 +915,7 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Var id, Sil.Const c
| Sil.Const c, Sil.Var id ->
if Ident.is_normal id then
(L.d_strln "failure reason 20"; raise Fail)
(L.d_strln "failure reason 20"; raise IList.Fail)
else
Rename.extend e1 e2 Rename.ExtFresh
| Sil.Const c1, Sil.Const c2 ->
@ -923,7 +923,7 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Var id, Sil.Lvar _
| Sil.Lvar _, Sil.Var id ->
if Ident.is_normal id then (L.d_strln "failure reason 21"; raise Fail)
if Ident.is_normal id then (L.d_strln "failure reason 21"; raise IList.Fail)
else Rename.extend e1 e2 Rename.ExtFresh
| Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const _), Sil.Var id2
@ -941,12 +941,12 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
let e_res = Rename.extend (Sil.exp_int c1') (Sil.Var id2) Rename.ExtFresh in
Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c2)
| Sil.Cast(t1, e1), Sil.Cast(t2, e2) ->
if not (Sil.typ_equal t1 t2) then (L.d_strln "failure reason 22"; raise Fail)
if not (Sil.typ_equal t1 t2) then (L.d_strln "failure reason 22"; raise IList.Fail)
else
let e1'' = exp_partial_join e1 e2 in
Sil.Cast (t1, e1'')
| Sil.UnOp(unop1, e1, topt1), Sil.UnOp(unop2, e2, topt2) ->
if not (Sil.unop_equal unop1 unop2) then (L.d_strln "failure reason 23"; raise Fail)
if not (Sil.unop_equal unop1 unop2) then (L.d_strln "failure reason 23"; raise IList.Fail)
else Sil.UnOp (unop1, exp_partial_join e1 e2, topt1) (* should be topt1 = topt2 *)
| Sil.BinOp(Sil.PlusPI, e1, e1'), Sil.BinOp(Sil.PlusPI, e2, e2') ->
let e1'' = exp_partial_join e1 e2 in
@ -955,16 +955,16 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| _ -> FreshVarExp.get_fresh_exp e1 e2 in
Sil.BinOp(Sil.PlusPI, e1'', e2'')
| Sil.BinOp(binop1, e1, e1'), Sil.BinOp(binop2, e2, e2') ->
if not (Sil.binop_equal binop1 binop2) then (L.d_strln "failure reason 24"; raise Fail)
if not (Sil.binop_equal binop1 binop2) then (L.d_strln "failure reason 24"; raise IList.Fail)
else
let e1'' = exp_partial_join e1 e2 in
let e2'' = exp_partial_join e1' e2' in
Sil.BinOp(binop1, e1'', e2'')
| Sil.Lvar(pvar1), Sil.Lvar(pvar2) ->
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 25"; raise Fail)
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 25"; raise IList.Fail)
else e1
| Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, t2) ->
if not (Sil.fld_equal f1 f2) then (L.d_strln "failure reason 26"; raise Fail)
if not (Sil.fld_equal f1 f2) then (L.d_strln "failure reason 26"; raise IList.Fail)
else Sil.Lfield(exp_partial_join e1 e2, f1, t1) (* should be t1 = t2 *)
| Sil.Lindex(e1, e1'), Sil.Lindex(e2, e2') ->
let e1'' = exp_partial_join e1 e2 in
@ -974,7 +974,7 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
Sil.Sizeof (typ_partial_join t1 t2, Sil.Subtype.join st1 st2)
| _ ->
L.d_str "exp_partial_join no match "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln ();
raise Fail
raise IList.Fail
and size_partial_join size1 size2 = match size1, size2 with
| Sil.BinOp(Sil.PlusA, e1, Sil.Const c1), Sil.BinOp(Sil.PlusA, e2, Sil.Const c2) ->
@ -997,7 +997,7 @@ and typ_partial_join t1 t2 = match t1, t2 with
| _ when Sil.typ_equal t1 t2 -> t1 (* common case *)
| _ ->
L.d_str "typ_partial_join no match "; Sil.d_typ_full t1; L.d_str " "; Sil.d_typ_full t2; L.d_ln ();
raise Fail
raise IList.Fail
let rec exp_partial_meet (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
match e1, e2 with
@ -1006,23 +1006,23 @@ let rec exp_partial_meet (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Var id, Sil.Const _ ->
if not (Ident.is_normal id) then
Rename.extend e1 e2 (Rename.ExtDefault(e2))
else (L.d_strln "failure reason 27"; raise Fail)
else (L.d_strln "failure reason 27"; raise IList.Fail)
| Sil.Const _, Sil.Var id ->
if not (Ident.is_normal id) then
Rename.extend e1 e2 (Rename.ExtDefault(e1))
else (L.d_strln "failure reason 28"; raise Fail)
else (L.d_strln "failure reason 28"; raise IList.Fail)
| Sil.Const c1, Sil.Const c2 ->
if (Sil.const_equal c1 c2) then e1 else (L.d_strln "failure reason 29"; raise Fail)
if (Sil.const_equal c1 c2) then e1 else (L.d_strln "failure reason 29"; raise IList.Fail)
| Sil.Cast(t1, e1), Sil.Cast(t2, e2) ->
if not (Sil.typ_equal t1 t2) then (L.d_strln "failure reason 30"; raise Fail)
if not (Sil.typ_equal t1 t2) then (L.d_strln "failure reason 30"; raise IList.Fail)
else
let e1'' = exp_partial_meet e1 e2 in
Sil.Cast (t1, e1'')
| Sil.UnOp(unop1, e1, topt1), Sil.UnOp(unop2, e2, topt2) ->
if not (Sil.unop_equal unop1 unop2) then (L.d_strln "failure reason 31"; raise Fail)
if not (Sil.unop_equal unop1 unop2) then (L.d_strln "failure reason 31"; raise IList.Fail)
else Sil.UnOp (unop1, exp_partial_meet e1 e2, topt1) (* should be topt1 = topt2 *)
| Sil.BinOp(binop1, e1, e1'), Sil.BinOp(binop2, e2, e2') ->
if not (Sil.binop_equal binop1 binop2) then (L.d_strln "failure reason 32"; raise Fail)
if not (Sil.binop_equal binop1 binop2) then (L.d_strln "failure reason 32"; raise IList.Fail)
else
let e1'' = exp_partial_meet e1 e2 in
let e2'' = exp_partial_meet e1' e2' in
@ -1030,26 +1030,26 @@ let rec exp_partial_meet (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Var id, Sil.Lvar _ ->
if not (Ident.is_normal id) then
Rename.extend e1 e2 (Rename.ExtDefault(e2))
else (L.d_strln "failure reason 33"; raise Fail)
else (L.d_strln "failure reason 33"; raise IList.Fail)
| Sil.Lvar _, Sil.Var id ->
if not (Ident.is_normal id) then
Rename.extend e1 e2 (Rename.ExtDefault(e1))
else (L.d_strln "failure reason 34"; raise Fail)
else (L.d_strln "failure reason 34"; raise IList.Fail)
| Sil.Lvar(pvar1), Sil.Lvar(pvar2) ->
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 35"; raise Fail)
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 35"; raise IList.Fail)
else e1
| Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, t2) ->
if not (Sil.fld_equal f1 f2) then (L.d_strln "failure reason 36"; raise Fail)
if not (Sil.fld_equal f1 f2) then (L.d_strln "failure reason 36"; raise IList.Fail)
else Sil.Lfield(exp_partial_meet e1 e2, f1, t1) (* should be t1 = t2 *)
| Sil.Lindex(e1, e1'), Sil.Lindex(e2, e2') ->
let e1'' = exp_partial_meet e1 e2 in
let e2'' = exp_partial_meet e1' e2' in
Sil.Lindex(e1'', e2'')
| _ -> (L.d_strln "failure reason 37"; raise Fail)
| _ -> (L.d_strln "failure reason 37"; raise IList.Fail)
let exp_list_partial_join = list_map2 exp_partial_join
let exp_list_partial_join = IList.map2 exp_partial_join
let exp_list_partial_meet = list_map2 exp_partial_meet
let exp_list_partial_meet = IList.map2 exp_partial_meet
let run_without_absval f e1 e2 =
let old_abs_val = !Config.abs_val in
@ -1080,12 +1080,12 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S
let rec f_fld_se_list inst mode acc fld_se_list1 fld_se_list2 =
match fld_se_list1, fld_se_list2 with
| [], [] -> Sil.Estruct (list_rev acc, inst)
| [], [] -> Sil.Estruct (IList.rev acc, inst)
| [], other_fsel | other_fsel, [] ->
begin
match mode with
| JoinState.Pre -> (L.d_strln "failure reason 42"; raise Fail)
| JoinState.Post -> Sil.Estruct (list_rev acc, inst)
| JoinState.Pre -> (L.d_strln "failure reason 42"; raise IList.Fail)
| JoinState.Post -> Sil.Estruct (IList.rev acc, inst)
end
| (fld1, se1):: fld_se_list1', (fld2, se2):: fld_se_list2' ->
let comparison = Sil.fld_compare fld1 fld2 in
@ -1096,7 +1096,7 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S
else begin
match mode with
| JoinState.Pre ->
(L.d_strln "failure reason 43"; raise Fail)
(L.d_strln "failure reason 43"; raise IList.Fail)
| JoinState.Post ->
if comparison < 0 then begin
f_fld_se_list inst mode acc fld_se_list1' fld_se_list2
@ -1110,13 +1110,13 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S
let rec f_idx_se_list inst size idx_se_list_acc idx_se_list1 idx_se_list2 =
match idx_se_list1, idx_se_list2 with
| [], [] -> Sil.Earray (size, list_rev idx_se_list_acc, inst)
| [], [] -> Sil.Earray (size, IList.rev idx_se_list_acc, inst)
| [], other_isel | other_isel, [] ->
begin
match mode with
| JoinState.Pre -> (L.d_strln "failure reason 44"; raise Fail)
| JoinState.Pre -> (L.d_strln "failure reason 44"; raise IList.Fail)
| JoinState.Post ->
Sil.Earray (size, list_rev idx_se_list_acc, inst)
Sil.Earray (size, IList.rev idx_se_list_acc, inst)
end
| (idx1, se1):: idx_se_list1', (idx2, se2):: idx_se_list2' ->
let idx = exp_partial_join idx1 idx2 in
@ -1134,19 +1134,19 @@ let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : S
let size = size_partial_join size1 size2 in
let inst = Sil.inst_partial_join inst1 inst2 in
f_idx_se_list inst size [] idx_se_list1 idx_se_list2
| _ -> L.d_strln "no match in strexp_partial_join"; raise Fail
| _ -> L.d_strln "no match in strexp_partial_join"; raise IList.Fail
let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.strexp =
let construct side rev_list ref_list =
let construct_offset_se (off, se) = (off, strexp_construct_fresh side se) in
let acc = list_map construct_offset_se ref_list in
list_rev_with_acc acc rev_list in
let acc = IList.map construct_offset_se ref_list in
IList.rev_with_acc acc rev_list in
let rec f_fld_se_list inst acc fld_se_list1 fld_se_list2 =
match fld_se_list1, fld_se_list2 with
| [], [] ->
Sil.Estruct (list_rev acc, inst)
Sil.Estruct (IList.rev acc, inst)
| [], _ ->
Sil.Estruct (construct Rhs acc fld_se_list2, inst)
| _, [] ->
@ -1169,7 +1169,7 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st
let rec f_idx_se_list inst size acc idx_se_list1 idx_se_list2 =
match idx_se_list1, idx_se_list2 with
| [],[] ->
Sil.Earray (size, list_rev acc, inst)
Sil.Earray (size, IList.rev acc, inst)
| [], _ ->
Sil.Earray (size, construct Rhs acc idx_se_list2, inst)
| _, [] ->
@ -1190,7 +1190,7 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st
when Sil.exp_equal size1 size2 ->
let inst = Sil.inst_partial_meet inst1 inst2 in
f_idx_se_list inst size1 [] idx_se_list1 idx_se_list2
| _ -> (L.d_strln "failure reason 52"; raise Fail)
| _ -> (L.d_strln "failure reason 52"; raise IList.Fail)
(** {2 Join and Meet for kind, hpara, hpara_dll} *)
@ -1210,7 +1210,7 @@ let hpara_partial_join (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara =
else if Match.hpara_match_with_impl true hpara1 hpara2 then
hpara2
else
(L.d_strln "failure reason 53"; raise Fail)
(L.d_strln "failure reason 53"; raise IList.Fail)
let hpara_partial_meet (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara =
if Match.hpara_match_with_impl true hpara2 hpara1 then
@ -1218,7 +1218,7 @@ let hpara_partial_meet (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara =
else if Match.hpara_match_with_impl true hpara1 hpara2 then
hpara1
else
(L.d_strln "failure reason 54"; raise Fail)
(L.d_strln "failure reason 54"; raise IList.Fail)
let hpara_dll_partial_join (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll =
if Match.hpara_dll_match_with_impl true hpara2 hpara1 then
@ -1226,7 +1226,7 @@ let hpara_dll_partial_join (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil
else if Match.hpara_dll_match_with_impl true hpara1 hpara2 then
hpara2
else
(L.d_strln "failure reason 55"; raise Fail)
(L.d_strln "failure reason 55"; raise IList.Fail)
let hpara_dll_partial_meet (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll =
if Match.hpara_dll_match_with_impl true hpara2 hpara1 then
@ -1234,7 +1234,7 @@ let hpara_dll_partial_meet (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil
else if Match.hpara_dll_match_with_impl true hpara1 hpara2 then
hpara1
else
(L.d_strln "failure reason 56"; raise Fail)
(L.d_strln "failure reason 56"; raise IList.Fail)
(** {2 Join and Meet for hpred} *)
@ -1257,7 +1257,7 @@ let hpred_partial_join mode (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpr
let iF', iB' =
if (fwd1 && fwd2) then (e, exp_partial_join iB1 iB2)
else if (not fwd1 && not fwd2) then (exp_partial_join iF1 iF2, e)
else (L.d_strln "failure reason 57"; raise Fail) in
else (L.d_strln "failure reason 57"; raise IList.Fail) in
let oF' = exp_partial_join oF1 oF2 in
let oB' = exp_partial_join oB1 oB2 in
let shared' = exp_list_partial_join shared1 shared2 in
@ -1271,7 +1271,7 @@ let hpred_partial_meet (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (
| Sil.Hpointsto (e1, se1, te1), Sil.Hpointsto (e2, se2, te2) when Sil.exp_equal te1 te2 ->
Prop.mk_ptsto e (strexp_partial_meet se1 se2) te1
| Sil.Hpointsto _, _ | _, Sil.Hpointsto _ ->
(L.d_strln "failure reason 58"; raise Fail)
(L.d_strln "failure reason 58"; raise IList.Fail)
| Sil.Hlseg (k1, hpara1, root1, next1, shared1), Sil.Hlseg (k2, hpara2, root2, next2, shared2) ->
let hpara' = hpara_partial_meet hpara1 hpara2 in
let next' = exp_partial_meet next1 next2 in
@ -1285,7 +1285,7 @@ let hpred_partial_meet (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (
let iF', iB' =
if (fwd1 && fwd2) then (e, exp_partial_meet iB1 iB2)
else if (not fwd1 && not fwd2) then (exp_partial_meet iF1 iF2, e)
else (L.d_strln "failure reason 59"; raise Fail) in
else (L.d_strln "failure reason 59"; raise IList.Fail) in
let oF' = exp_partial_meet oF1 oF2 in
let oB' = exp_partial_meet oB1 oB2 in
let shared' = exp_list_partial_meet shared1 shared2 in
@ -1308,7 +1308,7 @@ let find_hpred_by_address (e: Sil.exp) (sigma: sigma) : Sil.hpred option * sigma
| [] -> None, sigma
| hpred:: sigma ->
if contains_e hpred then
Some hpred, (list_rev sigma_acc) @ sigma
Some hpred, (IList.rev sigma_acc) @ sigma
else
f (hpred:: sigma_acc) sigma in
f [] sigma
@ -1339,7 +1339,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
let lookup_and_expand side e e' =
match (Rename.get_others side e, side) with
| None, _ -> (L.d_strln "failure reason 60"; raise Fail)
| None, _ -> (L.d_strln "failure reason 60"; raise IList.Fail)
| Some(e_res, e_op), Lhs -> (e_res, exp_partial_join e' e_op)
| Some(e_res, e_op), Rhs -> (e_res, exp_partial_join e_op e') in
@ -1401,7 +1401,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
'todo' describes the start point. *)
let cut_sigma side todo (target: sigma) (other: sigma) =
let list_is_empty l = if l != [] then (L.d_strln "failure reason 61"; raise Fail) in
let list_is_empty l = if l != [] then (L.d_strln "failure reason 61"; raise IList.Fail) in
let x = Todo.take () in
Todo.push todo;
let res =
@ -1455,7 +1455,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
let sigma_acc' = join_list_and_non Lhs e lseg e1 e2 :: sigma_acc in
sigma_partial_join' mode sigma_acc' sigma1 sigma2
else
(L.d_strln "failure reason 62"; raise Fail)
(L.d_strln "failure reason 62"; raise IList.Fail)
| None, Some (Sil.Hlseg (k, _, _, _, _) as lseg)
| None, Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg) ->
@ -1463,9 +1463,9 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
let sigma_acc' = join_list_and_non Rhs e lseg e2 e1 :: sigma_acc in
sigma_partial_join' mode sigma_acc' sigma1 sigma2
else
(L.d_strln "failure reason 63"; raise Fail)
(L.d_strln "failure reason 63"; raise IList.Fail)
| None, _ | _, None -> (L.d_strln "failure reason 64"; raise Fail)
| None, _ | _, None -> (L.d_strln "failure reason 64"; raise IList.Fail)
| Some (hpred1), Some (hpred2) when same_pred hpred1 hpred2 ->
let hpred_res1 = hpred_partial_join mode todo_curr hpred1 hpred2 in
@ -1517,7 +1517,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
with Todo.Empty ->
match sigma1_in, sigma2_in with
| _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
| _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise IList.Fail
| _ -> sigma_acc, sigma1_in, sigma2_in
let sigma_partial_join mode (sigma1: sigma) (sigma2: sigma) : (sigma * sigma * sigma) =
@ -1530,7 +1530,7 @@ let sigma_partial_join mode (sigma1: sigma) (sigma2: sigma) : (sigma * sigma * s
else begin
L.d_strln "failed Rename.check";
CheckJoin.final ();
raise Fail
raise IList.Fail
end
with
| exn -> (CheckJoin.final (); raise exn)
@ -1565,12 +1565,12 @@ let rec sigma_partial_meet' (sigma_acc: sigma) (sigma1_in: sigma) (sigma2_in: si
sigma_partial_meet' (hpred':: sigma_acc) sigma1 sigma2
| Some _, Some _ ->
(L.d_strln "failure reason 65"; raise Fail)
(L.d_strln "failure reason 65"; raise IList.Fail)
with Todo.Empty ->
match sigma1_in, sigma2_in with
| [], [] -> sigma_acc
| _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
| _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise IList.Fail
let sigma_partial_meet (sigma1: sigma) (sigma2: sigma) : sigma =
sigma_partial_meet' [] sigma1 sigma2
@ -1595,13 +1595,13 @@ let pi_partial_join mode
| Sil.Hpointsto (_, Sil.Earray (Sil.Const (Sil.Cint n), _, _), _) ->
(if Sil.Int.geq n Sil.Int.one then size_list := n::!size_list)
| _ -> () in
list_iter do_hpred (Prop.get_sigma prop);
IList.iter do_hpred (Prop.get_sigma prop);
!size_list in
let bounds =
let bounds1 = get_array_size ep1 in
let bounds2 = get_array_size ep2 in
let bounds_sorted = list_sort Sil.Int.compare_value (bounds1@bounds2) in
list_rev (list_remove_duplicates Sil.Int.compare_value bounds_sorted) in
let bounds_sorted = IList.sort Sil.Int.compare_value (bounds1@bounds2) in
IList.rev (IList.remove_duplicates Sil.Int.compare_value bounds_sorted) in
let widening_atom a =
(* widening heuristic for upper bound: take the size of some array, -2 and -1 *)
match Prop.atom_exp_le_const a, bounds with
@ -1639,11 +1639,11 @@ let pi_partial_join mode
(* check for atoms in pre mode: fail if the negation is implied by the other side *)
let not_a = Prop.atom_negate a in
if (Prover.check_atom p not_a) then
(L.d_str "join_atom_check failed on "; Sil.d_atom a; L.d_ln (); raise Fail) in
(L.d_str "join_atom_check failed on "; Sil.d_atom a; L.d_ln (); raise IList.Fail) in
let join_atom_check_attribute p a =
(* check for attribute: fail if the attribute is not in the other side *)
if not (Prover.check_atom p a) then
(L.d_str "join_atom_check_attribute failed on "; Sil.d_atom a; L.d_ln (); raise Fail) in
(L.d_str "join_atom_check_attribute failed on "; Sil.d_atom a; L.d_ln (); raise IList.Fail) in
let join_atom side p_op pi_op a =
(* try to find the atom corresponding to a on the other side, and check if it is implied *)
match Rename.get_other_atoms side a with
@ -1658,10 +1658,10 @@ let pi_partial_join mode
begin
match Prop.atom_const_lt_exp a_op with
| None -> Some a_res
| Some (n, e) -> if list_exists (is_stronger_lt n e) pi_op then (widening_atom a_res) else Some a_res
| Some (n, e) -> if IList.exists (is_stronger_lt n e) pi_op then (widening_atom a_res) else Some a_res
end
| Some (e, n) ->
if list_exists (is_stronger_le e n) pi_op then (widening_atom a_res) else Some a_res
if IList.exists (is_stronger_le e n) pi_op then (widening_atom a_res) else Some a_res
end in
let handle_atom_with_widening size p_op pi_op atom_list a =
(* find a join for the atom, if it fails apply widening heuristing and try again *)
@ -1691,17 +1691,17 @@ let pi_partial_join mode
end;
let atom_list1 =
let p2 = Prop.normalize ep2 in
list_fold_left (handle_atom_with_widening Lhs p2 pi2) [] pi1 in
IList.fold_left (handle_atom_with_widening Lhs p2 pi2) [] pi1 in
if !Config.trace_join then (L.d_str "atom_list1: "; Prop.d_pi atom_list1; L.d_ln ());
let atom_list_combined =
let p1 = Prop.normalize ep1 in
list_fold_left (handle_atom_with_widening Rhs p1 pi1) atom_list1 pi2 in
IList.fold_left (handle_atom_with_widening Rhs p1 pi1) atom_list1 pi2 in
if !Config.trace_join then (L.d_str "atom_list_combined: "; Prop.d_pi atom_list_combined; L.d_ln ());
let atom_list_filtered =
list_filter filter_atom atom_list_combined in
IList.filter filter_atom atom_list_combined in
if !Config.trace_join then (L.d_str "atom_list_filtered: "; Prop.d_pi atom_list_filtered; L.d_ln ());
let atom_list_res =
list_rev atom_list_filtered in
IList.rev atom_list_filtered in
atom_list_res
end
@ -1714,9 +1714,9 @@ let pi_partial_meet (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop.t) :
let handle_atom sub dom atom =
let fav_list = Sil.fav_to_list (Sil.atom_fav atom) in
if list_for_all (fun id -> Ident.IdentSet.mem id dom) fav_list then
if IList.for_all (fun id -> Ident.IdentSet.mem id dom) fav_list then
Sil.atom_sub sub atom
else (L.d_str "handle_atom failed on "; Sil.d_atom atom; L.d_ln (); raise Fail) in
else (L.d_str "handle_atom failed on "; Sil.d_atom atom; L.d_ln (); raise IList.Fail) in
let f1 p' atom =
Prop.prop_atom_and p' (handle_atom sub1 dom1 atom) in
let f2 p' atom =
@ -1725,9 +1725,9 @@ let pi_partial_meet (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop.t) :
let pi1 = Prop.get_pi ep1 in
let pi2 = Prop.get_pi ep2 in
let p_pi1 = list_fold_left f1 p pi1 in
let p_pi2 = list_fold_left f2 p_pi1 pi2 in
if (Prover.check_inconsistency_base p_pi2) then (L.d_strln "check_inconsistency_base failed"; raise Fail)
let p_pi1 = IList.fold_left f1 p pi1 in
let p_pi2 = IList.fold_left f2 p_pi1 pi2 in
if (Prover.check_inconsistency_base p_pi2) then (L.d_strln "check_inconsistency_base failed"; raise IList.Fail)
else p_pi2
(** {2 Join and Meet for Prop} *)
@ -1739,20 +1739,20 @@ let eprop_partial_meet (ep1: 'a Prop.t) (ep2: 'b Prop.t) : 'c Prop.t =
let es1 = sigma_get_start_lexps_sort sigma1 in
let es2 = sigma_get_start_lexps_sort sigma2 in
let es = list_merge_sorted_nodup Sil.exp_compare [] es1 es2 in
let es = IList.merge_sorted_nodup Sil.exp_compare [] es1 es2 in
let sub_check _ =
let sub1 = Prop.get_sub ep1 in
let sub2 = Prop.get_sub ep2 in
let range1 = Sil.sub_range sub1 in
let f e = Sil.fav_for_all (Sil.exp_fav e) Ident.is_normal in
Sil.sub_equal sub1 sub2 && list_for_all f range1 in
Sil.sub_equal sub1 sub2 && IList.for_all f range1 in
if not (sub_check ()) then
(L.d_strln "sub_check() failed"; raise Fail)
(L.d_strln "sub_check() failed"; raise IList.Fail)
else begin
let todos = list_map (fun x -> (x, x, x)) es in
list_iter Todo.push todos;
let todos = IList.map (fun x -> (x, x, x)) es in
IList.iter Todo.push todos;
let sigma_new = sigma_partial_meet sigma1 sigma2 in
let ep = Prop.replace_sigma sigma_new ep1 in
let ep' = Prop.replace_pi [] ep in
@ -1772,7 +1772,7 @@ let prop_partial_meet p1 p2 =
begin
Rename.final (); FreshVarExp.final (); Todo.final ();
match exn with
| Fail -> None
| IList.Fail -> None
| _ -> raise exn
end
@ -1783,7 +1783,7 @@ let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.
let es1 = sigma_get_start_lexps_sort sigma1 in
let es2 = sigma_get_start_lexps_sort sigma2 in
let simple_check = list_length es1 = list_length es2 in
let simple_check = IList.length es1 = IList.length es2 in
let rec expensive_check es1' es2' =
match (es1', es2') with
| [], [] -> true
@ -1798,7 +1798,7 @@ let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.
let f e = Sil.fav_for_all (Sil.exp_fav e) Ident.is_normal in
Sil.sub_range_partition f sub_common in
let eqs1, eqs2 =
let sub_to_eqs sub = list_map (fun (id, e) -> Sil.Aeq(Sil.Var id, e)) (Sil.sub_to_list sub) in
let sub_to_eqs sub = IList.map (fun (id, e) -> Sil.Aeq(Sil.Var id, e)) (Sil.sub_to_list sub) in
let eqs1 = sub_to_eqs sub1_only @ sub_to_eqs sub_common_other in
let eqs2 = sub_to_eqs sub2_only in
(eqs1, eqs2) in
@ -1808,10 +1808,10 @@ let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.
begin
if not simple_check then L.d_strln "simple_check failed"
else L.d_strln "expensive_check failed";
raise Fail
raise IList.Fail
end;
let todos = list_map (fun x -> (x, x, x)) es1 in
list_iter Todo.push todos;
let todos = IList.map (fun x -> (x, x, x)) es1 in
IList.iter Todo.push todos;
match sigma_partial_join mode sigma1 sigma2 with
| sigma_new, [], [] ->
L.d_strln "sigma_partial_join succeeded";
@ -1827,10 +1827,10 @@ let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.
L.d_strln "pi_partial_join succeeded";
let pi_from_fresh_vars = FreshVarExp.get_induced_pi () in
let pi_all = pi' @ pi_from_fresh_vars in
list_fold_left Prop.prop_atom_and p_sub_sigma pi_all in
IList.fold_left Prop.prop_atom_and p_sub_sigma pi_all in
p_sub_sigma_pi
| _ ->
L.d_strln "leftovers not empty"; raise Fail
L.d_strln "leftovers not empty"; raise IList.Fail
let footprint_partial_join' (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.t) : Prop.normal Prop.t * Prop.normal Prop.t =
if not !Config.footprint then p1, p2
@ -1841,11 +1841,11 @@ let footprint_partial_join' (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.t) :
let fp_pi = (* Prop.get_pure efp in *)
let fp_pi0 = Prop.get_pure efp in
let f a = Sil.fav_for_all (Sil.atom_fav a) Ident.is_footprint in
list_filter f fp_pi0 in
IList.filter f fp_pi0 in
let fp_sigma = (* Prop.get_sigma efp in *)
let fp_sigma0 = Prop.get_sigma efp in
let f a = Sil.fav_exists (Sil.hpred_fav a) (fun a -> not (Ident.is_footprint a)) in
if list_exists f fp_sigma0 then (L.d_strln "failure reason 66"; raise Fail);
if IList.exists f fp_sigma0 then (L.d_strln "failure reason 66"; raise IList.Fail);
fp_sigma0 in
let ep1' = Prop.replace_sigma_footprint fp_sigma (Prop.replace_pi_footprint fp_pi p1) in
let ep2' = Prop.replace_sigma_footprint fp_sigma (Prop.replace_pi_footprint fp_pi p2) in
@ -1875,7 +1875,7 @@ let prop_partial_join pname tenv mode p1 p2 =
begin
Rename.final (); FreshVarExp.final (); Todo.final ();
(if !Config.footprint then JoinState.set_footprint false);
(match exn with Fail -> None | _ -> raise exn)
(match exn with IList.Fail -> None | _ -> raise exn)
end
end
| Some _ -> res_by_implication_only
@ -1892,7 +1892,7 @@ let eprop_partial_join mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t
let list_reduce name dd f list =
let rec element_list_reduce acc (x, p1) = function
| [] -> ((x, p1), list_rev acc)
| [] -> ((x, p1), IList.rev acc)
| (y, p2):: ys -> begin
L.d_strln ("COMBINE[" ^ name ^ "] ....");
L.d_str "ENTRY1: "; L.d_ln (); dd x; L.d_ln ();
@ -1908,7 +1908,7 @@ let list_reduce name dd f list =
element_list_reduce acc (x', p1) ys
end in
let rec reduce acc = function
| [] -> list_rev acc
| [] -> IList.rev acc
| x:: xs ->
let (x', xs') = element_list_reduce [] x xs in
reduce (x':: acc) xs' in
@ -1929,7 +1929,7 @@ let jprop_partial_join mode jp1 jp2 =
let p = eprop_partial_join mode p1 p2 in
let p_renamed = Prop.prop_rename_primed_footprint_vars p in
Some (Specs.Jprop.Joined (0, p_renamed, jp1, jp2))
with Fail -> None
with IList.Fail -> None
let jplist_collapse mode jplist =
let f = jprop_partial_join mode in
@ -1946,21 +1946,21 @@ let jprop_list_add_ids jplist =
let jp2' = do_jprop jp2 in
incr seq_number;
Specs.Jprop.Joined (!seq_number, p, jp1', jp2') in
list_map (fun (p, path) -> (do_jprop p, path)) jplist
IList.map (fun (p, path) -> (do_jprop p, path)) jplist
let proplist_collapse mode plist =
let jplist = list_map (fun (p, path) -> (Specs.Jprop.Prop (0, p), path)) plist in
let jplist = IList.map (fun (p, path) -> (Specs.Jprop.Prop (0, p), path)) plist in
let jplist_joined = jplist_collapse mode (jplist_collapse mode jplist) in
jprop_list_add_ids jplist_joined
let proplist_collapse_pre plist =
let plist' = list_map (fun p -> (p, ())) plist in
list_map fst (proplist_collapse JoinState.Pre plist')
let plist' = IList.map (fun p -> (p, ())) plist in
IList.map fst (proplist_collapse JoinState.Pre plist')
let pathset_collapse pset =
let plist = Paths.PathSet.elements pset in
let plist' = proplist_collapse JoinState.Post plist in
Paths.PathSet.from_renamed_list (list_map (fun (p, path) -> (Specs.Jprop.to_prop p, path)) plist')
Paths.PathSet.from_renamed_list (IList.map (fun (p, path) -> (Specs.Jprop.to_prop p, path)) plist')
let join_time = ref 0.0
@ -1975,7 +1975,7 @@ let pathset_join
let ppalist1 = pset_to_plist pset1 in
let ppalist2 = pset_to_plist pset2 in
let rec join_proppath_plist ppalist2_acc ((p2, pa2) as ppa2) = function
| [] -> (ppa2, list_rev ppalist2_acc)
| [] -> (ppa2, IList.rev ppalist2_acc)
| ((p2', pa2') as ppa2') :: ppalist2_rest -> begin
L.d_strln ".... JOIN ....";
L.d_strln "JOIN SYM HEAP1: "; Prop.d_prop p2; L.d_ln ();
@ -1997,7 +1997,7 @@ let pathset_join
let (ppa2_new, ppalist1_cur') = join_proppath_plist [] ppa2'' ppalist1_cur in
join ppalist1_cur' (ppa2_new:: ppalist2_acc') ppalist2_rest' in
let _ppalist1_res, _ppalist2_res = join ppalist1 [] ppalist2 in
let ren l = list_map (fun (p, x) -> (Prop.prop_rename_primed_footprint_vars p, x)) l in
let ren l = IList.map (fun (p, x) -> (Prop.prop_rename_primed_footprint_vars p, x)) l in
let ppalist1_res, ppalist2_res = ren _ppalist1_res, ren _ppalist2_res in
let res = (Paths.PathSet.from_renamed_list ppalist1_res, Paths.PathSet.from_renamed_list ppalist2_res) in
join_time := !join_time +. (Unix.gettimeofday () -. initial_time);
@ -2034,10 +2034,10 @@ let proplist_meet_generate plist =
(* use porig instead of pcombined because it might be combinable with more othe props *)
(* e.g. porig might contain a global var to add to the ture branch of a conditional *)
(* but pcombined might have been combined with the false branch already *)
let pplist' = list_map (combine porig) pplist in
let pplist' = IList.map (combine porig) pplist in
props_done := Propset.add pcombined !props_done;
proplist_meet pplist' in
proplist_meet (list_map (fun p -> (p, p)) plist);
proplist_meet (IList.map (fun p -> (p, p)) plist);
!props_done

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

@ -98,7 +98,7 @@ let invisible_arrows = ref false
let print_stack_info = ref false
let exp_is_neq_zero e =
list_exists (fun e' -> Sil.exp_equal e e') !exps_neq_zero
IList.exists (fun e' -> Sil.exp_equal e e') !exps_neq_zero
(* replace a dollar sign in a name with a D. We need this because dotty get confused if there is*)
(* a dollar sign i a label*)
@ -220,7 +220,7 @@ let rec select_nodes_exp_lambda dotnodes e lambda =
(* this is written in this strange way for legacy reason. It should be changed a bit*)
let look_up dotnodes e lambda =
let r = select_nodes_exp_lambda dotnodes e lambda in
let r'= list_map get_coordinate_id r in
let r'= IList.map get_coordinate_id r in
r' @ look_up_for_back_pointer e dotnodes lambda
let pp_nesting fmt nesting =
@ -232,7 +232,7 @@ let reset_dotty_spec_counter () = spec_counter:= 0
let max_map f l =
let curr_max = ref 0 in
list_iter (fun x -> curr_max := max !curr_max (f x)) l;
IList.iter (fun x -> curr_max := max !curr_max (f x)) l;
! curr_max
let rec sigma_nesting_level sigma =
@ -284,7 +284,7 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list
let is_allocated d =
match d with
| Dotdangling(_, e, _) ->
list_exists (fun a -> match a with
IList.exists (fun a -> match a with
| Dotpointsto(_, e', _)
| Dotarray(_, _, e', _, _, _)
| Dotlseg(_, e', _, _, _, _)
@ -296,7 +296,7 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list
match l with
| [] -> []
| Dotdangling(coo, e, color):: l' ->
if (list_exists (Sil.exp_equal e) seen_exp) then filter_duplicate l' seen_exp
if (IList.exists (Sil.exp_equal e) seen_exp) then filter_duplicate l' seen_exp
else Dotdangling(coo, e, color):: filter_duplicate l' (e:: seen_exp)
| box:: l' -> box:: filter_duplicate l' seen_exp in (* this case cannot happen*)
let rec subtract_allocated candidate_dangling =
@ -305,7 +305,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 = list_flatten (list_map get_rhs_predicate sigma_lambda) in
let candidate_dangling = IList.flatten (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
@ -326,7 +326,7 @@ let rec dotty_mk_node pe sigma =
[Dotpointsto((mk_coordinate n lambda), e, e_color_str); Dotstruct((mk_coordinate (n + 1) lambda), e, l, e_color_str);]
| (Sil.Hpointsto (e, _, _), lambda) ->
let e_color_str = color_to_str (exp_color e) in
if list_mem Sil.exp_equal e !struct_exp_nodes then [] else
if IList.mem Sil.exp_equal e !struct_exp_nodes then [] else
[Dotpointsto((mk_coordinate n lambda), e, e_color_str)]
| (Sil.Hlseg (k, hpara, e1, e2, elist), lambda) ->
incr dotty_state_count; (* increment once more n+1 is the box for last element of the list *)
@ -349,10 +349,10 @@ let set_exps_neq_zero pi =
| Sil.Aneq (e, Sil.Const (Sil.Cint i)) when Sil.Int.iszero i -> exps_neq_zero := e :: !exps_neq_zero
| _ -> () in
exps_neq_zero := [];
list_iter f pi
IList.iter f pi
let box_dangling e =
let entry_e = list_filter (fun b -> match b with
let entry_e = IList.filter (fun b -> match b with
| Dotdangling(_, e', _) -> Sil.exp_equal e e' | _ -> false ) !dangling_dotboxes in
match entry_e with
|[] -> None
@ -382,8 +382,8 @@ let compute_fields_struct sigma =
let rec do_strexp se in_struct =
match se with
| Sil.Eexp (e, inst) -> if in_struct then fields_structs:= e ::!fields_structs else ()
| Sil.Estruct (l, _) -> list_iter (fun e -> do_strexp e true) (snd (list_split l))
| Sil.Earray (_, l, _) -> list_iter (fun e -> do_strexp e false) (snd (list_split l)) in
| Sil.Estruct (l, _) -> IList.iter (fun e -> do_strexp e true) (snd (IList.split l))
| Sil.Earray (_, l, _) -> IList.iter (fun e -> do_strexp e false) (snd (IList.split l)) in
let rec fs s =
match s with
| [] -> ()
@ -424,7 +424,7 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda =
)
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin
if IList.mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkStructToStruct, Ident.fieldname_to_string fn, n, e_no_special_char)]
end else
@ -460,7 +460,7 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda =
)
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin
if IList.mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkArrayToStruct, Sil.exp_to_string idx, n, e_no_special_char)]
end else
@ -483,15 +483,15 @@ let compute_target_from_eexp dotnodes e p f lambda =
[(LinkExpToExp, n', "")]
else
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
let nodes_e_no_struct = list_filter is_not_struct nodes_e in
let trg = list_map get_coordinate_id nodes_e_no_struct in
let nodes_e_no_struct = IList.filter is_not_struct nodes_e in
let trg = IList.map get_coordinate_id nodes_e_no_struct in
(match trg with
| [] ->
(match box_dangling e with
| None -> []
| Some n -> [(LinkExpToExp, n, "")]
)
| _ -> list_map (fun n -> (LinkExpToExp, n, "")) trg
| _ -> IList.map (fun n -> (LinkExpToExp, n, "")) trg
)
(* build the set of edges between nodes *)
@ -503,8 +503,8 @@ let rec dotty_mk_set_links dotnodes sigma p f =
| n:: nl ->
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 = list_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 = list_flatten (list_map ff (n:: nl)) in
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 trg_label = strip_special_chars (Sil.exp_to_string e) in
let lnk = mk_link (LinkToArray) (mk_coordinate n lambda) "" (mk_coordinate (n + 1) lambda) trg_label in
@ -518,16 +518,16 @@ let rec dotty_mk_set_links dotnodes sigma p f =
(match src with
| [] -> assert false
| nl ->
(* L.out "@\n@\n List of nl= "; list_iter (L.out " %i ") nl; L.out "@.@.@."; *)
(* L.out "@\n@\n List of nl= "; IList.iter (L.out " %i ") nl; L.out "@.@.@."; *)
let target_list = compute_target_struct_fields dotnodes lfld p f lambda in
let ff n = list_map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in
let ff n = IList.map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
let address_struct_id =
try get_coordinate_id (list_hd (list_filter (is_source_node_of_exp e) nodes_e))
try get_coordinate_id (IList.hd (IList.filter (is_source_node_of_exp e) nodes_e))
with exn when exn_not_timeout exn -> (* L.out "@\n@\n PROBLEMS!!!!!!!!!!@.@.@."; *) assert false in
(* we need to exclude the address node from the sorce of fields. no fields should start from there*)
let nl'= list_filter (fun id -> address_struct_id != id) nl in
let links_from_fields = list_flatten (list_map ff nl') in
let nl'= IList.filter (fun id -> address_struct_id != id) nl in
let links_from_fields = IList.flatten (IList.map ff nl') in
let trg_label = strip_special_chars (Sil.exp_to_string e) in
let lnk_from_address_struct = mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) "" (mk_coordinate (address_struct_id + 1) lambda) trg_label in
@ -540,8 +540,8 @@ let rec dotty_mk_set_links dotnodes sigma p f =
| [] -> assert false
| nl ->
let target_list = compute_target_from_eexp dotnodes e' p f lambda in
let ff n = list_map (fun (k, m, lab_target) -> mk_link k (mk_coordinate n lambda) "" (mk_coordinate m lambda) (strip_special_chars lab_target)) target_list in
let ll = list_flatten (list_map ff nl) in
let ff n = IList.map (fun (k, m, lab_target) -> 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
ll @ dotty_mk_set_links dotnodes sigma' p f
)
@ -550,7 +550,7 @@ let rec dotty_mk_set_links dotnodes sigma p f =
(match src with
| [] -> assert false
| n:: _ ->
let (_, m, lab) = list_hd (compute_target_from_eexp dotnodes e2 p f lambda) in
let (_, m, lab) = IList.hd (compute_target_from_eexp dotnodes e2 p f 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
)
@ -625,9 +625,9 @@ let dotty_pp_link f link =
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 = list_filter (fun n' -> not (list_mem Pervasives.(=) n' ln)) !tmp_links in
let remove_links_from ln = IList.filter (fun n' -> not (IList.mem Pervasives.(=) n' ln)) !tmp_links in
let remove_node n ns =
list_filter (fun n' -> match n' with
IList.filter (fun n' -> match n' with
| Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n)
| _ -> true
) ns in
@ -660,14 +660,14 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
(*L.out "@\n Found a spec expression = %s @.@." (Sil.exp_to_string e); *)
let links_from_node = boxes_pointed_by node links in
let links_to_node = boxes_pointing_at node links in
(* L.out "@\n Size of links_from=%i links_to=%i @.@." (list_length links_from_node) (list_length links_to_node); *)
(* L.out "@\n Size of links_from=%i links_to=%i @.@." (IList.length links_from_node) (IList.length links_to_node); *)
if links_to_node =[] then begin
tmp_links:= remove_links_from links_from_node ;
tmp_nodes:= remove_node node !tmp_nodes;
end
end
| _ -> () in
list_iter handle_one_node nodes;
IList.iter handle_one_node nodes;
(!tmp_nodes,!tmp_links)
(* print a struct node *)
@ -758,12 +758,12 @@ and build_visual_graph f pe p =
compute_fields_struct sigma;
compute_struct_exp_nodes sigma;
(* L.out "@\n@\n Computed fields structs: ";
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs;
IList.iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs;
L.out "@\n@.";
L.out "@\n@\n Computed exp structs nodes: ";
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes;
IList.iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes;
L.out "@\n@."; *)
let sigma_lambda = list_map (fun hp -> (hp,!lambda_counter)) sigma in
let sigma_lambda = IList.map (fun hp -> (hp,!lambda_counter)) sigma in
let nodes = (dotty_mk_node pe) sigma_lambda in
make_dangling_boxes pe nodes sigma_lambda;
let links = dotty_mk_set_links nodes sigma_lambda p f in
@ -815,8 +815,8 @@ and pp_dotty f kind (_prop: Prop.normal Prop.t) =
end;
(* F.fprintf f "\n subgraph cluster_%i { color=black \n" !dotty_state_count; *)
let (nodes, links) = build_visual_graph f pe prop in
list_iter (dotty_pp_state f pe) (nodes@ !dangling_dotboxes @ !nil_dotboxes);
list_iter (dotty_pp_link f) links;
IList.iter (dotty_pp_state f pe) (nodes@ !dangling_dotboxes @ !nil_dotboxes);
IList.iter (dotty_pp_link f) links;
(* F.fprintf f "\n } \n"; *)
F.fprintf f "\n } \n"
@ -832,7 +832,7 @@ let pp_dotty_one_spec f pre posts =
invisible_arrows:= true;
pp_dotty f (Spec_precondition) pre;
invisible_arrows:= false;
list_iter (fun (po, path) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po;
IList.iter (fun (po, path) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po;
for j = 1 to 4 do
F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre;
done
@ -847,7 +847,7 @@ let pp_dotty_prop_list_in_path f plist prev_n curr_n =
F.fprintf f "\n subgraph cluster_%i { color=blue \n" !dotty_state_count;
incr dotty_state_count;
F.fprintf f "\n state%iN [label=\"NODE %i \", style=filled, color= lightblue]\n" curr_n curr_n;
list_iter (fun po -> incr proposition_counter ; pp_dotty f (Generic_proposition) po) plist;
IList.iter (fun po -> incr proposition_counter ; pp_dotty f (Generic_proposition) po) plist;
if prev_n <> - 1 then F.fprintf f "\n state%iN ->state%iN\n" prev_n curr_n;
F.fprintf f "\n } \n"
with exn when exn_not_timeout exn ->
@ -875,7 +875,7 @@ let pp_proplist_parsed2dotty_file filename plist =
F.fprintf f "\n\n\ndigraph main { \nnode [shape=box];\n";
F.fprintf f "\n compound = true; \n";
F.fprintf f "\n /* size=\"12,7\"; ratio=fill;*/ \n";
ignore (list_map (pp_dotty f Generic_proposition) plist);
ignore (IList.map (pp_dotty f Generic_proposition) plist);
F.fprintf f "\n}" in
let outc = open_out filename in
let fmt = F.formatter_of_out_channel outc in
@ -892,11 +892,11 @@ let pp_cfgnodename fmt (n : Cfg.Node.t) =
F.fprintf fmt "%d" (Cfg.Node.get_id n)
let pp_etlist fmt etl =
list_iter (fun (id, ty) ->
IList.iter (fun (id, ty) ->
Format.fprintf fmt " %s:%a" id (Sil.pp_typ_full pe_text) ty) etl
let pp_local_list fmt etl =
list_iter (fun (id, ty) ->
IList.iter (fun (id, ty) ->
Format.fprintf fmt " %a:%a" Mangled.pp id (Sil.pp_typ_full pe_text) ty) etl
let pp_cfgnodelabel fmt (n : Cfg.Node.t) =
@ -914,7 +914,7 @@ let pp_cfgnodelabel fmt (n : Cfg.Node.t) =
gen
pp_etlist (Cfg.Procdesc.get_formals pdesc)
pp_local_list (Cfg.Procdesc.get_locals pdesc);
if list_length (Cfg.Procdesc.get_captured pdesc) <> 0 then
if IList.length (Cfg.Procdesc.get_captured pdesc) <> 0 then
Format.fprintf fmt "\\nCaptured: %a"
pp_local_list (Cfg.Procdesc.get_captured pdesc)
| Cfg.Node.Exit_node (pdesc) ->
@ -929,7 +929,7 @@ let pp_cfgnodelabel fmt (n : Cfg.Node.t) =
let str = pp_to_string pp () in
Escape.escape_dotty str in
let pp_instrs fmt instrs =
list_iter (fun i -> F.fprintf fmt " %s\\n " (instr_string i)) instrs in
IList.iter (fun i -> F.fprintf fmt " %s\\n " (instr_string i)) instrs in
let instrs = Cfg.Node.get_instrs n in
F.fprintf fmt "%d: %a \\n %a" (Cfg.Node.get_id n) pp_label n pp_instrs instrs
@ -957,8 +957,8 @@ let pp_cfgnode fmt (n: Cfg.Node.t) =
()
| _ ->
F.fprintf fmt "\n\t %d -> %d %s;" (Cfg.Node.get_id n1) (Cfg.Node.get_id n2) color in
list_iter (fun n' -> print_edge n n' false) (Cfg.Node.get_succs n);
list_iter (fun n' -> print_edge n n' true) (Cfg.Node.get_exn n)
IList.iter (fun n' -> print_edge n n' false) (Cfg.Node.get_succs n);
IList.iter (fun n' -> print_edge n n' true) (Cfg.Node.get_exn n)
(* * print control flow graph (in dot form) for fundec to channel let *)
(* print_cfg_channel (chan : out_channel) (fd : fundec) = let pnode (s: *)
@ -975,14 +975,14 @@ let print_icfg fmt cfg =
let loc = Cfg.Node.get_loc node in
if (!Config.dotty_cfg_libs || DB.source_file_equal loc.Location.file !DB.current_source) then
F.fprintf fmt "%a\n" pp_cfgnode node in
list_iter print_node (Cfg.Node.get_all_nodes cfg)
IList.iter print_node (Cfg.Node.get_all_nodes cfg)
let print_edges fmt edges =
let count = ref 0 in
let print_edge (n1, n2) =
incr count;
F.fprintf fmt "%a -> %a [color=\"red\" label=\"%d\" fontcolor=\"green\"];" pp_cfgnodename n1 pp_cfgnodename n2 !count in
list_iter print_edge edges
IList.iter print_edge edges
let print_icfg_dotty cfg (extra_edges : (Cfg.Node.t * Cfg.Node.t) list) =
let chan = open_out (DB.filename_to_string (DB.Results_dir.path_to_filename DB.Results_dir.Abs_source_dir [!Config.dotty_output])) in
@ -1012,7 +1012,7 @@ let pp_speclist_dotty f (splist: Prop.normal Specs.spec list) =
F.fprintf f "@\n@\n\ndigraph main { \nnode [shape=box]; @\n";
F.fprintf f "@\n compound = true; @\n";
(* F.fprintf f "\n size=\"12,7\"; ratio=fill; \n"; *)
list_iter (fun s -> pp_dotty_one_spec f (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts) splist;
IList.iter (fun s -> pp_dotty_one_spec f (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts) splist;
F.fprintf f "@\n}";
Config.pp_simple := pp_simple_saved
@ -1079,7 +1079,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 = list_filter (fun b -> match b with
let entry_e = IList.filter (fun b -> match b with
| VH_dangling(_, e') -> Sil.exp_equal e e' | _ -> false ) !set_dangling_nodes in
match entry_e with
|[] -> None
@ -1129,7 +1129,7 @@ let rec select_node_at_address nodes e =
(* look-up the ids in the list of nodes corresponding to expression e*)
(* let look_up_nodes_ids nodes e =
list_map get_node_id (select_nodes_exp nodes e) *)
IList.map get_node_id (select_nodes_exp nodes e) *)
(* create a list of dangling nodes *)
let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
@ -1150,7 +1150,7 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
| _ -> [] (* arrays and struct do not give danglings. CHECK THIS!*)
) in
let is_not_allocated e =
let allocated = list_exists (fun a -> match a with
let allocated = IList.exists (fun a -> match a with
| VH_pointsto(_, e', _, _)
| VH_lseg(_, e', _ , _)
| VH_dllseg(_, e', _, _, _, _) -> Sil.exp_equal e e'
@ -1160,12 +1160,12 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
match l with
| [] -> []
| e:: l' ->
if (list_exists (Sil.exp_equal e) seen_exp) then filter_duplicate l' seen_exp
if (IList.exists (Sil.exp_equal e) seen_exp) then filter_duplicate l' seen_exp
else e:: filter_duplicate l' (e:: seen_exp) in
let rhs_exp_list = list_flatten (list_map get_rhs_predicate sigma) in
let rhs_exp_list = IList.flatten (IList.map get_rhs_predicate sigma) in
let candidate_dangling_exps = filter_duplicate rhs_exp_list [] in
let dangling_exps = list_filter is_not_allocated candidate_dangling_exps in (* get rid of allocated ones*)
list_map make_new_dangling dangling_exps
let dangling_exps = IList.filter is_not_allocated candidate_dangling_exps in (* get rid of allocated ones*)
IList.map make_new_dangling dangling_exps
(* return a list of pairs (n,field_lab) where n is a target node*)
(* corresponding to se and is going to be used a target for and edge*)
@ -1212,7 +1212,7 @@ let rec make_visual_heap_edges nodes sigma prop =
| None -> assert false
| Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in
let ll = IList.map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop
)
| Sil.Hlseg (_, pred, e1, e2, elist):: sigma' ->
@ -1221,7 +1221,7 @@ let rec make_visual_heap_edges nodes sigma prop =
| None -> assert false
| Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in
let ll = IList.map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop
)
@ -1232,8 +1232,8 @@ let rec make_visual_heap_edges nodes sigma prop =
| Some n ->
let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in
let target_nodesB = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let llF = list_map (combine_source_target_label n) target_nodesF in
let llB = list_map (combine_source_target_label n) target_nodesB in
let llF = IList.map (combine_source_target_label n) target_nodesF in
let llB = IList.map (combine_source_target_label n) target_nodesB in
llF @ llB @ make_visual_heap_edges nodes sigma' prop
)
@ -1244,8 +1244,8 @@ let prop_to_set_of_visual_heaps prop =
incr global_node_counter;
while (!working_list!=[]) do
set_dangling_nodes:=[];
let (n, h) = list_hd !working_list in
working_list:= list_tl !working_list;
let (n, h) = IList.hd !working_list in
working_list:= IList.tl !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
@ -1259,10 +1259,10 @@ let rec pointsto_contents_to_xml (co: Sil.strexp) : Io_infer.Xml.node =
Io_infer.Xml.create_tree "cell" [("content-value", exp_to_xml_string e)] []
| Sil.Estruct (fel, _) ->
let f (fld, exp) = Io_infer.Xml.create_tree "struct-field" [("id", Ident.fieldname_to_string fld)] [(pointsto_contents_to_xml exp)] in
Io_infer.Xml.create_tree "struct" [] (list_map f fel)
Io_infer.Xml.create_tree "struct" [] (IList.map f fel)
| Sil.Earray (size, nel, _) ->
let f (e, se) = Io_infer.Xml.create_tree "array-element" [("index", exp_to_xml_string e)] [pointsto_contents_to_xml se] in
Io_infer.Xml.create_tree "array" [("size", exp_to_xml_string size)] (list_map f nel)
Io_infer.Xml.create_tree "array" [("size", exp_to_xml_string size)] (IList.map f nel)
(* Convert an atom to xml in a light version. Namely, the expressions are not fully blown-up into *)
(* xml tree but visualized as strings *)
@ -1278,7 +1278,7 @@ let atom_to_xml_light (a: Sil.atom) : Io_infer.Xml.node =
let xml_pure_info prop =
let pure = Prop.get_pure prop in
let xml_atom_list = list_map atom_to_xml_light pure in
let xml_atom_list = IList.map atom_to_xml_light pure in
Io_infer.Xml.create_tree "stack" [] xml_atom_list
(** Return a string describing the kind of a pointsto address *)
@ -1320,14 +1320,14 @@ let heap_edge_to_xml edge =
let visual_heap_to_xml heap =
let (n, nodes, edges) = heap in
let xml_heap_nodes = list_map heap_node_to_xml nodes in
let xml_heap_edges = list_map heap_edge_to_xml edges in
let xml_heap_nodes = IList.map heap_node_to_xml nodes in
let xml_heap_edges = IList.map heap_edge_to_xml edges in
Io_infer.Xml.create_tree "heap" [("id", string_of_int n)] (xml_heap_nodes @ xml_heap_edges)
(** convert a proposition to xml with the given tag and id *)
let prop_to_xml prop tag_name id =
let visual_heaps = prop_to_set_of_visual_heaps prop in
let xml_visual_heaps = list_map visual_heap_to_xml visual_heaps in
let xml_visual_heaps = IList.map visual_heap_to_xml visual_heaps in
let xml_pure_part = xml_pure_info prop in
let xml_graph = Io_infer.Xml.create_tree tag_name [("id", string_of_int id)] (xml_visual_heaps @ [xml_pure_part]) in
xml_graph
@ -1345,11 +1345,11 @@ let print_specs_xml signature specs loc fmt =
Prop.normalize _prop' in
let jj = ref 0 in
let xml_pre = prop_to_xml pre "precondition" !jj in
let xml_spec = xml_pre:: (list_map (fun (po, path) -> jj:=!jj + 1; prop_to_xml (add_stack_to_prop po) "postcondition" !jj) posts) in
let xml_spec = xml_pre:: (IList.map (fun (po, path) -> jj:=!jj + 1; prop_to_xml (add_stack_to_prop po) "postcondition" !jj) posts) in
Io_infer.Xml.create_tree "specification" [("id", string_of_int n)] xml_spec in
let j = ref 0 in
let list_of_specs_xml =
list_map
IList.map
(fun s ->
j:=!j + 1;
do_one_spec (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts !j)

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

@ -54,7 +54,7 @@ let find_variable_assigment node id : Sil.instr option =
res := Some instr;
true
| _ -> false in
ignore (list_exists find_set node_instrs);
ignore (IList.exists find_set node_instrs);
!res
(** Check if a nullify instruction exists for the program variable after the given instruction *)
@ -66,7 +66,7 @@ let find_nullify_after_instr node instr pvar : bool =
| _instr ->
if instr = _instr then found_instr := true;
false in
list_exists find_nullify node_instrs
IList.exists find_nullify node_instrs
(** Find the other prune node of a conditional (e.g. the false branch given the true branch of a conditional) *)
let find_other_prune_node node =
@ -104,10 +104,10 @@ let find_normal_variable_funcall
let node_instrs = Cfg.Node.get_instrs node in
let find_declaration = function
| Sil.Call ([id0], fun_exp, args, loc, call_flags) when Ident.equal id id0 ->
res := Some (fun_exp, list_map fst args, loc, call_flags);
res := Some (fun_exp, IList.map fst args, loc, call_flags);
true
| _ -> false in
ignore (list_exists find_declaration node_instrs);
ignore (IList.exists find_declaration node_instrs);
if !verbose && !res == None then (L.d_str ("find_normal_variable_funcall could not find " ^
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
!res
@ -126,7 +126,7 @@ let find_program_variable_assignment node pvar : (Cfg.Node.t * Ident.t) option =
res := Some (node, id);
true
| _ -> false in
if list_exists find_instr (Cfg.Node.get_instrs node)
if IList.exists find_instr (Cfg.Node.get_instrs node)
then !res
else match Cfg.Node.get_preds node with
| [pred_node] ->
@ -153,7 +153,7 @@ let find_ident_assignment node id : (Cfg.Node.t * Sil.exp) option =
res := Some (node, e);
true
| _ -> false in
if list_exists find_instr (Cfg.Node.get_instrs node)
if IList.exists find_instr (Cfg.Node.get_instrs node)
then !res
else match Cfg.Node.get_preds node with
| [pred_node] ->
@ -174,7 +174,7 @@ let rec find_boolean_assignment node pvar true_branch : Cfg.Node.t option =
| Sil.Set (Sil.Lvar _pvar, _, Sil.Const (Sil.Cint i), _) when Sil.pvar_equal pvar _pvar ->
Sil.Int.iszero i <> true_branch
| _ -> false in
list_exists filter (Cfg.Node.get_instrs n) in
IList.exists filter (Cfg.Node.get_instrs n) in
match Cfg.Node.get_preds node with
| [pred_node] -> find_boolean_assignment pred_node pvar true_branch
| [n1; n2] ->
@ -236,17 +236,17 @@ let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp
let fun_dexp = Sil.Dconst (Sil.Cfun pname) in
let args_dexp =
let args_dexpo = list_map (fun (e, _) -> _exp_rv_dexp seen node e) args in
if list_exists (fun x -> x = None) args_dexpo
let args_dexpo = IList.map (fun (e, _) -> _exp_rv_dexp seen node e) args in
if IList.exists (fun x -> x = None) args_dexpo
then []
else
let unNone = function Some x -> x | None -> assert false in
list_map unNone args_dexpo in
IList.map unNone args_dexpo in
res := Some (Sil.Dretcall (fun_dexp, args_dexp, loc, call_flags));
true
| _ -> false in
ignore (list_exists find_declaration node_instrs);
ignore (IList.exists find_declaration node_instrs);
if !verbose && !res == None then (L.d_str ("find_normal_variable_letderef could not find " ^
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
!res
@ -286,11 +286,11 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
match find_normal_variable_funcall node' id with
| Some (fun_exp, eargs, loc, call_flags) ->
let fun_dexpo = _exp_rv_dexp seen node' fun_exp in
let blame_args = list_map (_exp_rv_dexp seen node') eargs in
if list_exists (fun x -> x = None) (fun_dexpo:: blame_args) then None
let blame_args = IList.map (_exp_rv_dexp seen node') eargs in
if IList.exists (fun x -> x = None) (fun_dexpo:: blame_args) then None
else
let unNone = function Some x -> x | None -> assert false in
let args = list_map unNone blame_args in
let args = IList.map unNone blame_args in
Some (Sil.Dfcall (unNone fun_dexpo, args, loc, call_flags))
| None ->
_exp_rv_dexp seen node' (Sil.Var id)
@ -435,9 +435,9 @@ let leak_from_list_abstraction hpred prop =
| Some texp' when Sil.exp_equal texp texp' -> found := true
| _ -> () in
let check_hpara texp n hpara =
list_iter (check_hpred texp) hpara.Sil.body in
IList.iter (check_hpred texp) hpara.Sil.body in
let check_hpara_dll texp n hpara =
list_iter (check_hpred texp) hpara.Sil.body_dll in
IList.iter (check_hpred texp) hpara.Sil.body_dll in
match hpred_type hpred with
| Some texp ->
let env = Prop.prop_pred_env prop in
@ -458,7 +458,7 @@ let find_pvar_typ_without_ptr tenv prop pvar =
| Sil.Hpointsto (e, _, te) when Sil.exp_equal e (Sil.Lvar pvar) ->
res := Some te
| _ -> () in
list_iter do_hpred (Prop.get_sigma prop);
IList.iter do_hpred (Prop.get_sigma prop);
!res
(** Produce a description of a leak by looking at the current state.
@ -517,8 +517,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
if !verbose then (L.d_str "explain_leak: found nullify before Abstract for pvar "; Sil.d_pvar pvar; L.d_ln ());
[pvar]
| _ -> [] in
let nullify_pvars = list_flatten (list_map get_nullify node_instrs) in
let nullify_pvars_notmp = list_filter (fun pvar -> not (pvar_is_frontend_tmp pvar)) nullify_pvars in
let nullify_pvars = IList.flatten (IList.map get_nullify node_instrs) in
let nullify_pvars_notmp = IList.filter (fun pvar -> not (pvar_is_frontend_tmp pvar)) nullify_pvars in
value_str_from_pvars_vpath nullify_pvars_notmp vpath
| Some (Sil.Set (lexp, _, _, _)) when vpath = None ->
if !verbose then (L.d_str "explain_leak: current instruction Set for "; Sil.d_exp lexp; L.d_ln ());
@ -545,13 +545,13 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
let rec find sigma_acc sigma_todo exp =
let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) = match se with
| Sil.Eexp (e, _) when Sil.exp_equal exp e ->
let sigma' = (list_rev_append sigma_acc' sigma_todo') in
let sigma' = (IList.rev_append sigma_acc' sigma_todo') in
(match lexp with
| Sil.Lvar pv ->
let typo = match texp with
| Sil.Sizeof (Sil.Tstruct (ftl, ftal, _, _, _, _, _), _) ->
(try
let _, t, _ = list_find (fun (_f, _t, _) -> Ident.fieldname_equal _f f) ftl in
let _, t, _ = IList.find (fun (_f, _t, _) -> Ident.fieldname_equal _f f) ftl in
Some t
with Not_found -> None)
| _ -> None in
@ -565,7 +565,7 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
| _ -> () in
let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with
| Sil.Eexp (e, _) when Sil.exp_equal exp e ->
let sigma' = (list_rev_append sigma_acc' sigma_todo') in
let sigma' = (IList.rev_append sigma_acc' sigma_todo') in
(match lexp with
| Sil.Lvar pv when not (pvar_is_frontend_tmp pv) ->
let typo = match texp with
@ -581,7 +581,7 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
None, None)
| Sil.Estruct (fsel, _) ->
let res = ref (None, None) in
list_iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel;
IList.iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel;
!res
| sexp ->
None, None in
@ -590,7 +590,7 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
let filter = function
| (ni, Sil.Var id') -> Ident.is_normal ni && Ident.equal id' id
| _ -> false in
list_exists filter (Sil.sub_to_list (Prop.get_sub prop)) in
IList.exists filter (Sil.sub_to_list (Prop.get_sub prop)) in
function
| Sil.Hpointsto (Sil.Lvar pv, sexp, texp) when (Sil.pvar_is_local pv || Sil.pvar_is_global pv || Sil.pvar_is_seed pv) ->
do_sexp sigma_acc' sigma_todo' (Sil.Lvar pv) sexp texp
@ -632,7 +632,7 @@ let explain_dexp_access prop dexp is_nullable =
| Sil.Hpointsto (e', se, _) when Sil.exp_equal e e' ->
res := Some se
| _ -> () in
list_iter do_hpred sigma;
IList.iter do_hpred sigma;
!res in
let rec lookup_fld fsel f = match fsel with
| [] ->
@ -875,7 +875,7 @@ let explain_nth_function_parameter use_buckets deref_str prop n pvar_off =
match State.get_instr () with
| Some Sil.Call (_, _, args, _, _) ->
(try
let arg = fst (list_nth args (n - 1)) in
let arg = fst (IList.nth args (n - 1)) in
let dexp_opt = exp_rv_dexp node arg in
let dexp_opt' = match dexp_opt with
| Some de ->
@ -891,12 +891,12 @@ let find_pvar_with_exp prop exp =
let found_in_pvar pv =
res := Some (pv, Fpvar) in
let found_in_struct pv fld_lst = (* found_in_pvar has priority *)
if !res = None then res := Some (pv, Fstruct (list_rev fld_lst)) in
if !res = None then res := Some (pv, Fstruct (IList.rev fld_lst)) in
let rec search_struct pv fld_lst = function
| Sil.Eexp (e, _) ->
if Sil.exp_equal e exp then found_in_struct pv fld_lst
| Sil.Estruct (fsel, _) ->
list_iter (fun (f, se) -> search_struct pv (f:: fld_lst) se) fsel
IList.iter (fun (f, se) -> search_struct pv (f:: fld_lst) se) fsel
| _ -> () in
let do_hpred_pointed_by_pvar pv e = function
| Sil.Hpointsto(e1, se, _) ->
@ -905,9 +905,9 @@ let find_pvar_with_exp prop exp =
let do_hpred = function
| Sil.Hpointsto(Sil.Lvar pv, Sil.Eexp (e, _), _) ->
if Sil.exp_equal e exp then found_in_pvar pv
else list_iter (do_hpred_pointed_by_pvar pv e) (Prop.get_sigma prop)
else IList.iter (do_hpred_pointed_by_pvar pv e) (Prop.get_sigma prop)
| _ -> () in
list_iter do_hpred (Prop.get_sigma prop);
IList.iter do_hpred (Prop.get_sigma prop);
!res
(** return a description explaining value [exp] in [prop] in terms of a source expression

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

@ -245,7 +245,7 @@ module Err_table = struct
ErrLogHash.iter f err_table;
let pp ekind (nodeidkey, session, loc, mloco, ltr, pre_opt, eclass) fmt err_names =
list_iter (fun (err_name, desc) ->
IList.iter (fun (err_name, desc) ->
Exceptions.pp_err nodeidkey loc ekind err_name desc mloco fmt ()) err_names in
F.fprintf fmt "@.Detailed errors during footprint phase:@.";
LocMap.iter (fun nslm err_names ->

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

@ -97,7 +97,7 @@ let add_cg_exclude_fun (exe_env: t) (source_dir : DB.source_dir) exclude_fun =
Cg.extend exe_env.cg cg;
let file_data = new_file_data source nLOC cg_fname in
let defined_procs = Cg.get_defined_nodes cg in
list_iter (fun pname ->
IList.iter (fun pname ->
let should_update =
if Procname.Hash.mem exe_env.proc_map pname then
let old_source = (Procname.Hash.find exe_env.proc_map pname).source in

14
infer/src/backend/fork.ml
Unescape View File

@ -30,7 +30,7 @@ let compute_weighed_pnameset gr =
let pnameset = ref WeightedPnameSet.empty in
let add_pname_calls (pn, calls) =
pnameset := WeightedPnameSet.add (pn, calls) !pnameset in
list_iter add_pname_calls (Cg.get_nodes_and_calls gr);
IList.iter add_pname_calls (Cg.get_nodes_and_calls gr);
!pnameset
(* Return true if there are no children of [pname] whose specs
@ -71,7 +71,7 @@ let transition_footprint_re_exe proc_name joined_pres =
Specs.dependency_map = Specs.re_initialize_dependency_map summary.Specs.dependency_map;
Specs.payload =
let specs =
list_map
IList.map
(fun jp ->
Specs.spec_normalize
{ Specs.pre = jp;
@ -95,7 +95,7 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
let changed = ref false in
let current_specs =
ref
(list_fold_left
(IList.fold_left
(fun map spec ->
SpecMap.add
spec.Specs.pre
@ -103,7 +103,7 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
SpecMap.empty old_specs) in
let re_exe_filter old_spec = (* filter out pres which failed re-exe *)
if phase == Specs.RE_EXECUTION &&
not (list_exists
not (IList.exists
(fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre)
new_specs)
then begin
@ -143,8 +143,8 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
{ Specs.pre = pre;
Specs.posts = Paths.PathSet.elements post_set;
Specs.visited = visited }:: !res in
list_iter re_exe_filter old_specs; (* filter out pre's which failed re-exe *)
list_iter add_spec new_specs; (* add new specs *)
IList.iter re_exe_filter old_specs; (* filter out pre's which failed re-exe *)
IList.iter add_spec new_specs; (* add new specs *)
SpecMap.iter convert !current_specs;
!res,!changed
@ -188,7 +188,7 @@ let post_process_procs exe_env procs_done =
"No specs found for %a@." Procname.pp pn
end in
let cg = Exe_env.get_cg exe_env in
list_iter (fun pn ->
IList.iter (fun pn ->
let elem = (pn, Cg.get_calls cg pn) in
if WeightedPnameSet.mem elem !wpnames_todo then
begin

182
infer/src/backend/iList.ml
Unescape View File

@ -0,0 +1,182 @@
(*
* Copyright (c) 2015 - present Facebook, Inc.
* All rights reserved.
*
* This source code is licensed under the BSD style license found in the
* LICENSE file in the root directory of this source tree. An additional grant
* of patent rights can be found in the PATENTS file in the same directory.
*)
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 length = List.length
let nth = List.nth
let partition = List.partition
let rev = List.rev
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
(** tail-recursive variant of List.fold_right *)
let fold_right f l a =
let g x y = f y x in
fold_left g a (rev l)
(** tail-recursive variant of List.combine *)
let combine =
let rec combine acc l1 l2 = match l1, l2 with
| [], [] -> acc
| x1:: l1, x2:: l2 -> combine ((x1, x2):: acc) l1 l2
| [], _:: _
| _:: _, [] -> raise (Invalid_argument "IList.combine") in
fun l1 l2 -> rev (combine [] l1 l2)
(** tail-recursive variant of List.split *)
let split =
let rec split acc1 acc2 = function
| [] -> (acc1, acc2)
| (x, y):: l -> split (x:: acc1) (y:: acc2) l in
fun l ->
let acc1, acc2 = split [] [] l in
rev acc1, rev acc2
(** Like List.mem but without builtin equality *)
let mem equal x l = exists (equal x) l
(** 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
let rec drop_first n = function
| xs when n == 0 -> xs
| x:: xs -> drop_first (n - 1) xs
| [] -> []
let drop_last n list =
rev (drop_first n (rev list))
(** Generic comparison of lists given a compare function for the elements of the list *)
let rec compare cmp l1 l2 =
match l1, l2 with
| [],[] -> 0
| [], _ -> - 1
| _, [] -> 1
| x1:: l1', x2:: l2' ->
let n = cmp x1 x2 in
if n <> 0 then n else compare cmp l1' l2'
(** Generic equality of lists given a compare function for the elements of the list *)
let equal cmp l1 l2 =
compare cmp l1 l2 = 0
(** Returns (reverse input_list) *)
let rec rev_with_acc acc = function
| [] -> acc
| x :: xs -> rev_with_acc (x:: acc) xs
(** tail-recursive variant of List.append *)
let append l1 l2 =
rev_append (rev l1) l2
(** tail-recursive variant of List.map *)
let map f l =
rev (rev_map f l)
(** Remove consecutive equal elements from a list (according to the given comparison functions) *)
let remove_duplicates compare l =
let rec remove compare acc = function
| [] -> rev acc
| [x] -> rev (x:: acc)
| x:: ((y:: l'') as l') ->
if compare x y = 0 then remove compare acc (x:: l'')
else remove compare (x:: acc) l' in
remove compare [] l
(** Remove consecutive equal irrelevant elements from a list (according to the given comparison and relevance functions) *)
let remove_irrelevant_duplicates compare relevant l =
let rec remove compare acc = function
| [] -> rev acc
| [x] -> rev (x:: acc)
| x:: ((y:: l'') as l') ->
if compare x y = 0 then begin
match relevant x, relevant y with
| false, _ -> remove compare acc l'
| true, false -> remove compare acc (x:: l'')
| true, true -> remove compare (x:: acc) l'
end
else remove compare (x:: acc) l' in
remove compare [] l
(** The function works on sorted lists without duplicates *)
let rec merge_sorted_nodup compare res xs1 xs2 =
match xs1, xs2 with
| [], _ ->
rev_with_acc xs2 res
| _, [] ->
rev_with_acc xs1 res
| x1 :: xs1', x2 :: xs2' ->
let n = compare x1 x2 in
if n = 0 then
merge_sorted_nodup compare (x1 :: res) xs1' xs2'
else if n < 0 then
merge_sorted_nodup compare (x1 :: res) xs1' xs2
else
merge_sorted_nodup compare (x2 :: res) xs1 xs2'
let intersect compare l1 l2 =
let l1_sorted = sort compare l1 in
let l2_sorted = sort compare l2 in
let rec f l1 l2 = match l1, l2 with
| ([], _) | (_,[]) -> false
| (x1:: l1', x2:: l2') ->
let x_comparison = compare x1 x2 in
if x_comparison = 0 then true
else if x_comparison < 0 then f l1' l2
else f l1 l2' in
f l1_sorted l2_sorted
exception Fail
(** Apply [f] to pairs of elements; raise [Fail] if the two lists have different lenghts. *)
let map2 f l1 l2 =
let rec go l1 l2 acc =
match l1, l2 with
| [],[] -> rev acc
| x1 :: l1', x2 :: l2' ->
let x' = f x1 x2 in
go l1' l2' (x':: acc)
| _ -> raise Fail in
go l1 l2 []
let to_string f l =
let rec aux l =
match l with
| [] -> ""
| s:: [] -> (f s)
| s:: rest -> (f s)^", "^(aux rest) in
"["^(aux l)^"]"
(** Like List.mem_assoc but without builtin equality *)
let mem_assoc equal a l =
exists (fun x -> equal a (fst x)) l
(** Like List.assoc but without builtin equality *)
let assoc equal a l =
snd (find (fun x -> equal a (fst x)) l)

96
infer/src/backend/iList.mli
Unescape View File

@ -0,0 +1,96 @@
(*
* Copyright (c) 2015 - present Facebook, Inc.
* All rights reserved.
*
* This source code is licensed under the BSD style license found in the
* LICENSE file in the root directory of this source tree. An additional grant
* of patent rights can be found in the PATENTS file in the same directory.
*)
(** Generic comparison of lists given a compare function for the elements of the list *)
val compare : ('a -> 'b -> int) -> 'a list -> 'b list -> int
(** Generic equality of lists given a compare function for the elements of the list *)
val equal : ('a -> 'b -> int) -> 'a list -> 'b list -> bool
(** tail-recursive variant of List.append *)
val append : 'a list -> 'a list -> 'a list
(** tail-recursive variant of List.combine *)
val combine : 'a list -> 'b list -> ('a * 'b) list
val exists : ('a -> bool) -> 'a list -> bool
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 length : 'a list -> int
(** tail-recursive variant of List.fold_right *)
val fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
(** tail-recursive variant of List.map *)
val map : ('a -> 'b) -> 'a list -> 'b list
(** Like List.mem but without builtin equality *)
val mem : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
val nth : 'a list -> int -> 'a
val partition : ('a -> bool) -> 'a list -> 'a list * 'a list
val rev : 'a list -> 'a list
val rev_append : 'a list -> 'a list -> 'a list
val rev_map : ('a -> 'b) -> 'a list -> 'b list
val sort : ('a -> 'a -> int) -> 'a list -> 'a list
(** tail-recursive variant of List.split *)
val split : ('a * 'b) list -> 'a list * 'b list
val stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
val tl : 'a list -> 'a list
(* Drops the first n elements from a list. *)
val drop_first : int -> 'a list -> 'a list
(* Drops the last n elements from a list. *)
val drop_last : int -> 'a list -> 'a list
(** Returns (reverse input_list)[@]acc *)
val rev_with_acc : 'a list -> 'a list -> 'a list
(** Remove consecutive equal elements from a list (according to the given comparison functions) *)
val remove_duplicates : ('a -> 'a -> int) -> 'a list -> 'a list
(** Remove consecutive equal irrelevant elements from a list (according to the given comparison and relevance functions) *)
val remove_irrelevant_duplicates : ('a -> 'a -> int) -> ('a -> bool) -> 'a list -> 'a list
(** The function works on sorted lists without duplicates *)
val merge_sorted_nodup : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list -> 'a list
(** Returns whether there is an intersection in the elements of the two lists.
The compare function is required to sort the lists. *)
val intersect : ('a -> 'a -> int) -> 'a list -> 'a list -> bool
(** Like List.mem_assoc but without builtin equality *)
val mem_assoc : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> bool
(** Like List.assoc but without builtin equality *)
val assoc : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b
exception Fail
(** Apply [f] to pairs of elements; raise [Fail] if the two lists have different lenghts. *)
val map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val to_string : ('a -> string) -> 'a list -> string

4
infer/src/backend/ident.ml
Unescape View File

@ -96,7 +96,7 @@ module FieldMap = Map.Make(struct
end)
let idlist_to_idset ids =
list_fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids
IList.fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids
(** {2 Conversion between Names and Strings} *)
@ -280,7 +280,7 @@ let reset_name_generator () =
(** Update the name generator so that the given id's are not generated again *)
let update_name_generator ids =
let upd id = ignore (create_with_stamp id.kind id.name id.stamp) in
list_iter upd ids
IList.iter upd ids
(** Create a fresh identifier with the given kind and name. *)
let create_fresh_ident kind name =

88
infer/src/backend/inferanalyze.ml
Unescape View File

@ -98,9 +98,9 @@ let compute_exclude_fun () : DB.source_file -> bool =
let prepend_source_path s =
if Filename.is_relative s then Filename.concat !source_path s
else s in
let excluded_list = list_map (fun file_path -> prepend_source_path file_path) !excluded_files in
let excluded_list = IList.map (fun file_path -> prepend_source_path file_path) !excluded_files in
let exclude_fun (source_file : DB.source_file) =
list_exists (fun excluded_path -> string_is_prefix excluded_path (DB.source_file_to_string source_file)) excluded_list in
IList.exists (fun excluded_path -> string_is_prefix excluded_path (DB.source_file_to_string source_file)) excluded_list in
exclude_fun
let version_string () =
@ -203,7 +203,7 @@ let () = (* parse command-line arguments *)
module Simulator = struct (** Simulate the analysis only *)
let reset_summaries cg =
list_iter
IList.iter
(fun (pname, in_out_calls) -> Specs.reset_summary cg pname None)
(Cg.get_nodes_and_calls cg)
@ -214,7 +214,7 @@ module Simulator = struct (** Simulate the analysis only *)
let f proc_name =
let joined_pres = [] in
Fork.transition_footprint_re_exe proc_name joined_pres in
list_iter f proc_names
IList.iter f proc_names
let process_result (exe_env: Exe_env.t) ((proc_name: Procname.t), (calls: Cg.in_out_calls)) (_summ: Specs.summary) : unit =
L.err "in process_result %a@." Procname.pp proc_name;
@ -267,7 +267,7 @@ let analyze exe_env =
(** add [x] to list [l] at position [nth] *)
let list_add_nth x l nth =
let rec add acc todo nth =
if nth = 0 then list_rev_append acc (x:: todo)
if nth = 0 then IList.rev_append acc (x:: todo)
else match todo with
| [] -> raise Not_found
| y:: todo' -> add (y:: acc) todo' (nth - 1) in
@ -277,13 +277,13 @@ let list_add_nth x l nth =
the number returned by [compare x y] indicates 'how strongly' x should come before y *)
let weak_sort compare list =
let weak_add l x =
let length = list_length l in
let length = IList.length l in
let fitness = Array.make (length + 1) 0 in
list_iter (fun y -> fitness.(0) <- fitness.(0) + compare x y) l;
IList.iter (fun y -> fitness.(0) <- fitness.(0) + compare x y) l;
let best_position = ref 0 in
let best_value = ref (fitness.(0)) in
let i = ref 0 in
list_iter (fun y ->
IList.iter (fun y ->
incr i;
let new_value = fitness.(!i - 1) - (compare x y) + (compare y x) in
fitness.(!i) <- new_value;
@ -294,10 +294,10 @@ let weak_sort compare list =
end)
l;
list_add_nth x l !best_position in
list_fold_left weak_add [] list
IList.fold_left weak_add [] list
let pp_stringlist fmt slist =
list_iter (fun pname -> F.fprintf fmt "%s " pname) slist
IList.iter (fun pname -> F.fprintf fmt "%s " pname) slist
let weak_sort_nodes cg =
let nodes = Cg.get_defined_nodes cg in
@ -360,8 +360,8 @@ let create_minimal_clusters file_cg exe_env to_analyze_map : Cluster.t list =
let proc_is_active pname =
proc_is_selected pname &&
DB.source_file_equal (Exe_env.get_source exe_env pname) source_file in
let active_procs = list_filter proc_is_active (Procname.Set.elements changed_procs) in
let naprocs = list_length active_procs in
let active_procs = IList.filter proc_is_active (Procname.Set.elements changed_procs) in
let naprocs = IList.length active_procs in
total_files := !total_files + 1;
total_procs := !total_procs + naprocs;
total_LOC := !total_LOC + (Cg.get_nLOC cg);
@ -369,11 +369,11 @@ let create_minimal_clusters file_cg exe_env to_analyze_map : Cluster.t list =
let choose_next_file list = (* choose next file from the weakly ordered list *)
let file_has_no_unseen_dependents fname =
Procname.Set.subset (Cg.get_dependents file_cg fname) !seen in
match list_partition file_has_no_unseen_dependents list with
match IList.partition file_has_no_unseen_dependents list with
| (fname :: no_deps), deps -> (* if all the dependents of fname have been seen, bypass the order in the list *)
if !Cluster.trace_clusters then
L.err " [choose_next_file] %s (NO dependents)@." (Procname.to_string fname);
Some (fname, list_rev_append no_deps deps)
Some (fname, IList.rev_append no_deps deps)
| [], _ ->
begin
match list with
@ -391,10 +391,10 @@ let create_minimal_clusters file_cg exe_env to_analyze_map : Cluster.t list =
if Procname.Set.mem fname !seen then build_clusters list'
else
let cluster_set = Procname.Set.add fname (Cg.get_recursive_dependents file_cg fname) in
let cluster, list'' = list_partition (fun node -> Procname.Set.mem node cluster_set) list in
let cluster, list'' = IList.partition (fun node -> Procname.Set.mem node cluster_set) list in
seen := Procname.Set.union !seen cluster_set;
let to_analyze =
list_fold_right
IList.fold_right
(fun file_pname l ->
try (file_pname, Procname.Map.find file_pname to_analyze_map) :: l
with Not_found -> l)
@ -402,16 +402,16 @@ let create_minimal_clusters file_cg exe_env to_analyze_map : Cluster.t list =
[] in
if to_analyze <> [] then
begin
let cluster = list_map create_cluster_elem to_analyze in
let cluster = IList.map create_cluster_elem to_analyze in
clusters := cluster :: !clusters;
end;
build_clusters list'' in
build_clusters sorted_files;
output_json_file_stats !total_files !total_procs !total_LOC;
list_rev !clusters
IList.rev !clusters
let proc_list_to_set proc_list =
list_fold_left (fun s p -> Procname.Set.add p s) Procname.Set.empty proc_list
IList.fold_left (fun s p -> Procname.Set.add p s) Procname.Set.empty proc_list
(** compute the files to analyze map for incremental mode *)
let compute_to_analyze_map_incremental files_changed_map global_cg exe_env =
@ -497,20 +497,20 @@ let compute_clusters exe_env files_changed : Cluster.t list =
(ClusterMakefile.source_file_to_pname src2)
end
end in
list_iter do_node nodes;
if not !Config.intraprocedural then list_iter do_edge edges;
IList.iter do_node nodes;
if not !Config.intraprocedural then IList.iter do_edge edges;
if !save_file_dependency then
Cg.save_call_graph_dotty (Some (DB.filename_from_string "file_dependency.dot")) Specs.get_specs file_cg;
let files = Cg.get_defined_nodes file_cg in
let num_files = list_length files in
L.err "@.Found %d defined procedures in %d files.@." (list_length defined_procs) num_files;
let num_files = IList.length files in
L.err "@.Found %d defined procedures in %d files.@." (IList.length defined_procs) num_files;
let to_analyze_map =
if !incremental_mode = ANALYZE_ALL then
(* get all procedures defined in a file *)
let get_defined_procs file_pname = match file_pname_to_cg file_pname with
| None -> Procname.Set.empty
| Some cg -> proc_list_to_set (Cg.get_defined_nodes cg) in
list_fold_left
IList.fold_left
(fun m file_pname -> Procname.Map.add file_pname (get_defined_procs file_pname) m)
Procname.Map.empty
files
@ -553,8 +553,8 @@ let cg_get_changed_procs exe_env source_dir cg =
let is_changed pname =
not (spec_exists pname) || (cfg_modified_after_specs pname && pdesc_changed pname) in
let defined_nodes = Cg.get_defined_nodes cg in
if !Config.incremental_procs then list_filter is_changed defined_nodes
else if list_exists is_changed defined_nodes then defined_nodes
if !Config.incremental_procs then IList.filter is_changed defined_nodes
else if IList.exists is_changed defined_nodes then defined_nodes
else []
(** Load a .c or .cpp file into an execution environment *)
@ -567,9 +567,9 @@ let load_cg_file (_exe_env: Exe_env.initial) (source_dir : DB.source_dir) exclud
(** Return a map of (changed file procname) -> (procs in that file that have changed) *)
let compute_files_changed_map _exe_env (source_dirs : DB.source_dir list) exclude_fun =
let sorted_dirs = list_sort DB.source_dir_compare source_dirs in
let sorted_dirs = IList.sort DB.source_dir_compare source_dirs in
let cg_list =
list_fold_left
IList.fold_left
(fun cg_list source_dir ->
match load_cg_file _exe_env source_dir exclude_fun with
| None -> cg_list
@ -585,7 +585,7 @@ let compute_files_changed_map _exe_env (source_dirs : DB.source_dir list) exclud
let file_pname = ClusterMakefile.source_file_to_pname (Cg.get_source cg) in
Procname.Map.add file_pname (proc_list_to_set changed_procs) files_changed_map
else files_changed_map in
list_fold_left cg_get_files_changed files_changed_map cg_list in
IList.fold_left cg_get_files_changed files_changed_map cg_list in
let exe_env = Exe_env.freeze _exe_env in
let files_changed =
if !incremental_mode = ANALYZE_ALL then Procname.Map.empty
@ -606,9 +606,9 @@ let exe_env_from_cluster cluster =
| None ->
DB.source_dir_from_source_file ce.Cluster.ce_file in
source_dir :: source_dirs in
list_fold_left fold_cluster_elem [] cluster in
let sorted_dirs = list_sort DB.source_dir_compare source_dirs in
list_iter (fun src_dir -> ignore (Exe_env.add_cg _exe_env src_dir)) sorted_dirs;
IList.fold_left fold_cluster_elem [] cluster in
let sorted_dirs = IList.sort DB.source_dir_compare source_dirs in
IList.iter (fun src_dir -> ignore (Exe_env.add_cg _exe_env src_dir)) sorted_dirs;
let exe_env = Exe_env.freeze _exe_env in
exe_env
@ -616,9 +616,9 @@ let exe_env_from_cluster cluster =
let analyze_cluster cluster_num tot_clusters (cluster : Cluster.t) =
incr cluster_num;
let exe_env = exe_env_from_cluster cluster in
let num_files = list_length cluster in
let num_files = IList.length cluster in
let defined_procs = Cg.get_defined_nodes (Exe_env.get_cg exe_env) in
let num_procs = list_length defined_procs in
let num_procs = IList.length defined_procs in
L.err "@.Processing cluster #%d/%d with %d files and %d procedures@." !cluster_num tot_clusters num_files num_procs;
Fork.this_cluster_files := num_files;
analyze exe_env;
@ -633,8 +633,8 @@ let process_cluster_cmdline_exit () =
L.err "Cannot find cluster file %s@." fname;
exit 0
| Some (nr, tot_nr, cluster) ->
Fork.tot_files_done := (nr - 1) * list_length cluster;
Fork.tot_files := tot_nr * list_length cluster;
Fork.tot_files_done := (nr - 1) * IList.length cluster;
Fork.tot_files := tot_nr * IList.length cluster;
analyze_cluster (ref (nr -1)) tot_nr cluster;
exit 0)
@ -663,9 +663,9 @@ let compute_ondemand_clusters source_dirs =
Cluster.create_ondemand source_dir in
let clusters =
let do_source_dir acc source_dir = mk_cluster source_dir @ acc in
list_fold_left do_source_dir [] source_dirs in
IList.fold_left do_source_dir [] source_dirs in
Cluster.print_clusters_stats clusters;
let num_files = list_length clusters in
let num_files = IList.length clusters in
let num_procs = 0 (* can't compute it at this stage *) in
let num_lines = 0 in
output_json_file_stats num_files num_procs num_lines;
@ -710,9 +710,9 @@ let () =
else
let filter source_dir =
let source_dir_base = Filename.basename (DB.source_dir_to_string source_dir) in
list_exists (fun s -> Utils.string_is_prefix s source_dir_base) !only_files_cmdline in
list_filter filter (DB.find_source_dirs ()) in
L.err "Found %d source files in %s@." (list_length source_dirs) !Config.results_dir;
IList.exists (fun s -> Utils.string_is_prefix s source_dir_base) !only_files_cmdline in
IList.filter filter (DB.find_source_dirs ()) in
L.err "Found %d source files in %s@." (IList.length source_dirs) !Config.results_dir;
let clusters =
if !Config.ondemand_enabled
@ -729,9 +729,9 @@ let () =
end in
let tot_clusters = list_length clusters in
Fork.tot_files := list_fold_left (fun n cluster -> n + list_length cluster) 0 clusters;
list_iter (analyze_cluster (ref 0) tot_clusters) clusters;
let tot_clusters = IList.length clusters in
Fork.tot_files := IList.fold_left (fun n cluster -> n + IList.length cluster) 0 clusters;
IList.iter (analyze_cluster (ref 0) tot_clusters) clusters;
L.flush_streams ();
close_output_file analyzer_out_of;
close_output_file analyzer_err_of;

34
infer/src/backend/inferconfig.ml
Unescape View File

@ -55,7 +55,7 @@ type filter_config =
let is_matching patterns =
fun source_file ->
let path = DB.source_file_to_rel_path source_file in
Utils.list_exists
IList.exists
(fun pattern ->
try
(Str.search_forward pattern path 0) = 0
@ -168,8 +168,8 @@ struct
let detect_pattern assoc =
let language = detect_language assoc in
let is_method_pattern key = list_exists (string_equal key) ["class"; "method"]
and is_source_contains key = list_exists (string_equal key) ["source_contains"] in
let is_method_pattern key = IList.exists (string_equal key) ["class"; "method"]
and is_source_contains key = IList.exists (string_equal key) ["source_contains"] in
let rec loop = function
| [] ->
failwith ("Unknown pattern for " ^ M.json_key ^ " in " ^ inferconfig_file)
@ -185,7 +185,7 @@ struct
let collect accu = function
| `String s -> s:: accu
| _ -> failwith ("Unrecognised parameters in " ^ Yojson.Basic.to_string (`Assoc assoc)) in
list_rev (list_fold_left collect [] l) in
IList.rev (IList.fold_left collect [] l) in
let create_method_pattern mp assoc =
let loop mp = function
| (key, `String s) when key = "class" ->
@ -196,13 +196,13 @@ struct
{ mp with parameters = Some (collect_params l) }
| (key, _) when key = "language" -> mp
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
list_fold_left loop default_method_pattern assoc
IList.fold_left loop default_method_pattern assoc
and create_string_contains sc assoc =
let loop sc = function
| (key, `String pattern) when key = "source_contains" -> pattern
| (key, _) when key = "language" -> sc
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
list_fold_left loop default_source_contains assoc in
IList.fold_left loop default_source_contains assoc in
match detect_pattern assoc with
| Method_pattern (language, mp) ->
Method_pattern (language, create_method_pattern mp assoc)
@ -212,7 +212,7 @@ struct
let rec translate accu (json : Yojson.Basic.json) : pattern list =
match json with
| `Assoc l -> (create_pattern l):: accu
| `List l -> list_fold_left translate accu l
| `List l -> IList.fold_left translate accu l
| _ -> assert false
let create_method_matcher m_patterns =
@ -220,7 +220,7 @@ struct
default_matcher
else
let pattern_map =
list_fold_left
IList.fold_left
(fun map pattern ->
let previous =
try
@ -234,7 +234,7 @@ struct
and method_name = Procname.java_get_method proc_name in
try
let class_patterns = StringMap.find class_name pattern_map in
list_exists
IList.exists
(fun p ->
match p.method_name with
| None -> true
@ -247,7 +247,7 @@ struct
let collect (s_patterns, m_patterns) = function
| Source_contains (lang, s) -> (s:: s_patterns, m_patterns)
| Method_pattern (lang, mp) -> (s_patterns, mp :: m_patterns) in
list_fold_left collect ([], []) patterns in
IList.fold_left collect ([], []) patterns in
let s_matcher =
let matcher = FileContainsStringMatcher.create_matcher s_patterns in
fun source_file proc_name -> matcher source_file
@ -263,7 +263,7 @@ struct
Yojson.Basic.Util.filter_member
M.json_key
[Yojson.Basic.from_file inferconfig] in
list_fold_left translate [] found in
IList.fold_left translate [] found in
create_file_matcher patterns
with Sys_error _ ->
default_matcher
@ -315,9 +315,9 @@ let filters_from_inferconfig inferconfig : filters =
let path_filter =
let whitelist_filter : path_filter =
if inferconfig.whitelist = [] then default_path_filter
else is_matching (list_map Str.regexp inferconfig.whitelist) in
else is_matching (IList.map Str.regexp inferconfig.whitelist) in
let blacklist_filter : path_filter =
is_matching (list_map Str.regexp inferconfig.blacklist) in
is_matching (IList.map Str.regexp inferconfig.blacklist) in
let blacklist_files_containing_filter : path_filter =
FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing in
function source_file ->
@ -327,7 +327,7 @@ let filters_from_inferconfig inferconfig : filters =
let error_filter =
function error_name ->
let error_str = Localise.to_string error_name in
not (list_exists (string_equal error_str) inferconfig.suppress_errors) in
not (IList.exists (string_equal error_str) inferconfig.suppress_errors) in
{
path_filter = path_filter;
error_filter = error_filter;
@ -352,9 +352,9 @@ let create_filters analyzer =
let test () =
Config.project_root := Some (Sys.getcwd ());
let filters =
Utils.list_map (fun analyzer -> (analyzer, create_filters analyzer)) Utils.analyzers in
IList.map (fun analyzer -> (analyzer, create_filters analyzer)) Utils.analyzers in
let matching_analyzers path =
Utils.list_fold_left
IList.fold_left
(fun l (a, f) -> if f.path_filter path then a:: l else l)
[] filters in
Utils.directory_iter
@ -365,7 +365,7 @@ let test () =
if matching <> [] then
let matching_s =
Utils.join_strings ", "
(Utils.list_map Utils.string_of_analyzer matching) in
(IList.map Utils.string_of_analyzer matching) in
Logging.stderr "%s -> {%s}@."
(DB.source_file_to_rel_path source_file)
matching_s)

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

@ -147,15 +147,15 @@ let load_specfiles () =
let specs_files_in_dir dir =
let is_specs_file fname = not (Sys.is_directory fname) && Filename.check_suffix fname ".specs" in
let all_filenames = Array.to_list (Sys.readdir dir) in
let all_filepaths = list_map (fun fname -> Filename.concat dir fname) all_filenames in
list_filter is_specs_file all_filepaths in
let all_filepaths = IList.map (fun fname -> Filename.concat dir fname) all_filenames in
IList.filter is_specs_file all_filepaths in
let specs_dirs =
if !results_dir_cmdline then
let result_specs_dir = DB.filename_to_string (DB.Results_dir.specs_dir ()) in
result_specs_dir :: !Config.specs_library
else
!Config.specs_library in
list_flatten (list_map specs_files_in_dir specs_dirs)
IList.flatten (IList.map specs_files_in_dir specs_dirs)
(** Create and initialize latex file *)
let begin_latex_file fmt =
@ -190,7 +190,7 @@ let error_desc_to_xml_tags error_desc =
let tags = Localise.error_desc_get_tags error_desc in
let subtree label contents =
Io_infer.Xml.create_tree label [] [(Io_infer.Xml.String contents)] in
list_map (fun (tag, value) -> subtree tag (Escape.escape_xml value)) tags
IList.map (fun (tag, value) -> subtree tag (Escape.escape_xml value)) tags
let get_bug_hash (kind: string) (type_str: string) (procedure_id: string) (filename: string) (node_key: int) (error_desc: Localise.error_desc) =
let qualifier_tag_call_procedure = Localise.error_desc_get_tag_call_procedure error_desc in
@ -203,7 +203,7 @@ let loc_trace_to_jsonbug_record trace_list ekind =
| _ ->
(* writes a trace as a record for atdgen conversion *)
let node_tags_to_records tags_list =
list_map (fun tag -> { tag = fst tag; value = snd tag }) tags_list in
IList.map (fun tag -> { tag = fst tag; value = snd tag }) tags_list in
let trace_item_to_record trace_item =
{ level = trace_item.Errlog.lt_level;
filename = DB.source_file_to_string trace_item.Errlog.lt_loc.Location.file;
@ -211,14 +211,14 @@ let loc_trace_to_jsonbug_record trace_list ekind =
description = trace_item.Errlog.lt_description;
node_tags = node_tags_to_records trace_item.Errlog.lt_node_tags;
} in
let record_list = list_rev (list_rev_map trace_item_to_record trace_list) in
let record_list = IList.rev (IList.rev_map trace_item_to_record trace_list) in
record_list
let error_desc_to_qualifier_tags_records error_desc =
let tag_value_pairs = Localise.error_desc_to_tag_value_pairs error_desc in
let tag_value_to_record (tag, value) =
{ tag = tag; value = value } in
list_map (fun tag_value -> tag_value_to_record tag_value) tag_value_pairs
IList.map (fun tag_value -> tag_value_to_record tag_value) tag_value_pairs
type summary_val =
{ vname : string;
@ -250,15 +250,15 @@ let summary_values top_proc_set summary =
let proc_name = Specs.get_proc_name summary in
let is_top = Procname.Set.mem proc_name top_proc_set in
let signature = Specs.get_signature summary in
let nodes_nr = list_length summary.Specs.nodes in
let nodes_nr = IList.length summary.Specs.nodes in
let specs = Specs.get_specs_from_payload summary in
let nr_nodes_visited, lines_visited =
let visited = ref Specs.Visitedset.empty in
let do_spec spec = visited := Specs.Visitedset.union spec.Specs.visited !visited in
list_iter do_spec specs;
IList.iter do_spec specs;
let visited_lines = ref IntSet.empty in
Specs.Visitedset.iter (fun (n, ls) ->
list_iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls)
IList.iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls)
!visited;
Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in
let proof_trace =
@ -279,7 +279,7 @@ let summary_values top_proc_set summary =
let cyclomatic = stats.Specs.cyclomatic in
{ vname = Procname.to_string proc_name;
vname_id = Procname.to_filename proc_name;
vspecs = list_length specs;
vspecs = IList.length specs;
vtime = Printf.sprintf "%.0f" stats.Specs.stats_time;
vto = if stats.Specs.stats_timeout then "TO" else " ";
vsymop = stats.Specs.symops;
@ -504,7 +504,7 @@ module BugsXml = struct
let code_to_xml code = subtree Io_infer.Xml.tag_code code in
let description_to_xml descr = subtree Io_infer.Xml.tag_description (Escape.escape_xml descr) in
let node_tags_to_xml node_tags =
let escaped_tags = list_map (fun (tag, value) -> (tag, Escape.escape_xml value)) node_tags in
let escaped_tags = IList.map (fun (tag, value) -> (tag, Escape.escape_xml value)) node_tags in
Io_infer.Xml.create_tree Io_infer.Xml.tag_node escaped_tags [] in
let num = ref 0 in
let loc_to_xml lt =
@ -520,7 +520,7 @@ module BugsXml = struct
(code_to_xml code);
(description_to_xml lt.Errlog.lt_description);
(node_tags_to_xml lt.Errlog.lt_node_tags)] in
list_rev (list_rev_map loc_to_xml ltr)
IList.rev (IList.rev_map loc_to_xml ltr)
(** print bugs from summary in xml *)
let pp_bugs error_filter linereader fmt summary =
@ -616,8 +616,8 @@ module UnitTest = struct
Autounit.genunit c_file proc_name !cnt (Specs.get_formals summary) spec in
F.fprintf fmt "%a@." Autounit.pp_code code in
let specs = Specs.get_specs_from_payload summary in
list_iter do_spec specs;
procs_done := (proc_name, list_length specs) :: !procs_done
IList.iter do_spec specs;
procs_done := (proc_name, IList.length specs) :: !procs_done
(** Print main function which calls all the unit test functions generated *)
let print_unit_test_main () =
@ -648,7 +648,7 @@ end = struct
Procname.Set.diff x.possible x.impossible
let process_summary x (_, summary) =
let proc_name = Specs.get_proc_name summary in
let nspecs = list_length (Specs.get_specs_from_payload summary) in
let nspecs = IList.length (Specs.get_specs_from_payload summary) in
if nspecs > 0 then
begin
mark_possible x proc_name;
@ -712,8 +712,8 @@ module Stats = struct
F.fprintf fmt "%s%04d: %s" (indent_string (level + indent_num)) loc.Location.line code in
pp_to_string pp () in
res := line :: "" :: !res in
list_iter loc_to_string ltr;
list_rev !res
IList.iter loc_to_string ltr;
IList.rev !res
let process_err_log error_filter linereader err_log stats =
let found_errors = ref false in
@ -731,7 +731,7 @@ module Stats = struct
let pp3 fmt () = F.fprintf fmt " (%a)" Localise.pp_error_desc error_desc in
[pp_to_string pp1 (); pp_to_string pp2 (); pp_to_string pp3 ()] in
let trace = loc_trace_to_string_list linereader 1 ltr in
stats.saved_errors <- list_rev_append (error_strs @ trace @ [""]) stats.saved_errors
stats.saved_errors <- IList.rev_append (error_strs @ trace @ [""]) stats.saved_errors
| Exceptions.Kwarning -> stats.nwarnings <- stats.nwarnings + 1
| Exceptions.Kinfo -> stats.ninfos <- stats.ninfos + 1 in
Errlog.iter process_row err_log;
@ -745,7 +745,7 @@ module Stats = struct
let is_verified = specs <> [] && not is_defective in
let is_checked = not (is_defective || is_verified) in
stats.nprocs <- stats.nprocs + 1;
stats.nspecs <- stats.nspecs + (list_length specs);
stats.nspecs <- stats.nspecs + (IList.length specs);
if is_verified then stats.nverified <- stats.nverified + 1;
if is_checked then stats.nchecked <- stats.nchecked + 1;
if is_defective then stats.ndefective <- stats.ndefective + 1;
@ -767,7 +767,7 @@ module Stats = struct
F.fprintf fmt "Infos: %d@\n" stats.ninfos;
F.fprintf fmt "@\n -------------------@\n";
F.fprintf fmt "@\nDetailed Errors@\n@\n";
list_iter (fun s -> F.fprintf fmt "%s@\n" s) (list_rev stats.saved_errors);
IList.iter (fun s -> F.fprintf fmt "%s@\n" s) (IList.rev stats.saved_errors);
end
module Report = struct
@ -788,7 +788,7 @@ module PreconditionStats = struct
let do_summary proc_name summary =
let specs = Specs.get_specs_from_payload summary in
let preconditions = list_map (fun spec -> Specs.Jprop.to_prop spec.Specs.pre) specs in
let preconditions = IList.map (fun spec -> Specs.Jprop.to_prop spec.Specs.pre) specs in
match Prop.CategorizePreconditions.categorize preconditions with
| Prop.CategorizePreconditions.Empty ->
incr nr_empty;
@ -882,10 +882,10 @@ module AnalysisResults = struct
Inferconfig.test ();
exit(0)
end;
list_append (if !args = ["."] then begin
IList.append (if !args = ["."] then begin
let arr = Sys.readdir "." in
let all_files = Array.to_list arr in
list_filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files
IList.filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files
end
else !args) (load_specfiles ())
@ -908,7 +908,7 @@ module AnalysisResults = struct
exit 0
| Some summary ->
summaries := (fname, summary) :: !summaries in
apply_without_gc (list_iter load_file) spec_files_from_cmdline;
apply_without_gc (IList.iter load_file) spec_files_from_cmdline;
let summ_cmp (fname1, summ1) (fname2, summ2) =
let n =
DB.source_file_compare
@ -918,11 +918,11 @@ module AnalysisResults = struct
else int_compare
summ1.Specs.attributes.ProcAttributes.loc.Location.line
summ2.Specs.attributes.ProcAttributes.loc.Location.line in
list_sort summ_cmp !summaries
IList.sort summ_cmp !summaries
(** Create an iterator which loads spec files one at a time *)
let iterator_of_spec_files () =
let sorted_spec_files = list_sort string_compare spec_files_from_cmdline in
let sorted_spec_files = IList.sort string_compare spec_files_from_cmdline in
let do_spec f fname =
match Specs.load_summary (DB.filename_from_string fname) with
| None ->
@ -931,7 +931,7 @@ module AnalysisResults = struct
| Some summary ->
f (fname, summary) in
let iterate f =
list_iter (do_spec f) sorted_spec_files in
IList.iter (do_spec f) sorted_spec_files in
iterate
(** Serializer for analysis results *)
@ -949,7 +949,7 @@ module AnalysisResults = struct
If options - load_results or - save_results are used, all the summaries are loaded in memory *)
let get_summary_iterator () =
let iterator_of_summary_list r =
fun f -> list_iter f r in
fun f -> IList.iter f r in
match !load_analysis_results with
| None ->
begin

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

@ -219,7 +219,7 @@ let collect_preconditions pname tenv proc_name : Prop.normal Specs.Jprop.t list
Config.footprint := true;
prop' end
else Abs.abstract_no_symop tenv prop in
let pres = list_map (fun spec -> Specs.Jprop.to_prop spec.Specs.pre) (Specs.get_specs proc_name) in
let pres = IList.map (fun spec -> Specs.Jprop.to_prop spec.Specs.pre) (Specs.get_specs proc_name) in
let pset = Propset.from_proplist pres in
let pset' =
let f p = Prop.prop_normal_vars_to_primed_vars p in
@ -238,12 +238,12 @@ let collect_preconditions pname tenv proc_name : Prop.normal Specs.Jprop.t list
L.d_decrease_indent 2; L.d_ln ();
L.d_strln ("#### Footprint of " ^ Procname.to_string proc_name ^ " after Join ####");
L.d_increase_indent 1; Specs.Jprop.d_list false jplist; L.d_decrease_indent 1; L.d_ln ();
let jplist' = list_map (Specs.Jprop.map Prop.prop_rename_primed_footprint_vars) jplist in
let jplist' = IList.map (Specs.Jprop.map Prop.prop_rename_primed_footprint_vars) jplist in
L.d_strln ("#### Renamed footprint of " ^ Procname.to_string proc_name ^ ": ####");
L.d_increase_indent 1; Specs.Jprop.d_list false jplist'; L.d_decrease_indent 1; L.d_ln ();
let jplist'' =
let f p = Prop.prop_primed_vars_to_normal_vars (collect_do_abstract_one pname tenv p) in
list_map (Specs.Jprop.map f) jplist' in
IList.map (Specs.Jprop.map f) jplist' in
L.d_strln ("#### Abstracted footprint of " ^ Procname.to_string proc_name ^ ": ####");
L.d_increase_indent 1; Specs.Jprop.d_list false jplist''; L.d_decrease_indent 1; L.d_ln();
jplist''
@ -271,7 +271,7 @@ let propagate_nodes_divergence
let pset_exn, pset_ok = Paths.PathSet.partition (Tabulation.prop_is_exn pname) pset in
let succ_nodes = match State.get_goto_node () with (* handle Sil.Goto_node target, if any *)
| Some node_id ->
list_filter (fun n -> Cfg.Node.get_id n = node_id) _succ_nodes
IList.filter (fun n -> Cfg.Node.get_id n = node_id) _succ_nodes
| None -> _succ_nodes in
if !Config.footprint && not (Paths.PathSet.is_empty (State.get_diverging_states_node ())) then
begin
@ -288,8 +288,8 @@ let propagate_nodes_divergence
Propgraph.d_proplist Prop.prop_emp (Paths.PathSet.to_proplist prop_incons); L.d_ln ();
propagate pname false prop_incons exit_node
end;
list_iter (propagate pname false pset_ok) succ_nodes;
list_iter (propagate pname true pset_exn) exn_nodes
IList.iter (propagate pname false pset_ok) succ_nodes;
IList.iter (propagate pname true pset_exn) exn_nodes
(* ===================== END of symbolic execution ===================== *)
@ -305,7 +305,7 @@ let do_symexec_join pname tenv curr_node (edgeset_todo : Paths.PathSet.t) =
let old_dset = Join_table.find curr_id in
let old_dset', new_dset' = Dom.pathset_join curr_pname tenv old_dset new_dset in
Join_table.put curr_id (Paths.PathSet.union old_dset' new_dset');
list_iter (fun node ->
IList.iter (fun node ->
Paths.PathSet.iter (fun prop path ->
State.set_path path None;
propagate pname false (Paths.PathSet.from_renamed_list [(prop, path)]) node)
@ -350,7 +350,7 @@ let d_path (path, pos_opt) =
L.d_str "Path: "; Paths.Path.d_stats path; L.d_ln ();
Paths.Path.d path; L.d_ln ();
(* pp_complete_path_dotty_file path; *)
(* if !Config.write_dotty then Dotty.print_icfg_dotty (list_rev (get_edges path)) *)
(* if !Config.write_dotty then Dotty.print_icfg_dotty (IList.rev (get_edges path)) *)
Paths.Path.iter_longest_sequence f pos_opt path
exception RE_EXE_ERROR
@ -372,8 +372,8 @@ let instrs_get_normal_vars instrs =
let do_instr instr =
let do_e e = Sil.exp_fav_add fav e in
let exps = Sil.instr_get_exps instr in
list_iter do_e exps in
list_iter do_instr instrs;
IList.iter do_e exps in
IList.iter do_instr instrs;
Sil.fav_filter_ident fav Ident.is_normal;
Sil.fav_to_list fav
@ -392,7 +392,7 @@ let check_assignement_guard node =
let is_call = function
| Sil.Call _ -> true
| _ -> false in
list_exists is_call instrs in
IList.exists is_call instrs in
let is_set_instr i =
match i with
| Sil.Set _ -> true
@ -422,19 +422,19 @@ let check_assignement_guard node =
let is_prune_exp e =
let prune_var n =
let ins = Cfg.Node.get_instrs n in
let pi = list_filter is_prune_instr ins in
let leti = list_filter is_letderef_instr ins in
let pi = IList.filter is_prune_instr ins in
let leti = IList.filter is_letderef_instr ins in
match pi, leti with
| [Sil.Prune (Sil.Var(e1), _, _, _)], [Sil.Letderef(e2, e', _, _)]
| [Sil.Prune (Sil.UnOp(Sil.LNot, Sil.Var(e1), _), _, _, _)], [Sil.Letderef(e2, e', _, _)] when (Ident.equal e1 e2) ->
if verbose then L.d_strln ("Found "^(Sil.exp_to_string e')^" as prune var");
[e']
| _ -> [] in
let prune_vars = list_flatten(list_map (fun n -> prune_var n) succs) in
list_for_all (fun e' -> Sil.exp_equal e' e) prune_vars in
let succs_loc = list_map (fun n -> Cfg.Node.get_loc n) succs in
let prune_vars = IList.flatten(IList.map (fun n -> prune_var n) succs) in
IList.for_all (fun e' -> Sil.exp_equal e' e) prune_vars in
let succs_loc = IList.map (fun n -> Cfg.Node.get_loc n) succs in
let succs_are_all_prune_nodes () =
list_for_all (fun n -> match Cfg.Node.get_kind n with
IList.for_all (fun n -> match Cfg.Node.get_kind n with
| Cfg.Node.Prune_node(_) -> true
| _ -> false) succs in
let succs_same_loc_as_node () =
@ -442,7 +442,7 @@ let check_assignement_guard node =
(L.d_str ("LOCATION NODE: line: " ^ (string_of_int l_node.Location.line) ^
" nLOC: " ^ (string_of_int l_node.Location.nLOC));
L.d_strln " ");
list_for_all (fun l ->
IList.for_all (fun l ->
if verbose then
(L.d_str ("LOCATION l: line: " ^ (string_of_int l.Location.line) ^
" nLOC: " ^ (string_of_int l.Location.nLOC));
@ -455,8 +455,8 @@ let check_assignement_guard node =
| Sil.Prune _ -> false
| _ -> true in
let check_guard n =
list_for_all check_instr (Cfg.Node.get_instrs n) in
list_for_all check_guard succs in
IList.for_all check_instr (Cfg.Node.get_instrs n) in
IList.for_all check_guard succs in
if !Config.curr_language = Config.C_CPP &&
succs_are_all_prune_nodes () &&
succs_same_loc_as_node () &&
@ -465,7 +465,7 @@ let check_assignement_guard node =
match succs_loc with
| loc_succ:: _ -> (* at this point all successors are at the same location, so we can take the first*)
let set_instr_at_succs_loc =
list_filter
IList.filter
(fun i -> (Location.equal (Sil.instr_get_loc i) loc_succ) && is_set_instr i)
instr in
(match set_instr_at_succs_loc with
@ -610,7 +610,7 @@ let report_activity_leaks pname sigma tenv =
let fld_exps = Prop.strexp_get_exps fld_strexp in
Prop.compute_reachable_hpreds sigma fld_exps in
(* raise an error if any Activity expression is in [reachable_exps] *)
list_iter
IList.iter
(fun (activity_exp, typ) ->
if Sil.ExpSet.mem activity_exp reachable_exps then
let err_desc = Errdesc.explain_activity_leak pname typ fld_name in
@ -620,7 +620,7 @@ let report_activity_leaks pname sigma tenv =
activity_exps in
(* get the set of pointed-to expressions of type T <: Activity *)
let activity_exps =
list_fold_left
IList.fold_left
(fun exps hpred -> match hpred with
| Sil.Hpointsto (_, Sil.Eexp (exp, _), Sil.Sizeof (Sil.Tptr (typ, _), _))
when AndroidFramework.is_activity typ tenv ->
@ -628,10 +628,10 @@ let report_activity_leaks pname sigma tenv =
| _ -> exps)
[]
sigma in
list_iter
IList.iter
(function
| Sil.Hpointsto (Sil.Lvar pv, Sil.Estruct (static_flds, _), _) when Sil.pvar_is_global pv ->
list_iter
IList.iter
(fun (f_name, f_strexp) ->
if not (Harness.is_generated_field f_name) then
check_reachable_activity_from_fld (f_name, f_strexp) activity_exps) static_flds
@ -648,7 +648,7 @@ let remove_locals_formals_and_check pdesc p =
let desc = Errdesc.explain_stack_variable_address_escape loc pvar dexp_opt in
let exn = Exceptions.Stack_variable_address_escape (desc, try assert false with Assert_failure x -> x) in
Reporting.log_warning pname exn in
list_iter check_pvar pvars;
IList.iter check_pvar pvars;
p'
(* Collect the analysis results for the exit node *)
@ -670,9 +670,9 @@ let compute_visited vset =
let res = ref Specs.Visitedset.empty in
let node_get_all_lines n =
let node_loc = Cfg.Node.get_loc n in
let instrs_loc = list_map Sil.instr_get_loc (Cfg.Node.get_instrs n) in
let lines = list_map (fun loc -> loc.Location.line) (node_loc :: instrs_loc) in
list_remove_duplicates int_compare (list_sort int_compare lines) in
let instrs_loc = IList.map Sil.instr_get_loc (Cfg.Node.get_instrs n) in
let lines = IList.map (fun loc -> loc.Location.line) (node_loc :: instrs_loc) in
IList.remove_duplicates int_compare (IList.sort int_compare lines) in
let do_node n = res := Specs.Visitedset.add (Cfg.Node.get_id n, node_get_all_lines n) !res in
Cfg.NodeSet.iter do_node vset;
!res
@ -683,7 +683,7 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
let sub =
let fav = Sil.fav_new () in
Paths.PathSet.iter (fun prop path -> Prop.prop_fav_add fav prop) pathset;
let sub_list = list_map (fun id -> (id, Sil.Var (Ident.create_fresh (Ident.knormal)))) (Sil.fav_to_list fav) in
let sub_list = IList.map (fun id -> (id, Sil.Var (Ident.create_fresh (Ident.knormal)))) (Sil.fav_to_list fav) in
Sil.sub_of_list sub_list in
let pre_post_visited_list =
let pplist = Paths.PathSet.elements pathset in
@ -704,7 +704,7 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
vset_ref_add_path vset_ref path;
compute_visited !vset_ref in
(pre', post', visited) in
list_map f pplist in
IList.map f pplist in
let pre_post_map =
let add map (pre, post, visited) =
let current_posts, current_visited = try Pmap.find pre map with Not_found -> (Paths.PathSet.empty, Specs.Visitedset.empty) in
@ -713,11 +713,11 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
| Some (post, path) -> Paths.PathSet.add_renamed_prop post path current_posts in
let new_visited = Specs.Visitedset.union visited current_visited in
Pmap.add pre (new_posts, new_visited) map in
list_fold_left add Pmap.empty pre_post_visited_list in
IList.fold_left add Pmap.empty pre_post_visited_list in
let specs = ref [] in
let add_spec pre ((posts : Paths.PathSet.t), visited) =
let posts' =
list_map
IList.map
(fun (p, path) -> (Cfg.remove_seed_vars p, path))
(Paths.PathSet.elements (do_join_post pname tenv posts)) in
let spec =
@ -756,7 +756,7 @@ let create_seed_vars sigma =
| Sil.Hpointsto (Sil.Lvar pv, se, typ) when not (Sil.pvar_is_abducted pv) ->
Sil.Hpointsto(Sil.Lvar (Sil.pvar_to_seed pv), se, typ) :: sigma
| _ -> sigma in
list_fold_left hpred_add_seed [] sigma
IList.fold_left hpred_add_seed [] sigma
(** Initialize proposition for execution given formal and global
parameters. The footprint is initialized according to the
@ -769,7 +769,7 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
| Config.C_CPP -> Sil.Sizeof (typ, Sil.Subtype.exact)
| Config.Java -> Sil.Sizeof (typ, Sil.Subtype.subtypes) in
Prop.mk_ptsto_lvar (Some tenv) Prop.Fld_init Sil.inst_formal (pv, texp, None) in
list_map do_formal new_formals in
IList.map do_formal new_formals in
let sigma_seed =
create_seed_vars (Prop.get_sigma prop @ sigma_new_formals) (* formals already there plus new ones *) in
let sigma = sigma_seed @ sigma_new_formals in
@ -779,7 +779,7 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
(* inactive until it becomes necessary, as it pollutes props
let fav_ids = Sil.fav_to_list (Prop.sigma_fav sigma_locals) in
let mk_undef_atom id = Prop.mk_neq (Sil.Var id) (Sil.Const (Sil.Cattribute (Sil.Aundef "UNINITIALIZED"))) in
let pi_undef = list_map mk_undef_atom fav_ids in
let pi_undef = IList.map mk_undef_atom fav_ids in
pi_undef @ pi *) in
let prop' =
Prop.replace_pi new_pi (Prop.prop_sigma_star prop sigma) in
@ -792,7 +792,7 @@ let initial_prop tenv (curr_f: Cfg.Procdesc.t) (prop : 'a Prop.t) add_formals :
(Sil.mk_pvar (Mangled.from_string x) (Cfg.Procdesc.get_proc_name curr_f), typ) in
let new_formals =
if add_formals
then list_map construct_decl (Cfg.Procdesc.get_formals curr_f)
then IList.map construct_decl (Cfg.Procdesc.get_formals curr_f)
else [] in (** no new formals added *)
let prop1 = Prop.prop_reset_inst (fun inst_old -> Sil.update_inst inst_old Sil.inst_formal) prop in
let prop2 = prop_init_formals_seed tenv new_formals prop1 in
@ -806,7 +806,7 @@ let initial_prop_from_emp tenv curr_f =
let initial_prop_from_pre tenv curr_f pre =
if !Config.footprint then
let vars = Sil.fav_to_list (Prop.prop_fav pre) in
let sub_list = list_map (fun id -> (id, Sil.Var (Ident.create_fresh (Ident.kfootprint)))) vars in
let sub_list = IList.map (fun id -> (id, Sil.Var (Ident.create_fresh (Ident.kfootprint)))) vars in
let sub = Sil.sub_of_list sub_list in
let pre2 = Prop.prop_sub sub pre in
let pre3 = Prop.replace_sigma_footprint (Prop.get_sigma pre2) (Prop.replace_pi_footprint (Prop.get_pure pre2) pre2) in
@ -838,7 +838,7 @@ let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Spe
L.d_ln ();
let posts, visited =
let pset, visited = collect_postconditions tenv pdesc in
let plist = list_map (fun (p, path) -> (Cfg.remove_seed_vars p, path)) (Paths.PathSet.elements pset) in
let plist = IList.map (fun (p, path) -> (Cfg.remove_seed_vars p, path)) (Paths.PathSet.elements pset) in
plist, visited in
let pre =
let p = Cfg.remove_locals_ret pdesc (Specs.Jprop.to_prop precondition) in
@ -863,13 +863,13 @@ let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Spe
(** get all the nodes in the current call graph with their defined children *)
let get_procs_and_defined_children call_graph =
list_map (fun (n, ns) -> (n, Procname.Set.elements ns)) (Cg.get_nodes_and_defined_children call_graph)
IList.map (fun (n, ns) -> (n, Procname.Set.elements ns)) (Cg.get_nodes_and_defined_children call_graph)
let pp_intra_stats cfg proc_desc fmt proc_name =
let nstates = ref 0 in
let nodes = Cfg.Procdesc.get_nodes proc_desc in
list_iter (fun node -> nstates := !nstates + Paths.PathSet.size (path_set_get_visited (Cfg.Node.get_id node))) nodes;
F.fprintf fmt "(%d nodes containing %d states)" (list_length nodes) !nstates
IList.iter (fun node -> nstates := !nstates + Paths.PathSet.size (path_set_get_visited (Cfg.Node.get_id node))) nodes;
F.fprintf fmt "(%d nodes containing %d states)" (IList.length nodes) !nstates
(** Return functions to perform one phase of the analysis for a procedure.
Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase
@ -896,7 +896,7 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
let specs = Specs.get_specs pname in
let mk_init precondition = (* rename spec vars to footrpint vars, and copy current to footprint *)
initial_prop_from_pre tenv pdesc (Specs.Jprop.to_prop precondition) in
list_map (fun spec -> mk_init spec.Specs.pre) specs in
IList.map (fun spec -> mk_init spec.Specs.pre) specs in
let init_props = Propset.from_proplist (init_prop :: init_props_from_pres) in
let init_edgeset =
let add pset prop =
@ -936,7 +936,7 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
go, get_results in
let re_execution proc_name : (unit -> unit) * (unit -> Prop.normal Specs.spec list) =
let candidate_preconditions = list_map (fun spec -> spec.Specs.pre) (Specs.get_specs proc_name) in
let candidate_preconditions = IList.map (fun spec -> spec.Specs.pre) (Specs.get_specs proc_name) in
let valid_specs = ref [] in
let go () =
L.out "@.#### Start: Re-Execution for %a ####@." Procname.pp proc_name;
@ -957,12 +957,12 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
if !Config.undo_join then
ignore (Specs.Jprop.filter filter candidate_preconditions)
else
ignore (list_map filter candidate_preconditions) in
ignore (IList.map filter candidate_preconditions) in
let get_results () =
let specs = !valid_specs in
L.out "#### [FUNCTION %a] ... OK #####@\n" Procname.pp proc_name;
L.out "#### Finished: Re-Execution for %a ####@." Procname.pp proc_name;
let valid_preconditions = list_map (fun spec -> spec.Specs.pre) specs in
let valid_preconditions = IList.map (fun spec -> spec.Specs.pre) specs in
let filename = DB.Results_dir.path_to_filename DB.Results_dir.Abs_source_dir [(Procname.to_filename proc_name)] in
if !Config.write_dotty then
Dotty.pp_speclist_dotty_file filename specs;
@ -1011,10 +1011,10 @@ let exception_preconditions tenv pname summary =
let collect_spec errors spec =
match !Config.curr_language with
| Config.Java ->
list_fold_left (collect_exceptions spec.Specs.pre) errors spec.Specs.posts
IList.fold_left (collect_exceptions spec.Specs.pre) errors spec.Specs.posts
| Config.C_CPP ->
list_fold_left (collect_errors spec.Specs.pre) errors spec.Specs.posts in
list_fold_left collect_spec [] (Specs.get_specs_from_payload summary)
IList.fold_left (collect_errors spec.Specs.pre) errors spec.Specs.posts in
IList.fold_left collect_spec [] (Specs.get_specs_from_payload summary)
(* Remove the constrain of the form this != null which is true for all Java virtual calls *)
@ -1027,11 +1027,11 @@ let remove_this_not_null prop =
| Sil.Aneq (Sil.Var v, e)
when Ident.equal v var && Sil.exp_equal e Sil.exp_null -> atoms
| a -> a:: atoms in
match list_fold_left collect_hpred (None, []) (Prop.get_sigma prop) with
match IList.fold_left collect_hpred (None, []) (Prop.get_sigma prop) with
| None, _ -> prop
| Some var, filtered_hpreds ->
let filtered_atoms =
list_fold_left (collect_atom var) [] (Prop.get_pi prop) in
IList.fold_left (collect_atom var) [] (Prop.get_pi prop) in
let prop' = Prop.replace_pi filtered_atoms Prop.prop_emp in
let prop'' = Prop.replace_sigma filtered_hpreds prop' in
Prop.normalize prop''
@ -1069,12 +1069,12 @@ let report_runtime_exceptions tenv cfg pdesc summary =
let exn_desc = Localise.java_unchecked_exn_desc pname runtime_exception pre_str in
let exn = Exceptions.Java_runtime_exception (runtime_exception, pre_str, exn_desc) in
Reporting.log_error pname ~pre: (Some (Specs.Jprop.to_prop pre)) exn in
list_iter report (exception_preconditions tenv pname summary)
IList.iter report (exception_preconditions tenv pname summary)
(** update a summary after analysing a procedure *)
let update_summary prev_summary specs proc_name elapsed res =
let normal_specs = list_map Specs.spec_normalize specs in
let normal_specs = IList.map Specs.spec_normalize specs in
let new_specs, changed = Fork.update_specs proc_name normal_specs in
let timestamp = max 1 (prev_summary.Specs.timestamp + if changed then 1 else 0) in
let stats_time = prev_summary.Specs.stats.Specs.stats_time +. elapsed in
@ -1147,7 +1147,7 @@ let perform_transition exe_env cg proc_name =
L.err "Error: %s %a@." err_str pp_ml_location_opt mloco;
[] in
Fork.transition_footprint_re_exe pname joined_pres in
list_iter transition proc_names
IList.iter transition proc_names
(** Process the result of the analysis of [proc_name]: update the
returned summary and add it to the spec table. Executed in the
@ -1190,10 +1190,10 @@ let check_skipped_procs procs_and_defined_children =
| Specs.CallStats.CR_skip, _ ->
skipped_procs := Procname.Set.add pn !skipped_procs
| _ -> () in
let do_call (pn, _) (tr: Specs.CallStats.trace) = list_iter (do_tr_elem pn) tr in
let do_call (pn, _) (tr: Specs.CallStats.trace) = IList.iter (do_tr_elem pn) tr in
Specs.CallStats.iter do_call call_stats in
if Specs.summary_exists pname then process_skip () in
list_iter proc_check_skips procs_and_defined_children;
IList.iter proc_check_skips procs_and_defined_children;
let skipped_procs_with_summary =
Procname.Set.filter Specs.summary_exists !skipped_procs in
skipped_procs_with_summary
@ -1224,13 +1224,13 @@ let do_analysis exe_env =
let calls = ref [] in
let f (callee_pname, loc) = calls := (callee_pname, loc) :: !calls in
Cfg.Procdesc.iter_calls f caller_pdesc;
list_rev !calls in
IList.rev !calls in
let init_proc (pname, dep) =
let cfg = Exe_env.get_cfg exe_env pname in
let pdesc = match Cfg.Procdesc.find_from_name cfg pname with
| Some pdesc -> pdesc
| None -> assert false in
let nodes = list_map (fun n -> Cfg.Node.get_id n) (Cfg.Procdesc.get_nodes pdesc) in
let nodes = IList.map (fun n -> Cfg.Node.get_id n) (Cfg.Procdesc.get_nodes pdesc) in
let proc_flags = Cfg.Procdesc.get_flags pdesc in
let static_err_log = Cfg.Procdesc.get_err_log pdesc in (** err log from translation *)
let calls = get_calls pdesc in
@ -1247,7 +1247,7 @@ let do_analysis exe_env =
if !Config.only_skips then (filter_skipped_procs cg procs_and_defined_children)
else if !Config.only_nospecs then filter_nospecs
else (fun _ -> true) in
list_iter
IList.iter
(fun ((pn, _) as x) ->
let should_init () =
not !Config.ondemand_enabled ||
@ -1282,7 +1282,7 @@ let do_analysis exe_env =
let visited_and_total_nodes cfg =
let all_nodes =
let add s n = Cfg.NodeSet.add n s in
list_fold_left add Cfg.NodeSet.empty (Cfg.Node.get_all_nodes cfg) in
IList.fold_left add Cfg.NodeSet.empty (Cfg.Node.get_all_nodes cfg) in
let filter_node n =
Cfg.Procdesc.is_defined (Cfg.Node.get_proc_desc n) &&
match Cfg.Node.get_kind n with
@ -1297,13 +1297,13 @@ let visited_and_total_nodes cfg =
was defined in another module, and was the one which was analyzed *)
let print_stats_cfg proc_shadowed proc_is_active cfg =
let err_table = Errlog.create_err_table () in
let active_procs = list_filter proc_is_active (Cfg.get_defined_procs cfg) in
let active_procs = IList.filter proc_is_active (Cfg.get_defined_procs cfg) in
let nvisited, ntotal = visited_and_total_nodes cfg in
let node_filter n =
let node_procname = Cfg.Procdesc.get_proc_name (Cfg.Node.get_proc_desc n) in
Specs.summary_exists node_procname && Specs.get_specs node_procname != [] in
let nodes_visited = list_filter node_filter nvisited in
let nodes_total = list_filter node_filter ntotal in
let nodes_visited = IList.filter node_filter nvisited in
let nodes_total = IList.filter node_filter ntotal in
let num_proc = ref 0 in
let num_nospec_noerror_proc = ref 0 in
let num_spec_noerror_proc = ref 0 in
@ -1323,7 +1323,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
let err_log = summary.Specs.attributes.ProcAttributes.err_log in
incr num_proc;
let specs = Specs.get_specs_from_payload summary in
tot_specs := (list_length specs) + !tot_specs;
tot_specs := (IList.length specs) + !tot_specs;
let () =
match specs,
Errlog.size
@ -1344,7 +1344,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
(* F.fprintf fmt "VISITED: %a@\n" (pp_seq pp_node) nodes_visited;
F.fprintf fmt "TOTAL: %a@\n" (pp_seq pp_node) nodes_total; *)
F.fprintf fmt "@\n++++++++++++++++++++++++++++++++++++++++++++++++++@\n";
F.fprintf fmt "+ FILE: %s LOC: %n VISITED: %d/%d SYMOPS: %d@\n" (DB.source_file_to_string !DB.current_source) !Config.nLOC (list_length nodes_visited) (list_length nodes_total) !tot_symops;
F.fprintf fmt "+ FILE: %s LOC: %n VISITED: %d/%d SYMOPS: %d@\n" (DB.source_file_to_string !DB.current_source) !Config.nLOC (IList.length nodes_visited) (IList.length nodes_total) !tot_symops;
F.fprintf fmt "+ num_procs: %d (%d ok, %d timeouts, %d errors, %d warnings, %d infos)@\n" !num_proc num_ok_proc !num_timeout num_errors num_warnings num_infos;
F.fprintf fmt "+ detail procs:@\n";
F.fprintf fmt "+ - No Errors and No Specs: %d@\n" !num_nospec_noerror_proc;
@ -1366,7 +1366,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
print_file_stats fmt ();
close_out outc
with Sys_error _ -> () in
list_iter compute_stats_proc active_procs;
IList.iter compute_stats_proc active_procs;
L.out "%a" print_file_stats ();
save_file_stats ()

10
infer/src/backend/io_infer.ml
Unescape View File

@ -35,10 +35,10 @@ module Html : sig
val pp_start_color : Format.formatter -> color -> unit (** Print start color *)
end = struct
let create pk path =
let fname, dir_path = match list_rev path with
let fname, dir_path = match IList.rev path with
| fname:: dir_path -> fname, dir_path
| [] -> raise (Failure "Html.create") in
let fd = DB.Results_dir.create_file pk (list_rev ((fname ^ ".html") :: dir_path)) in
let fd = DB.Results_dir.create_file pk (IList.rev ((fname ^ ".html") :: dir_path)) in
let outc = Unix.out_channel_of_descr fd in
let fmt = F.formatter_of_out_channel outc in
let (++) x y = x ^ "\n" ^ y in
@ -103,10 +103,10 @@ end = struct
(** get the full html filename from a path *)
let get_full_fname path =
let fname, dir_path = match list_rev path with
let fname, dir_path = match IList.rev path with
| fname:: dir_path -> fname, dir_path
| [] -> raise (Failure "Html.open_out") in
DB.Results_dir.path_to_filename DB.Results_dir.Abs_source_dir (list_rev ((fname ^ ".html") :: dir_path))
DB.Results_dir.path_to_filename DB.Results_dir.Abs_source_dir (IList.rev ((fname ^ ".html") :: dir_path))
let open_out path =
let full_fname = get_full_fname path in
@ -261,7 +261,7 @@ module Xml = struct
| String s ->
F.fprintf fmt "%s%s%s" indent s newline
and pp_forest newline indent fmt forest =
list_iter (pp_node newline indent fmt) forest
IList.iter (pp_node newline indent fmt) forest
let pp_prelude fmt = pp fmt "%s" "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"

14
infer/src/backend/localise.ml
Unescape View File

@ -126,11 +126,11 @@ module Tags = struct
let create () = ref []
let add tags tag value = tags := (tag, value) :: !tags
let update tags tag value =
let tags' = list_filter (fun (t, v) -> t <> tag) tags in
let tags' = IList.filter (fun (t, v) -> t <> tag) tags in
(tag, value) :: tags'
let get tags tag =
try
let (_, v) = list_find (fun (t, _) -> t = tag) tags in
let (_, v) = IList.find (fun (t, _) -> t = tag) tags in
Some v
with Not_found -> None
end
@ -151,7 +151,7 @@ let error_desc_extract_tag_value (_, _, tags) tag_to_extract =
| (t, _) when t = tag -> true
| _ -> false in
try
let _, s = list_find (find_value tag_to_extract) tags in
let _, s = IList.find (find_value tag_to_extract) tags in
s
with Not_found -> ""
@ -178,8 +178,8 @@ let error_desc_set_bucket (l, advice, tags) bucket show_in_message =
(** get the value tag, if any *)
let get_value_line_tag tags =
try
let value = snd (list_find (fun (_tag, value) -> _tag = Tags.value) tags) in
let line = snd (list_find (fun (_tag, value) -> _tag = Tags.line) tags) in
let value = snd (IList.find (fun (_tag, value) -> _tag = Tags.value) tags) in
let line = snd (IList.find (fun (_tag, value) -> _tag = Tags.line) tags) in
Some [value; line]
with Not_found -> None
@ -461,7 +461,7 @@ let parameter_field_not_null_checked_desc desc exp =
let has_tag desc tag =
match desc with
| descriptions, advice, tags ->
list_exists (fun (tag', value) -> tag = tag') tags
IList.exists (fun (tag', value) -> tag = tag') tags
let is_parameter_not_null_checked_desc desc = has_tag desc Tags.parameter_not_null_checked
@ -658,7 +658,7 @@ let desc_retain_cycle prop cycle loc =
str_cycle:=!str_cycle^" ("^(string_of_int !ct)^") an object of "^(Sil.typ_to_string typ)^" retaining another object via instance variable "^(Ident.fieldname_to_string f)^", ";
ct:=!ct +1
| _ -> () in
list_iter do_edge cycle;
IList.iter do_edge cycle;
let desc = Format.sprintf "Retain cycle involving the following objects: %s %s"
!str_cycle (at_line tags loc) in
[desc], None, !tags

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

@ -15,7 +15,7 @@ module F = Format
open Utils
let mem_idlist i l =
list_exists (Ident.equal i) l
IList.exists (Ident.equal i) l
(** Type for a hpred pattern. flag=false means that the implication
between hpreds is not considered, and flag = true means that it is
@ -40,7 +40,7 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
in if (Sil.exp_equal e1 e2_inst) then Some(sub, vars) else None in
match e1, e2 with
| _, Sil.Var id2 when (Ident.is_primed id2 && mem_idlist id2 vars) ->
let vars_new = list_filter (fun id -> not (Ident.equal id id2)) vars in
let vars_new = IList.filter (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
@ -82,8 +82,8 @@ let exp_list_match es1 sub vars es2 =
let f res_acc (e1, e2) = match res_acc with
| None -> None
| Some (sub_acc, vars_leftover) -> exp_match e1 sub_acc vars_leftover e2 in
let es_combined = try list_combine es1 es2 with Invalid_argument _ -> assert false in
let es_match_res = list_fold_left f (Some (sub, vars)) es_combined
let es_combined = try IList.combine es1 es2 with Invalid_argument _ -> assert false in
let es_match_res = IList.fold_left f (Some (sub, vars)) es_combined
in es_match_res
(** Checks sexp1 = sexp2[sub ++ sub'] for some sub' with
@ -135,7 +135,7 @@ and isel_match isel1 sub vars isel2 =
| [], _ | _, [] -> None
| (idx1, se1') :: isel1', (idx2, se2') :: isel2' ->
let idx2 = Sil.exp_sub sub idx2 in
let sanity_check = not (list_exists (fun id -> Sil.ident_in_exp id idx2) vars) in
let sanity_check = not (IList.exists (fun id -> Sil.ident_in_exp id idx2) vars) in
if (not sanity_check) then begin
let pe = pe_text in
L.out "@[.... Sanity Check Failure while Matching Index-Strexps ....@.";
@ -156,12 +156,12 @@ let sub_extend_with_ren (sub: Sil.subst) vars =
(*
let check_precondition () =
let dom = Sil.sub_domain sub in
let overlap = list_exists (fun id -> list_exists (Ident.equal id) dom) vars in
let overlap = IList.exists (fun id -> IList.exists (Ident.equal id) dom) vars in
if overlap then assert false in
check_precondition ();
*)
let f id = (id, Sil.Var (Ident.create_fresh Ident.kprimed)) in
let renaming_for_vars = Sil.sub_of_list (list_map f vars) in
let renaming_for_vars = Sil.sub_of_list (IList.map f vars) in
Sil.sub_join sub renaming_for_vars
type sidecondition = Prop.normal Prop.t -> Sil.subst -> bool
@ -182,7 +182,7 @@ let rec instantiate_to_emp p condition sub vars = function
else match hpat.hpred with
| Sil.Hpointsto _ | Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) | Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) -> None
| Sil.Hlseg (k, _, e1, e2, _) ->
let fully_instantiated = not (list_exists (fun id -> Sil.ident_in_exp id e1) vars)
let fully_instantiated = not (IList.exists (fun id -> Sil.ident_in_exp id e1) vars)
in if (not fully_instantiated) then None else
let e1' = Sil.exp_sub sub e1
in begin
@ -193,7 +193,7 @@ let rec instantiate_to_emp p condition sub vars = function
end
| Sil.Hdllseg (k, _, iF, oB, oF, iB, _) ->
let fully_instantiated =
not (list_exists (fun id -> Sil.ident_in_exp id iF || Sil.ident_in_exp id oB) vars)
not (IList.exists (fun id -> Sil.ident_in_exp id iF || Sil.ident_in_exp id oB) vars)
in if (not fully_instantiated) then None else
let iF' = Sil.exp_sub sub iF in
let oB' = Sil.exp_sub sub oB
@ -289,7 +289,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| Sil.Hlseg (k2, para2, e_start2, e_end2, es_shared2) ->
let filter = gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 in
let do_emp_lseg _ =
let fully_instantiated_start2 = not (list_exists (fun id -> Sil.ident_in_exp id e_start2) vars) in
let fully_instantiated_start2 = not (IList.exists (fun id -> Sil.ident_in_exp id e_start2) vars) in
if (not fully_instantiated_start2) then None
else
let e_start2' = Sil.exp_sub sub e_start2 in
@ -313,7 +313,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let (para2_exist_vars, para2_inst) = Sil.hpara_instantiate para2 e_start2 e_end2 es_shared2 in
(* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *)
let allow_impl hpred = { hpred = hpred; flag = true } in
let (para2_hpat, para2_hpats) = match list_map allow_impl para2_inst with
let (para2_hpat, para2_hpats) = match IList.map allow_impl para2_inst with
| [] -> assert false (* the body of a parameter should contain at least one * conjunct *)
| para2_pat :: para2_pats -> (para2_pat, para2_pats) in
let new_vars = para2_exist_vars @ vars in
@ -322,7 +322,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| None -> None
| Some (sub_res, p_leftover) when condition p_leftover sub_res ->
let not_in_para2_exist_vars id =
not (list_exists (fun id' -> Ident.equal id id') para2_exist_vars) in
not (IList.exists (fun id' -> Ident.equal id id') para2_exist_vars) in
let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res
in Some (sub_res', p_leftover)
| Some _ -> None
@ -347,7 +347,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let filter = gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 in
let do_emp_dllseg _ =
let fully_instantiated_iFoB2 =
not (list_exists (fun id -> Sil.ident_in_exp id iF2 || Sil.ident_in_exp id oB2) vars)
not (IList.exists (fun id -> Sil.ident_in_exp id iF2 || Sil.ident_in_exp id oB2) vars)
in if (not fully_instantiated_iFoB2) then None else
let iF2' = Sil.exp_sub sub iF2 in
let oB2' = Sil.exp_sub sub oB2
@ -361,7 +361,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let p = Prop.prop_iter_to_prop iter
in prop_match_with_impl_sub p condition sub_new vars_leftover hpat_next hpats_rest in
let do_para_dllseg _ =
let fully_instantiated_iF2 = not (list_exists (fun id -> Sil.ident_in_exp id iF2) vars)
let fully_instantiated_iF2 = not (IList.exists (fun id -> Sil.ident_in_exp id iF2) vars)
in if (not fully_instantiated_iF2) then None else
let iF2' = Sil.exp_sub sub iF2
in match exp_match iF2' sub vars iB2 with
@ -370,7 +370,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let (para2_exist_vars, para2_inst) = Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 es_shared2 in
(* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *)
let allow_impl hpred = { hpred = hpred; flag = true } in
let (para2_hpat, para2_hpats) = match list_map allow_impl para2_inst with
let (para2_hpat, para2_hpats) = match IList.map allow_impl para2_inst with
| [] -> assert false (* the body of a parameter should contain at least one * conjunct *)
| para2_pat :: para2_pats -> (para2_pat, para2_pats) in
let new_vars = para2_exist_vars @ vars_leftover in
@ -379,7 +379,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| None -> None
| Some (sub_res, p_leftover) when condition p_leftover sub_res ->
let not_in_para2_exist_vars id =
not (list_exists (fun id' -> Ident.equal id id') para2_exist_vars) in
not (IList.exists (fun id' -> Ident.equal id id') para2_exist_vars) in
let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res
in Some (sub_res', p_leftover)
| Some _ -> None
@ -408,14 +408,14 @@ and prop_match_with_impl_sub p condition sub vars hpat hpats =
and hpara_common_match_with_impl impl_ok ids1 sigma1 eids2 ids2 sigma2 =
try
let sub_ids =
let ren_ids = list_combine ids2 ids1 in
let ren_ids = IList.combine ids2 ids1 in
let f (id2, id1) = (id2, Sil.Var id1) in
list_map f ren_ids in
IList.map f ren_ids in
let (sub_eids, eids_fresh) =
let f id = (id, Ident.create_fresh Ident.kprimed) in
let ren_eids = list_map f eids2 in
let eids_fresh = list_map snd ren_eids in
let sub_eids = list_map (fun (id2, id1) -> (id2, Sil.Var id1)) ren_eids in
let ren_eids = IList.map f eids2 in
let eids_fresh = IList.map snd ren_eids in
let sub_eids = IList.map (fun (id2, id1) -> (id2, Sil.Var id1)) ren_eids in
(sub_eids, eids_fresh) in
let sub = Sil.sub_of_list (sub_ids @ sub_eids) in
match sigma2 with
@ -424,7 +424,7 @@ and hpara_common_match_with_impl impl_ok ids1 sigma1 eids2 ids2 sigma2 =
let (hpat2, hpats2) =
let (hpred2_ren, sigma2_ren) = (Sil.hpred_sub sub hpred2, Prop.sigma_sub sub sigma2) in
let allow_impl hpred = { hpred = hpred; flag = impl_ok } in
(allow_impl hpred2_ren, list_map allow_impl sigma2_ren) in
(allow_impl hpred2_ren, IList.map allow_impl sigma2_ren) in
let condition _ _ = true in
let p1 = Prop.normalize (Prop.from_sigma sigma1) in
begin
@ -472,7 +472,7 @@ let sigma_remove_hpred eq sigma e =
| Sil.Hpointsto (root, _, _)
| Sil.Hlseg (_, _, root, _, _)
| Sil.Hdllseg (_, _, root, _, _, _, _) -> eq root e in
let sigma_e, sigma_no_e = list_partition filter sigma in
let sigma_e, sigma_no_e = IList.partition filter sigma in
match sigma_e with
| [] -> (None, sigma)
| [hpred_e] -> (Some hpred_e, sigma_no_e)
@ -491,13 +491,13 @@ let rec generate_todos_from_strexp mode todos sexp1 sexp2 =
| Sil.Eexp _, _ ->
None
| Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) -> (* assume sorted w.r.t. fields *)
if (list_length fel1 <> list_length fel2) && mode == Exact
if (IList.length fel1 <> IList.length fel2) && mode == Exact
then None
else generate_todos_from_fel mode todos fel1 fel2
| Sil.Estruct _, _ ->
None
| Sil.Earray (size1, iel1, _), Sil.Earray (size2, iel2, _) ->
if (not (Sil.exp_equal size1 size2) || list_length iel1 <> list_length iel2)
if (not (Sil.exp_equal size1 size2) || IList.length iel1 <> IList.length iel2)
then None
else generate_todos_from_iel mode todos iel1 iel2
| Sil.Earray _, _ ->
@ -545,19 +545,19 @@ and generate_todos_from_iel mode todos iel1 iel2 =
let corres_extend_front e1 e2 corres =
let filter (e1', e2') = (Sil.exp_equal e1 e1') || (Sil.exp_equal e2 e2') in
let checker e1' e2' = (Sil.exp_equal e1 e1') && (Sil.exp_equal e2 e2')
in match (list_filter filter corres) with
in match (IList.filter filter corres) with
| [] -> Some ((e1, e2) :: corres)
| [(e1', e2')] when checker e1' e2' -> Some corres
| _ -> None
let corres_extensible corres e1 e2 =
let predicate (e1', e2') = (Sil.exp_equal e1 e1') || (Sil.exp_equal e2 e2')
in not (list_exists predicate corres) && not (Sil.exp_equal e1 e2)
in not (IList.exists predicate corres) && not (Sil.exp_equal e1 e2)
let corres_related corres e1 e2 =
let filter (e1', e2') = (Sil.exp_equal e1 e1') || (Sil.exp_equal e2 e2') in
let checker e1' e2' = (Sil.exp_equal e1 e1') && (Sil.exp_equal e2 e2') in
match (list_filter filter corres) with
match (IList.filter filter corres) with
| [] -> Sil.exp_equal e1 e2
| [(e1', e2')] when checker e1' e2' -> true
| _ -> false
@ -579,7 +579,7 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
match todos with
| [] ->
let sigma1, sigma2 = sigma_corres in
Some (list_rev corres, list_rev sigma1, list_rev sigma2, sigma_todo)
Some (IList.rev corres, IList.rev sigma1, IList.rev sigma2, sigma_todo)
| (e1, e2) :: todos' when corres_related corres e1 e2 ->
begin
match corres_extend_front e1 e2 corres with
@ -633,7 +633,7 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in
let new_todos =
let shared12 = list_combine shared1 shared2 in
let shared12 = IList.combine shared1 shared2 in
(root1, root2) :: (next1, next2) :: shared12 @ todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None)
@ -651,7 +651,7 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in
let new_todos =
let shared12 = list_combine shared1 shared2 in
let shared12 = IList.combine shared1 shared2 in
(iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None)
@ -700,7 +700,7 @@ let hpred_lift_to_pe hpred =
(** Lift the kind of list segment predicates to PE in a given sigma *)
let sigma_lift_to_pe sigma =
list_map hpred_lift_to_pe sigma
IList.map hpred_lift_to_pe sigma
(** [generic_para_create] takes a correspondence, and a sigma
and a list of expressions for the first part of this
@ -714,20 +714,20 @@ let generic_para_create corres sigma1 elist1 =
let not_same_consts = function
| Sil.Const c1, Sil.Const c2 -> not (Sil.const_equal c1 c2)
| _ -> true in
let new_corres' = list_filter not_same_consts corres in
let new_corres' = IList.filter not_same_consts corres in
let add_fresh_id pair = (pair, Ident.create_fresh Ident.kprimed) in
list_map add_fresh_id new_corres' in
IList.map add_fresh_id new_corres' in
let (es_shared, ids_shared, ids_exists) =
let not_in_elist1 ((e1, _), _) = not (list_exists (Sil.exp_equal e1) elist1) in
let corres_ids_no_elist1 = list_filter not_in_elist1 corres_ids in
let not_in_elist1 ((e1, _), _) = not (IList.exists (Sil.exp_equal e1) elist1) in
let corres_ids_no_elist1 = IList.filter not_in_elist1 corres_ids in
let should_be_shared ((e1, e2), _) = Sil.exp_equal e1 e2 in
let shared, exists = list_partition should_be_shared corres_ids_no_elist1 in
let es_shared = list_map (fun ((e1, _), _) -> e1) shared in
(es_shared, list_map snd shared, list_map snd exists) in
let renaming = list_map (fun ((e1, _), id) -> (e1, id)) corres_ids in
let shared, exists = IList.partition should_be_shared corres_ids_no_elist1 in
let es_shared = IList.map (fun ((e1, _), _) -> e1) shared in
(es_shared, IList.map snd shared, IList.map snd exists) in
let renaming = IList.map (fun ((e1, _), id) -> (e1, id)) corres_ids in
let body =
let sigma1' = sigma_lift_to_pe sigma1 in
let renaming_exp = list_map (fun (e1, id) -> (e1, Sil.Var id)) renaming in
let renaming_exp = IList.map (fun (e1, id) -> (e1, Sil.Var id)) renaming in
Prop.sigma_replace_exp renaming_exp sigma1' in
(renaming, body, ids_exists, ids_shared, es_shared)
@ -741,7 +741,7 @@ let hpara_create corres sigma1 root1 next1 =
let get_id1 e1 =
try
let is_equal_to_e1 (e1', _) = Sil.exp_equal e1 e1' in
let _, id = list_find is_equal_to_e1 renaming in
let _, id = IList.find is_equal_to_e1 renaming in
id
with Not_found -> assert false in
let id_root = get_id1 root1 in
@ -764,7 +764,7 @@ let hpara_dll_create corres sigma1 root1 blink1 flink1 =
let get_id1 e1 =
try
let is_equal_to_e1 (e1', _) = Sil.exp_equal e1 e1' in
let _, id = list_find is_equal_to_e1 renaming in
let _, id = IList.find is_equal_to_e1 renaming in
id
with Not_found -> assert false in
let id_root = get_id1 root1 in

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

@ -68,20 +68,20 @@ let init_buckets ml_buckets_arg =
let buckets =
match buckets with
| ["all"] -> []
| _ -> list_map bucket_from_string buckets in
| _ -> IList.map bucket_from_string buckets in
ml_buckets := buckets
let contains_cf ml_buckets =
list_mem mleak_bucket_eq MLeak_cf ml_buckets
IList.mem mleak_bucket_eq MLeak_cf ml_buckets
let contains_arc ml_buckets =
list_mem mleak_bucket_eq MLeak_arc ml_buckets
IList.mem mleak_bucket_eq MLeak_arc ml_buckets
let contains_narc ml_buckets =
list_mem mleak_bucket_eq MLeak_no_arc ml_buckets
IList.mem mleak_bucket_eq MLeak_no_arc ml_buckets
let contains_cpp ml_buckets =
list_mem mleak_bucket_eq MLeak_cpp ml_buckets
IList.mem mleak_bucket_eq MLeak_cpp ml_buckets
let should_raise_leak_cf typ =
if contains_cf !ml_buckets then
@ -110,7 +110,7 @@ let should_raise_cpp_leak () =
(* If arc is passed, check leaks from code that compiles with arc*)
(* If no arc is passed check the leaks from code that compiles without arc *)
let should_raise_objc_leak typ =
if list_length !ml_buckets = 0 then Some ""
if IList.length !ml_buckets = 0 then Some ""
else
if should_raise_leak_cf typ then Some (bucket_to_message MLeak_cf)
else if should_raise_leak_arc () then Some (bucket_to_message MLeak_arc)

8
infer/src/backend/objc_models.ml
Unescape View File

@ -201,8 +201,8 @@ struct
| Core_graphics -> core_graphics_types
let is_objc_memory_model_controlled o =
list_mem (string_equal) o core_foundation_types ||
list_mem (string_equal) o core_graphics_types
IList.mem (string_equal) o core_foundation_types ||
IList.mem (string_equal) o core_graphics_types
let rec is_core_lib lib typ =
match typ with
@ -211,7 +211,7 @@ struct
| Sil.Tvar (Sil.TN_csu (_, name) )
| Sil.Tstruct(_, _, _, (Some name), _, _, _) ->
let core_lib_types = core_lib_to_type_list lib in
list_mem (=) (Mangled.to_string name) core_lib_types
IList.mem (=) (Mangled.to_string name) core_lib_types
| _ -> false
let is_core_foundation_type typ =
@ -244,7 +244,7 @@ struct
let is_core_graphics_release typ funct =
try
let cg_typ = list_find
let cg_typ = IList.find
(fun lib -> (funct = (lib^upper_release))) core_graphics_types in
(string_contains (cg_typ^ref) typ)
with Not_found -> false

6
infer/src/backend/objc_preanal.ml
Unescape View File

@ -28,7 +28,7 @@ let process_all_cfgs process_function default_value =
match cfg_opt with
| None -> value
| Some cfg -> process_function cfg source_dir in
list_fold_right process_dir source_dirs default_value
IList.fold_right process_dir source_dirs default_value
let process_procedures process_function default_value procedure_type =
let process_cfg_procedures cfg source_dir =
@ -37,7 +37,7 @@ let process_procedures process_function default_value procedure_type =
| DEFINED -> Cfg.get_defined_procs cfg
| ALL -> Cfg.get_all_procs cfg
| OBJC_GENERATED -> Cfg.get_objc_generated_procs cfg in
list_fold_right (process_function cfg source_dir) procdescs default_value in
IList.fold_right (process_function cfg source_dir) procdescs default_value in
process_all_cfgs process_cfg_procedures default_value
let process_all_procedures process_function default_value =
@ -89,7 +89,7 @@ let update_cfgs generated_proc_map =
Cg.node_set_defined cg pname false;
true)
else need_updating in
let need_updating = list_fold_right update_cfg_procdesc generated_procs false in
let need_updating = IList.fold_right update_cfg_procdesc generated_procs false in
if need_updating then
(Cfg.store_cfg_to_file cfg_name false cfg;
Cg.store_to_file cg_name cg) in

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

@ -321,12 +321,12 @@ end = struct
if !position_seen then
let rec remove_until_seen = function
| ((level, p, session, exn_opt) as x):: l ->
if path_pos_at_path p then list_rev (x :: l)
if path_pos_at_path p then IList.rev (x :: l)
else remove_until_seen l
| [] -> [] in
remove_until_seen inverse_sequence
else list_rev inverse_sequence in
list_iter (fun (level, p, session, exn_opt) -> f level p session exn_opt) sequence_up_to_last_seen
else IList.rev inverse_sequence in
IList.iter (fun (level, p, session, exn_opt) -> f level p session exn_opt) sequence_up_to_last_seen
module NodeMap = Map.Make (Cfg.Node)
@ -473,8 +473,8 @@ end = struct
let n = int_compare lt1.Errlog.lt_level lt2.Errlog.lt_level in
if n <> 0 then n else Location.compare lt1.Errlog.lt_loc lt2.Errlog.lt_loc in
let relevant lt = lt.Errlog.lt_node_tags <> [] in
list_remove_irrelevant_duplicates compare relevant (list_rev !trace)
(* list_remove_duplicates compare (list_sort compare !trace) *)
IList.remove_irrelevant_duplicates compare relevant (IList.rev !trace)
(* IList.remove_duplicates compare (IList.sort compare !trace) *)
end
(* =============== END of the Path module ===============*)
@ -561,7 +561,7 @@ end = struct
!plist
let to_proplist ps =
list_map fst (elements ps)
IList.map fst (elements ps)
let to_propset ps =
Propset.from_proplist (to_proplist ps)
@ -569,16 +569,16 @@ end = struct
let filter f ps =
let elements = ref [] in
PropMap.iter (fun p _ -> elements := p :: !elements) ps;
elements := list_filter (fun p -> not (f p)) !elements;
elements := IList.filter (fun p -> not (f p)) !elements;
let filtered_map = ref ps in
list_iter (fun p -> filtered_map := PropMap.remove p !filtered_map) !elements;
IList.iter (fun p -> filtered_map := PropMap.remove p !filtered_map) !elements;
!filtered_map
let partition f ps =
let elements = ref [] in
PropMap.iter (fun p _ -> elements := p :: !elements) ps;
let el1, el2 = ref ps, ref ps in
list_iter (fun p -> if f p then el2 := PropMap.remove p !el2 else el1 := PropMap.remove p !el1) !elements;
IList.iter (fun p -> if f p then el2 := PropMap.remove p !el2 else el1 := PropMap.remove p !el1) !elements;
!el1, !el2
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *)
@ -658,7 +658,7 @@ end = struct
(** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *)
let from_renamed_list (pl : ('a Prop.t * Path.t) list) : t =
list_fold_left (fun ps (p, pa) -> add_renamed_prop p pa ps) empty pl
IList.fold_left (fun ps (p, pa) -> add_renamed_prop p pa ps) empty pl
end
(* =============== END of the PathSet module ===============*)

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

@ -32,10 +32,10 @@ module AllPreds = struct
with Not_found ->
NodeHash.add preds_table nto (Cfg.NodeSet.singleton nfrom) in
let do_node n =
list_iter (add_edge false n) (Cfg.Node.get_succs n);
list_iter (add_edge true n) (Cfg.Node.get_exn n) in
IList.iter (add_edge false n) (Cfg.Node.get_succs n);
IList.iter (add_edge true n) (Cfg.Node.get_exn n) in
let proc_nodes = Cfg.Procdesc.get_nodes pdesc in
list_iter do_node proc_nodes in
IList.iter do_node proc_nodes in
clear_table ();
Cfg.iter_proc_desc cfg do_pdesc
@ -62,7 +62,7 @@ let is_not_function cfg x =
let is_captured_pvar pdesc x =
let captured = Cfg.Procdesc.get_captured pdesc in
list_exists (fun (m, _) -> (Sil.pvar_to_string x) = (Mangled.to_string m)) captured
IList.exists (fun (m, _) -> (Sil.pvar_to_string x) = (Mangled.to_string m)) captured
(** variables read in the expression *)
let rec use_exp cfg pdesc (exp: Sil.exp) acc =
@ -76,7 +76,7 @@ let rec use_exp cfg pdesc (exp: Sil.exp) acc =
let defining_proc = Cfg.Procdesc.get_proc_name pdesc in
(match !found_pd with
| Some pd ->
list_iter (fun (x, _) ->
IList.iter (fun (x, _) ->
captured_var:= Vset.add (Sil.mk_pvar x defining_proc) !captured_var
) (Cfg.Procdesc.get_captured pd)
| _ -> ());
@ -89,10 +89,10 @@ let rec use_exp cfg pdesc (exp: Sil.exp) acc =
| Sil.BinOp (_, e1, e2) | Sil.Lindex (e1, e2) -> use_exp cfg pdesc e1 (use_exp cfg pdesc e2 acc)
and use_etl cfg pdesc (etl: (Sil.exp * Sil.typ) list) acc =
list_fold_left (fun acc (e, _) -> use_exp cfg pdesc e acc) acc etl
IList.fold_left (fun acc (e, _) -> use_exp cfg pdesc e acc) acc etl
and use_instrl cfg tenv (pdesc: Cfg.Procdesc.t) (il : Sil.instr list) acc =
list_fold_left (fun acc instr -> use_instr cfg tenv pdesc instr acc) acc il
IList.fold_left (fun acc instr -> use_instr cfg tenv pdesc instr acc) acc il
and use_instr cfg tenv (pdesc: Cfg.Procdesc.t) (instr: Sil.instr) acc =
match instr with
@ -121,7 +121,7 @@ let rec def_instr cfg (instr: Sil.instr) acc =
| Sil.Goto_node _ -> acc
and def_instrl cfg instrs acc =
list_fold_left (fun acc' i -> def_instr cfg i acc') acc instrs
IList.fold_left (fun acc' i -> def_instr cfg i acc') acc instrs
(* computes the addresses that are assigned to something or passed as parameters to*)
(* a functions. These will be considered becoming possibly aliased *)
@ -129,19 +129,19 @@ let rec aliasing_instr cfg pdesc (instr: Sil.instr) acc =
match instr with
| Sil.Set (_, _, e, _) -> use_exp cfg pdesc e acc
| Sil.Call (_, _, argl, _, _) ->
let argl'= fst (list_split argl) in
list_fold_left (fun acc' e' -> use_exp cfg pdesc e' acc') acc argl'
let argl'= fst (IList.split argl) in
IList.fold_left (fun acc' e' -> use_exp cfg pdesc e' acc') acc argl'
| Sil.Letderef _ | Sil.Prune _ -> acc
| Sil.Nullify _ -> acc
| Sil.Abstract _ | Sil.Remove_temps _ | Sil.Stackop _ | Sil.Declare_locals _ -> acc
| Sil.Goto_node _ -> acc
and aliasing_instrl cfg pdesc (il : Sil.instr list) acc =
list_fold_left (fun acc instr -> aliasing_instr cfg pdesc instr acc) acc il
IList.fold_left (fun acc instr -> aliasing_instr cfg pdesc instr acc) acc il
(* computes possible alisased var *)
let def_aliased_var cfg pdesc instrs acc =
list_fold_left (fun acc' i -> aliasing_instr cfg pdesc i acc') acc instrs
IList.fold_left (fun acc' i -> aliasing_instr cfg pdesc i acc') acc instrs
(** variables written by instructions in the node *)
let def_node cfg node acc =
@ -155,7 +155,7 @@ let compute_live_instr cfg tenv pdesc s instr =
use_instr cfg tenv pdesc instr (Vset.diff s (def_instr cfg instr Vset.empty))
let compute_live_instrl cfg tenv pdesc instrs livel =
list_fold_left (compute_live_instr cfg tenv pdesc) livel (list_rev instrs)
IList.fold_left (compute_live_instr cfg tenv pdesc) livel (IList.rev instrs)
module Worklist = struct
module S = Cfg.NodeSet
@ -164,7 +164,7 @@ module Worklist = struct
let reset _ = worklist := S.empty
let add node = worklist := S.add node !worklist
let add_list = list_iter add
let add_list = IList.iter add
let pick () =
let min = S.min_elt !worklist in
worklist := S.remove min !worklist;
@ -194,13 +194,13 @@ end = struct
if not (Vset.equal oldset newset) then Worklist.add node
with Not_found ->
replace node set; Worklist.add node in
list_iter do_node preds
IList.iter do_node preds
let iter init f =
let get_live_preds init node = (** nodes live at predecessors *)
match AllPreds.get_preds node with
| [] -> init
| preds -> list_fold_left Vset.union Vset.empty (list_map get_live preds) in
| preds -> IList.fold_left Vset.union Vset.empty (IList.map get_live preds) in
H.iter (fun node live -> f node (get_live_preds init node) live) table
end
@ -226,11 +226,11 @@ let compute_candidates procdesc : Vset.t * (Vset.t -> Vset.elt list) =
candidates := Vset.add pv !candidates;
if typ_is_struct_array typ then struct_array_cand := Vset.add pv !struct_array_cand
) in
list_iter add_vi (list_map (fun (var, typ) -> Mangled.from_string var, typ) (Cfg.Procdesc.get_formals procdesc));
list_iter add_vi (Cfg.Procdesc.get_locals procdesc);
IList.iter add_vi (IList.map (fun (var, typ) -> Mangled.from_string var, typ) (Cfg.Procdesc.get_formals procdesc));
IList.iter add_vi (Cfg.Procdesc.get_locals procdesc);
let get_sorted_candidates vs =
let priority, no_pri = list_partition (fun pv -> Vset.mem pv !struct_array_cand) (Vset.elements vs) in
list_rev_append (list_rev priority) no_pri in
let priority, no_pri = IList.partition (fun pv -> Vset.mem pv !struct_array_cand) (Vset.elements vs) in
IList.rev_append (IList.rev priority) no_pri in
!candidates, get_sorted_candidates
(** Construct a table wich associates to each node a set of live variables *)
@ -264,7 +264,7 @@ let print_aliased_var s al_var =
(* Printing function useful for debugging *)
let print_aliased_var_l s al_var =
L.out s;
list_iter (fun v -> L.out " %a, " (Sil.pp_pvar pe_text) v) al_var;
IList.iter (fun v -> L.out " %a, " (Sil.pp_pvar pe_text) v) al_var;
L.out "@."
(* Instruction i is nullifying a block variable *)
@ -277,16 +277,16 @@ let is_block_nullify i =
let node_add_nullify_instrs n dead_vars_after dead_vars_before =
let loc = Cfg.Node.get_last_loc n in
let move_tmp_pvars_first pvars =
let pvars_tmp, pvars_notmp = list_partition Errdesc.pvar_is_frontend_tmp pvars in
let pvars_tmp, pvars_notmp = IList.partition Errdesc.pvar_is_frontend_tmp pvars in
pvars_tmp @ pvars_notmp in
let instrs_after =
list_map (fun pvar -> Sil.Nullify (pvar, loc, false)) (move_tmp_pvars_first dead_vars_after) in
IList.map (fun pvar -> Sil.Nullify (pvar, loc, false)) (move_tmp_pvars_first dead_vars_after) in
let instrs_before =
list_map (fun pvar -> Sil.Nullify (pvar, loc, false)) (move_tmp_pvars_first dead_vars_before) in
IList.map (fun pvar -> Sil.Nullify (pvar, loc, false)) (move_tmp_pvars_first dead_vars_before) in
(* Nullify(bloc_var,_,true) can be placed in the middle of the block because when we add this instruction*)
(* we don't have already all the instructions of the node. Here we reorder the instructions to move *)
(* nullification of blocks at the end of existing instructions. *)
let block_nullify, no_block_nullify = list_partition is_block_nullify (Cfg.Node.get_instrs n) in
let block_nullify, no_block_nullify = IList.partition is_block_nullify (Cfg.Node.get_instrs n) in
Cfg.Node.replace_instrs n (no_block_nullify @ block_nullify);
Cfg.Node.append_instrs_temps n instrs_after [];
Cfg.Node.prepend_instrs_temps n instrs_before []
@ -318,12 +318,12 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
| Cfg.Node.Prune_node _ | Cfg.Node.Join_node when node_assigns_no_variables cfg node && not (next_is_exit node) ->
(* cannot push nullify instructions after an assignment, as they could nullify the same variable *)
let succs = Cfg.Node.get_succs node in
list_iter (add_after_prune_join false) succs
IList.iter (add_after_prune_join false) succs
| _ ->
let new_dead_pvs =
let old_pvs = Cfg.Node.get_dead_pvars node is_after in
let pv_is_new pv = not (list_exists (Sil.pvar_equal pv) old_pvs) in
(list_filter pv_is_new dead_pvars) @ old_pvs in
let pv_is_new pv = not (IList.exists (Sil.pvar_equal pv) old_pvs) in
(IList.filter pv_is_new dead_pvars) @ old_pvs in
Cfg.Node.set_dead_pvars node is_after new_dead_pvs
end in
add_after_prune_join true n
@ -345,7 +345,7 @@ let analyze_and_annotate_proc cfg tenv pname pdesc =
let dead_pvars_added = ref 0 in
let dead_pvars_limit = 100000 in
let incr_dead_pvars_added pvars =
let num = list_length pvars in
let num = IList.length pvars in
dead_pvars_added := num + !dead_pvars_added;
if !dead_pvars_added > dead_pvars_limit && !dead_pvars_added - num <= dead_pvars_limit
then L.err "WARNING: liveness: more than %d dead pvars added in procedure %a, stopping@." dead_pvars_limit Procname.pp pname in
@ -366,7 +366,7 @@ let analyze_and_annotate_proc cfg tenv pname pdesc =
else dead_pvars_no_alias in
incr_dead_pvars_added dead_pvars_to_add;
if !dead_pvars_added < dead_pvars_limit then add_dead_pvars_after_conditionals_join cfg n dead_pvars_to_add);
list_iter (fun n -> (* generate nullify instructions *)
IList.iter (fun n -> (* generate nullify instructions *)
let dead_pvs_after = Cfg.Node.get_dead_pvars n true in
let dead_pvs_before = Cfg.Node.get_dead_pvars n false in
node_add_nullify_instrs n dead_pvs_after dead_pvs_before)

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

@ -65,23 +65,23 @@ end = struct
(Escape.escape_xml (Procname.to_string proc_name))
(Io_infer.Html.pp_line_link [".."]) loc.Location.line;
F.fprintf fmt "<br>PREDS:@\n";
list_iter (fun node ->
IList.iter (fun node ->
Io_infer.Html.pp_node_link [".."] ""
(list_map Cfg.Node.get_id (Cfg.Node.get_preds node))
(list_map Cfg.Node.get_id (Cfg.Node.get_succs node))
(list_map Cfg.Node.get_id (Cfg.Node.get_exn node))
(IList.map Cfg.Node.get_id (Cfg.Node.get_preds node))
(IList.map Cfg.Node.get_id (Cfg.Node.get_succs node))
(IList.map Cfg.Node.get_id (Cfg.Node.get_exn node))
(is_visited node) false fmt (Cfg.Node.get_id node)) preds;
F.fprintf fmt "<br>SUCCS: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] ""
(list_map Cfg.Node.get_id (Cfg.Node.get_preds node))
(list_map Cfg.Node.get_id (Cfg.Node.get_succs node))
(list_map Cfg.Node.get_id (Cfg.Node.get_exn node))
IList.iter (fun node -> Io_infer.Html.pp_node_link [".."] ""
(IList.map Cfg.Node.get_id (Cfg.Node.get_preds node))
(IList.map Cfg.Node.get_id (Cfg.Node.get_succs node))
(IList.map Cfg.Node.get_id (Cfg.Node.get_exn node))
(is_visited node) false fmt (Cfg.Node.get_id node)) succs;
F.fprintf fmt "<br>EXN: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] ""
(list_map Cfg.Node.get_id (Cfg.Node.get_preds node))
(list_map Cfg.Node.get_id (Cfg.Node.get_succs node))
(list_map Cfg.Node.get_id (Cfg.Node.get_exn node))
IList.iter (fun node -> Io_infer.Html.pp_node_link [".."] ""
(IList.map Cfg.Node.get_id (Cfg.Node.get_preds node))
(IList.map Cfg.Node.get_id (Cfg.Node.get_succs node))
(IList.map Cfg.Node.get_id (Cfg.Node.get_exn node))
(is_visited node) false fmt (Cfg.Node.get_id node)) exn;
F.fprintf fmt "<br>@\n";
F.pp_print_flush fmt ();
@ -230,7 +230,7 @@ let () = L.printer_hook := force_delayed_print
let force_delayed_prints () =
Config.forcing_delayed_prints := true;
F.fprintf !html_formatter "@?"; (* flush html stream *)
list_iter (force_delayed_print !html_formatter) (list_rev (L.get_delayed_prints ()));
IList.iter (force_delayed_print !html_formatter) (IList.rev (L.get_delayed_prints ()));
F.fprintf !html_formatter "@?";
L.reset_delayed_prints ();
Config.forcing_delayed_prints := false
@ -262,19 +262,19 @@ let finish_session node =
let _proc_write_log whole_seconds cfg pname =
match Cfg.Procdesc.find_from_name cfg pname with
| Some pdesc ->
let nodes = list_sort Cfg.Node.compare (Cfg.Procdesc.get_nodes pdesc) in
let linenum = (Cfg.Node.get_loc (list_hd nodes)).Location.line in
let nodes = IList.sort Cfg.Node.compare (Cfg.Procdesc.get_nodes pdesc) in
let linenum = (Cfg.Node.get_loc (IList.hd nodes)).Location.line in
let fd, fmt =
Io_infer.Html.create DB.Results_dir.Abs_source_dir [Procname.to_filename pname] in
F.fprintf fmt "<center><h1>Procedure %a</h1></center>@\n"
(Io_infer.Html.pp_line_link ~text: (Some (Escape.escape_xml (Procname.to_string pname))) [])
linenum;
list_iter
IList.iter
(fun n -> Io_infer.Html.pp_node_link []
(Cfg.Node.get_description (pe_html Black) n)
(list_map Cfg.Node.get_id (Cfg.Node.get_preds n))
(list_map Cfg.Node.get_id (Cfg.Node.get_succs n))
(list_map Cfg.Node.get_id (Cfg.Node.get_exn n))
(IList.map Cfg.Node.get_id (Cfg.Node.get_preds n))
(IList.map Cfg.Node.get_id (Cfg.Node.get_succs n))
(IList.map Cfg.Node.get_id (Cfg.Node.get_exn n))
(is_visited n) false fmt (Cfg.Node.get_id n))
nodes;
(match Specs.get_summary pname with
@ -345,7 +345,7 @@ end = struct
assert false (* execution never reaches here *)
with End_of_file ->
(close_in cin;
Array.of_list (list_rev !lines))
Array.of_list (IList.rev !lines))
let file_data (hash: t) fname =
try
@ -393,11 +393,11 @@ let c_file_write_html proc_is_active linereader fname tenv cfg =
Cfg.Procdesc.is_defined proc_desc &&
(DB.source_file_equal proc_loc.Location.file !DB.current_source) then
begin
list_iter process_node (Cfg.Procdesc.get_nodes proc_desc);
IList.iter process_node (Cfg.Procdesc.get_nodes proc_desc);
match Specs.get_summary proc_name with
| None -> ()
| Some summary ->
list_iter
IList.iter
(fun sp -> proof_cover := Specs.Visitedset.union sp.Specs.visited !proof_cover)
(Specs.get_specs_from_payload summary);
Errlog.update global_err_log summary.Specs.attributes.ProcAttributes.err_log
@ -427,17 +427,17 @@ let c_file_write_html proc_is_active linereader fname tenv cfg =
let str =
"<tr><td class=\"num\" id=\"" ^ line_str ^ "\">" ^ linenum_str ^ "</td><td class=\"line\">" ^ line_html in
F.fprintf fmt "%s" str;
list_iter (fun n ->
IList.iter (fun n ->
let isproof = Specs.Visitedset.mem (Cfg.Node.get_id n, []) !proof_cover in
Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum;
list_iter (fun n -> match Cfg.Node.get_kind n with
Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (IList.map Cfg.Node.get_id (Cfg.Node.get_preds n)) (IList.map Cfg.Node.get_id (Cfg.Node.get_succs n)) (IList.map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum;
IList.iter (fun n -> match Cfg.Node.get_kind n with
| Cfg.Node.Start_node proc_desc ->
let proc_name = Cfg.Procdesc.get_proc_name proc_desc in
let num_specs = list_length (Specs.get_specs proc_name) in
let num_specs = IList.length (Specs.get_specs proc_name) in
let label = (Escape.escape_xml (Procname.to_string proc_name)) ^ ": " ^ (string_of_int num_specs) ^ " specs" in
Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label
| _ -> ()) nodes_at_linenum;
list_iter (fun err_string -> F.fprintf fmt "%s" (create_err_message err_string)) errors_at_linenum;
IList.iter (fun err_string -> F.fprintf fmt "%s" (create_err_message err_string)) errors_at_linenum;
F.fprintf fmt "%s" "</td></tr>\n"
done
with End_of_file ->

10
infer/src/backend/procname.ml
Unescape View File

@ -217,7 +217,7 @@ let java_get_class_components proc_name =
(** Return the class name of a java procedure name. *)
let java_get_simple_class proc_name =
list_hd (list_rev (java_get_class_components proc_name))
IList.hd (IList.rev (java_get_class_components proc_name))
(** Return the method of a java procname. *)
let java_get_method = function
@ -248,7 +248,7 @@ let java_get_return_type = function
(** Return the parameters of a java procname. *)
let java_get_parameters = function
| JAVA j -> list_map (fun param -> java_type_to_string param VERBOSE) j.parameters
| JAVA j -> IList.map (fun param -> java_type_to_string param VERBOSE) j.parameters
| _ -> assert false
(** Return true if the java procedure is static *)
@ -305,10 +305,10 @@ let java_is_anonymous_inner_class = function
with an extra parameter and calls the normal constructor. *)
let java_remove_hidden_inner_class_parameter = function
| JAVA js ->
(match list_rev js.parameters with
(match IList.rev js.parameters with
| (so, s) :: par' ->
if is_anonymous_inner_class_name s
then Some (JAVA { js with parameters = list_rev par'})
then Some (JAVA { js with parameters = IList.rev par'})
else None
| [] -> None)
| _ -> None
@ -337,7 +337,7 @@ let java_is_access_method = function
let java_is_vararg = function
| JAVA js ->
begin
match (list_rev js.parameters) with
match (IList.rev js.parameters) with
| (_,"java.lang.Object[]") :: _ -> true
| _ -> false
end

346
infer/src/backend/prop.ml
View File

File diff suppressed because it is too large Load Diff

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

@ -69,9 +69,9 @@ let get_subl footprint_part g =
let edge_from_source g n footprint_part is_hpred =
let edges =
if is_hpred
then list_map (fun hpred -> Ehpred hpred ) (get_sigma footprint_part g)
else list_map (fun a -> Eatom a) (get_pi footprint_part g) @ list_map (fun entry -> Esub_entry entry) (get_subl footprint_part g) in
match list_filter (fun hpred -> Sil.exp_equal n (edge_get_source hpred)) edges with
then IList.map (fun hpred -> Ehpred hpred ) (get_sigma footprint_part g)
else IList.map (fun a -> Eatom a) (get_pi footprint_part g) @ IList.map (fun entry -> Esub_entry entry) (get_subl footprint_part g) in
match IList.filter (fun hpred -> Sil.exp_equal n (edge_get_source hpred)) edges with
| [] -> None
| edge:: _ -> Some edge
@ -87,7 +87,7 @@ let get_edges footprint_part g =
let hpreds = get_sigma footprint_part g in
let atoms = get_pi footprint_part g in
let subst_entries = get_subl footprint_part g in
list_map (fun hpred -> Ehpred hpred) hpreds @ list_map (fun a -> Eatom a) atoms @ list_map (fun entry -> Esub_entry entry) subst_entries
IList.map (fun hpred -> Ehpred hpred) hpreds @ IList.map (fun a -> Eatom a) atoms @ IList.map (fun entry -> Esub_entry entry) subst_entries
let edge_equal e1 e2 = match e1, e2 with
| Ehpred hp1, Ehpred hp2 -> Sil.hpred_equal hp1 hp2
@ -98,13 +98,13 @@ 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 (list_find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true
try ignore (IList.find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true
with Not_found -> false
(** [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. *)
let iter_edges footprint_part f g =
list_iter f (get_edges footprint_part g) (* For now simple iterator; later might use a specific traversal *)
IList.iter f (get_edges footprint_part g) (* For now simple iterator; later might use a specific traversal *)
(** Graph annotated with the differences w.r.t. a previous graph *)
type diff =
@ -176,9 +176,9 @@ let compute_diff default_color oldgraph newgraph : diff =
changed := changed_obj :: !changed
| Some oldedge -> changed := compute_edge_diff oldedge edge @ !changed
end in
list_iter build_changed newedges;
IList.iter build_changed newedges;
let colormap (o: Obj.t) =
if list_exists (fun x -> x == o) !changed then Red
if IList.exists (fun x -> x == o) !changed then Red
else default_color in
!changed, colormap in
let changed_norm, colormap_norm = compute_changed false in
@ -198,7 +198,7 @@ let diff_get_colormap footprint_part diff =
If !Config.pring_using_diff is true, print the diff w.r.t. the given prop,
extracting its local stack vars if the boolean is true. *)
let pp_proplist pe0 s (base_prop, extract_stack) f plist =
let num = list_length plist in
let num = IList.length plist in
let base_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma base_prop)) in
let add_base_stack prop =
if extract_stack then Prop.replace_sigma (base_stack @ Prop.get_sigma prop) prop

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

@ -30,7 +30,7 @@ type t = PropSet.t
let add p pset =
let ps = Prop.prop_expand p in
list_fold_left (fun pset' p' -> PropSet.add (Prop.prop_rename_primed_footprint_vars p') pset') pset ps
IList.fold_left (fun pset' p' -> PropSet.add (Prop.prop_rename_primed_footprint_vars p') pset') pset ps
(** Singleton set. *)
let singleton p =
@ -61,27 +61,27 @@ let size = PropSet.cardinal
let filter = PropSet.filter
let from_proplist plist =
list_fold_left (fun pset p -> add p pset) empty plist
IList.fold_left (fun pset p -> add p pset) empty plist
let to_proplist pset =
PropSet.elements pset
(** Apply function to all the elements of [propset], removing those where it returns [None]. *)
let map_option f pset =
let plisto = list_map f (to_proplist pset) in
let plisto = list_filter (function | Some _ -> true | None -> false) plisto in
let plist = list_map (function Some p -> p | None -> assert false) plisto in
let plisto = IList.map f (to_proplist pset) in
let plisto = IList.filter (function | Some _ -> true | None -> false) plisto in
let plist = IList.map (function Some p -> p | None -> assert false) plisto in
from_proplist plist
(** Apply function to all the elements of [propset]. *)
let map f pset =
from_proplist (list_map f (to_proplist pset))
from_proplist (IList.map f (to_proplist pset))
(** [fold f pset a] computes [f (... (f (f a p1) p2) ...) pn]
where [p1 ... pN] are the elements of pset, in increasing order. *)
let fold f a pset =
let l = to_proplist pset in
list_fold_left f a l
IList.fold_left f a l
(** [iter f pset] computes (f p1;f p2;..;f pN)
where [p1 ... pN] are the elements of pset, in increasing order. *)

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

@ -19,10 +19,10 @@ let decrease_indent_when_exception thunk =
with exn when exn_not_timeout exn -> (L.d_decrease_indent 1; raise exn)
let compute_max_from_nonempty_int_list l =
list_hd (list_rev (list_sort Sil.Int.compare_value l))
IList.hd (IList.rev (IList.sort Sil.Int.compare_value l))
let compute_min_from_nonempty_int_list l =
list_hd (list_sort Sil.Int.compare_value l)
IList.hd (IList.sort Sil.Int.compare_value l)
let exp_pair_compare (e1, e2) (f1, f2) =
let c1 = Sil.exp_compare e1 f1 in
@ -33,8 +33,8 @@ let rec list_rev_acc acc = function
| x:: l -> list_rev_acc (x:: acc) l
let rec remove_redundancy have_same_key acc = function
| [] -> list_rev acc
| [x] -> list_rev (x:: acc)
| [] -> IList.rev acc
| [x] -> IList.rev (x:: acc)
| x:: ((y:: l') as l) ->
if have_same_key x y then remove_redundancy have_same_key acc (x:: l')
else remove_redundancy have_same_key (x:: acc) l
@ -110,18 +110,18 @@ end = struct
generate constr acc rest
let sort_then_remove_redundancy constraints =
let constraints_sorted = list_sort compare constraints in
let constraints_sorted = IList.sort compare constraints in
let have_same_key (e1, e2, _) (f1, f2, _) = exp_pair_compare (e1, e2) (f1, f2) = 0 in
remove_redundancy have_same_key [] constraints_sorted
let remove_redundancy constraints =
let constraints' = sort_then_remove_redundancy constraints in
list_filter (fun entry -> list_exists (equal entry) constraints') constraints
IList.filter (fun entry -> IList.exists (equal entry) constraints') constraints
let rec combine acc_todos acc_seen constraints_new constraints_old =
match constraints_new, constraints_old with
| [], [] -> list_rev acc_todos, list_rev acc_seen
| [], _ -> list_rev acc_todos, list_rev_acc constraints_old acc_seen
| [], [] -> IList.rev acc_todos, IList.rev acc_seen
| [], _ -> IList.rev acc_todos, list_rev_acc constraints_old acc_seen
| _, [] -> list_rev_acc constraints_new acc_todos, list_rev_acc constraints_new acc_seen
| constr:: rest, constr':: rest' ->
let e1, e2, n = constr in
@ -253,7 +253,7 @@ end = struct
if c2 <> 0 then c2 else - (Sil.exp_compare e1 f1)
let leqs_sort_then_remove_redundancy leqs =
let leqs_sorted = list_sort leq_compare leqs in
let leqs_sorted = IList.sort leq_compare leqs in
let have_same_key leq1 leq2 =
match leq1, leq2 with
| (e1, Sil.Const (Sil.Cint n1)), (e2, Sil.Const (Sil.Cint n2)) ->
@ -261,7 +261,7 @@ end = struct
| _, _ -> false in
remove_redundancy have_same_key [] leqs_sorted
let lts_sort_then_remove_redundancy lts =
let lts_sorted = list_sort lt_compare lts in
let lts_sorted = IList.sort lt_compare lts in
let have_same_key lt1 lt2 =
match lt1, lt2 with
| (Sil.Const (Sil.Cint n1), e1), (Sil.Const (Sil.Cint n2), e2) ->
@ -271,9 +271,9 @@ end = struct
let saturate { leqs = leqs; lts = lts; neqs = neqs } =
let diff_constraints1 =
list_fold_left
IList.fold_left
DiffConstr.from_lt
(list_fold_left DiffConstr.from_leq [] leqs)
(IList.fold_left DiffConstr.from_leq [] leqs)
lts in
let inconsistent, diff_constraints2 = DiffConstr.saturate diff_constraints1 in
if inconsistent then inconsistent_ineq
@ -328,7 +328,7 @@ end = struct
let leqs' = Sil.ExpMap.fold
(fun e upper acc_leqs -> (e, Sil.exp_int upper):: acc_leqs)
umap' [] in
let leqs'' = (list_map DiffConstr.to_leq diff_constraints2) @ leqs' in
let leqs'' = (IList.map DiffConstr.to_leq diff_constraints2) @ leqs' in
leqs_sort_then_remove_redundancy leqs'' in
let lts_res =
let lmap = lmap_create_from_lts Sil.ExpMap.empty lts in
@ -336,7 +336,7 @@ end = struct
let lts' = Sil.ExpMap.fold
(fun e lower acc_lts -> (Sil.exp_int lower, e):: acc_lts)
lmap' [] in
let lts'' = (list_map DiffConstr.to_lt diff_constraints2) @ lts' in
let lts'' = (IList.map DiffConstr.to_lt diff_constraints2) @ lts' in
lts_sort_then_remove_redundancy lts'' in
{ leqs = leqs_res; lts = lts_res; neqs = neqs }
end
@ -354,7 +354,7 @@ end = struct
| Sil.Aeq (Sil.BinOp (Sil.Lt, e1, e2), Sil.Const (Sil.Cint i)) when Sil.Int.isone i -> (* < *)
lts := (e1, e2) :: !lts
| Sil.Aeq _ -> () in
list_iter process_atom pi;
IList.iter process_atom pi;
saturate { leqs = !leqs; lts = !lts; neqs = !neqs }
let from_sigma sigma =
@ -371,10 +371,10 @@ end = struct
let rec strexp_extract = function
| Sil.Eexp _ -> ()
| Sil.Estruct (fsel, _) ->
list_iter (fun (_, se) -> strexp_extract se) fsel
IList.iter (fun (_, se) -> strexp_extract se) fsel
| Sil.Earray (size, isel, _) ->
add_lt_minus1_e size;
list_iter (fun (idx, se) ->
IList.iter (fun (idx, se) ->
add_lt_minus1_e idx;
strexp_extract se) isel in
let hpred_extract = function
@ -382,7 +382,7 @@ end = struct
if texp_is_unsigned texp then strexp_lt_minus1 se;
strexp_extract se
| Sil.Hlseg _ | Sil.Hdllseg _ -> () in
list_iter hpred_extract sigma;
IList.iter hpred_extract sigma;
saturate { leqs = !leqs; lts = !lts; neqs = [] }
let join ineq1 ineq2 =
@ -411,11 +411,11 @@ end = struct
when Sil.Int.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *)
check_type_size_lt t1 t2
| e, Sil.Const (Sil.Cint n) -> (* [e <= n' <= n |- e <= n] *)
list_exists (function
IList.exists (function
| e', Sil.Const (Sil.Cint n') -> Sil.exp_equal e e' && Sil.Int.leq n' n
| _, _ -> false) leqs
| Sil.Const (Sil.Cint n), e -> (* [ n-1 <= n' < e |- n <= e] *)
list_exists (function
IList.exists (function
| Sil.Const (Sil.Cint n'), e' -> Sil.exp_equal e e' && Sil.Int.leq (n -- Sil.Int.one) n'
| _, _ -> false) lts
| _ -> Sil.exp_equal e1 e2
@ -426,11 +426,11 @@ end = struct
match e1, e2 with
| Sil.Const (Sil.Cint n1), Sil.Const (Sil.Cint n2) -> Sil.Int.lt n1 n2
| Sil.Const (Sil.Cint n), e -> (* [n <= n' < e |- n < e] *)
list_exists (function
IList.exists (function
| Sil.Const (Sil.Cint n'), e' -> Sil.exp_equal e e' && Sil.Int.leq n n'
| _, _ -> false) lts
| e, Sil.Const (Sil.Cint n) -> (* [e <= n' <= n-1 |- e < n] *)
list_exists (function
IList.exists (function
| e', Sil.Const (Sil.Cint n') -> Sil.exp_equal e e' && Sil.Int.leq n' (n -- Sil.Int.one)
| _, _ -> false) leqs
| _ -> false
@ -438,7 +438,7 @@ end = struct
(** Check [prop |- e1!=e2]. Result [false] means "don't know". *)
let check_ne ineq _e1 _e2 =
let e1, e2 = if Sil.exp_compare _e1 _e2 <= 0 then _e1, _e2 else _e2, _e1 in
list_exists (exp_pair_eq (e1, e2)) ineq.neqs || check_lt ineq e1 e2 || check_lt ineq e2 e1
IList.exists (exp_pair_eq (e1, e2)) ineq.neqs || check_lt ineq e1 e2 || check_lt ineq e2 e1
(** Find a Sil.Int.t n such that [t |- e<=n] if possible. *)
let compute_upper_bound { leqs = leqs; lts = _; neqs = _ } e1 =
@ -446,11 +446,11 @@ end = struct
| Sil.Const (Sil.Cint n1) -> Some n1
| _ ->
let e_upper_list =
list_filter (function
IList.filter (function
| e', Sil.Const (Sil.Cint _) -> Sil.exp_equal e1 e'
| _, _ -> false) leqs in
let upper_list =
list_map (function
IList.map (function
| _, Sil.Const (Sil.Cint n) -> n
| _ -> assert false) e_upper_list in
if upper_list == [] then None
@ -463,11 +463,11 @@ end = struct
| Sil.Sizeof _ -> Some Sil.Int.zero
| _ ->
let e_lower_list =
list_filter (function
IList.filter (function
| Sil.Const (Sil.Cint _), e' -> Sil.exp_equal e1 e'
| _, _ -> false) lts in
let lower_list =
list_map (function
IList.map (function
| Sil.Const (Sil.Cint n), _ -> n
| _ -> assert false) e_lower_list in
if lower_list == [] then None
@ -479,9 +479,9 @@ end = struct
check_le ineq e1 e2 && check_le ineq e2 e1 in
let inconsistent_leq (e1, e2) = check_lt ineq e2 e1 in
let inconsistent_lt (e1, e2) = check_le ineq e2 e1 in
list_exists inconsistent_neq neqs ||
list_exists inconsistent_leq leqs ||
list_exists inconsistent_lt lts
IList.exists inconsistent_neq neqs ||
IList.exists inconsistent_leq leqs ||
IList.exists inconsistent_lt lts
(** Pretty print inequalities and disequalities *)
let pp pe fmt { leqs = leqs; lts = lts; neqs = neqs } =
@ -491,15 +491,15 @@ end = struct
Format.fprintf fmt "%a %a %a" (pp_seq pp_leq) leqs (pp_seq pp_lt) lts (pp_seq pp_neq) neqs
let d_leqs { leqs = leqs; lts = lts; neqs = neqs } =
let elist = list_map (fun (e1, e2) -> Sil.BinOp(Sil.Le, e1, e2)) leqs in
let elist = IList.map (fun (e1, e2) -> Sil.BinOp(Sil.Le, e1, e2)) leqs in
Sil.d_exp_list elist
let d_lts { leqs = leqs; lts = lts; neqs = neqs } =
let elist = list_map (fun (e1, e2) -> Sil.BinOp(Sil.Lt, e1, e2)) lts in
let elist = IList.map (fun (e1, e2) -> Sil.BinOp(Sil.Lt, e1, e2)) lts in
Sil.d_exp_list elist
let d_neqs { leqs = leqs; lts = lts; neqs = neqs } =
let elist = list_map (fun (e1, e2) -> Sil.BinOp(Sil.Ne, e1, e2)) lts in
let elist = IList.map (fun (e1, e2) -> Sil.BinOp(Sil.Ne, e1, e2)) lts in
Sil.d_exp_list elist
end
(* End of module Inequalities *)
@ -525,7 +525,7 @@ let check_equal prop e1 e2 =
let eq = Sil.Aeq(n_e1, n_e2) in
let n_eq = Prop.atom_normalize_prop prop eq in
let pi = Prop.get_pi prop in
list_exists (Sil.atom_equal n_eq) pi in
IList.exists (Sil.atom_equal n_eq) pi in
check_equal () || check_equal_const () || check_equal_pi ()
(** Check [ |- e=0]. Result [false] means "don't know". *)
@ -603,7 +603,7 @@ let check_disequal prop e1 e2 =
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
| Some _ ->
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant'))
| Sil.Hlseg (k, _, e1, e2, _) as hpred :: sigma_rest ->
(match is_root prop e1 e with
@ -612,20 +612,20 @@ let check_disequal prop e1 e2 =
in f sigma_irrelevant' e sigma_rest
| Some _ ->
if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else if (Sil.exp_equal e2 Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest')
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, oB, oF, iB, _) :: sigma_rest ->
if is_root prop iF e != None || is_root prop iB e != None then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) as hpred :: sigma_rest ->
(match is_root prop iF e with
@ -634,18 +634,18 @@ let check_disequal prop e1 e2 =
in f sigma_irrelevant' e sigma_rest
| Some _ ->
if (check_pi_implies_disequal iF oF) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else if (Sil.exp_equal oF Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest
in f [] oF sigma_rest') in
let f_null_check sigma_irrelevant e sigma_rest =
if not (Sil.exp_equal e Sil.exp_zero) then f sigma_irrelevant e sigma_rest
else
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
in match f_null_check [] n_e1 spatial_part with
| None -> false
@ -748,7 +748,7 @@ let check_allocatedness prop e =
if k == Sil.Lseg_NE || check_disequal prop iF oF || check_disequal prop iB oB then
is_root prop iF n_e != None || is_root prop iB n_e != None
else false
in list_exists f spatial_part
in IList.exists f spatial_part
(** Compute an upper bound of an expression *)
let compute_upper_bound_of_exp p e =
@ -823,7 +823,7 @@ let check_inconsistency_base prop =
Sil.exp_equal e Sil.exp_zero &&
Sil.pvar_is_seed pv
| _ -> false in
list_exists do_hpred sigma in
IList.exists do_hpred sigma in
let inconsistent_self () = (* "self" cannot be null in ObjC *)
let procdesc = Cfg.Node.get_proc_desc (State.get_node ()) in
let procedure_attr = Cfg.Procdesc.get_attributes procdesc in
@ -835,7 +835,7 @@ let check_inconsistency_base prop =
Sil.pvar_get_name pv = Mangled.from_string "self" &&
procedure_attr.ProcAttributes.is_objc_instance_method
| _ -> false in
list_exists do_hpred sigma in
IList.exists do_hpred sigma in
let inconsistent_atom = function
| Sil.Aeq (e1, e2) ->
(match e1, e2 with
@ -857,7 +857,7 @@ let check_inconsistency_base prop =
Inequalities.inconsistent ineq in
inconsistent_ptsto ()
|| check_inconsistency_two_hpreds prop
|| list_exists inconsistent_atom pi
|| IList.exists inconsistent_atom pi
|| inconsistent_inequalities ()
|| inconsistent_this ()
|| inconsistent_self ()
@ -895,7 +895,7 @@ type check =
let d_typings typings =
let d_elem (exp, texp) =
Sil.d_exp exp; L.d_str ": "; Sil.d_texp_full texp; L.d_str " " in
list_iter d_elem typings
IList.iter d_elem typings
(** Module to encapsulate operations on the internal state of the prover *)
module ProverState : sig
@ -950,7 +950,7 @@ end = struct
| Sil.Hpointsto (_, Sil.Earray (Sil.Var _ as size, _, _), _) ->
Sil.exp_fav_add fav size
| _ -> () in
list_iter do_hpred (Prop.get_sigma prop);
IList.iter do_hpred (Prop.get_sigma prop);
fav
let reset lhs rhs =
@ -1246,7 +1246,7 @@ let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subs
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x))
end
| Sil.Earray (size1, esel1, inst1), Sil.Earray (size2, esel2, _) ->
let indices2 = list_map fst esel2 in
let indices2 = IList.map fst esel2 in
let subs' = array_size_imply calc_missing subs size1 size2 indices2 in
if Sil.strexp_equal se1 se2 then subs', None, None
else begin
@ -1259,7 +1259,7 @@ let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subs
d_impl_err ("WARNING: function call with parameters of struct type, treating as unknown", subs, (EXC_FALSE_SEXPS (se1, se2)));
let fsel' =
let g (f, se) = (f, Sil.Eexp (Sil.Var (Ident.create_fresh Ident.knormal), inst)) in
list_map g fsel in
IList.map g fsel in
sexp_imply source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 typ2
| Sil.Eexp _, Sil.Earray (size, esel, inst)
| Sil.Estruct _, Sil.Earray (size, esel, inst) ->
@ -1404,7 +1404,7 @@ let move_primed_lhs_from_front subs sigma = match sigma with
| [] -> sigma
| hpred:: sigma' ->
if hpred_has_primed_lhs (snd subs) hpred then
let (sigma_primed, sigma_unprimed) = list_partition (hpred_has_primed_lhs (snd subs)) sigma
let (sigma_primed, sigma_unprimed) = IList.partition (hpred_has_primed_lhs (snd subs)) sigma
in match sigma_unprimed with
| [] -> raise (IMPL_EXC ("every hpred has primed lhs, cannot proceed", subs, (EXC_FALSE_SIGMA sigma)))
| _:: _ -> sigma_unprimed @ sigma_primed
@ -1436,7 +1436,7 @@ let expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred =
| Sil.Hpointsto (Sil.BinOp (Sil.PlusPI, e1, e2), Sil.Earray (size, esel, inst), t) ->
let shift_exp e = Sil.BinOp (Sil.PlusA, e, e2) in
let size' = shift_exp size in
let esel' = list_map (fun (e, se) -> (shift_exp e, se)) esel in
let esel' = IList.map (fun (e, se) -> (shift_exp e, se)) esel in
let hpred' = Sil.Hpointsto (e1, Sil.Earray (size', esel', inst), t) in
expand true calc_index_frame hpred'
| _ -> changed, calc_index_frame, hpred in
@ -1451,7 +1451,7 @@ let cloneable_type = Mangled.from_string "java.lang.Cloneable"
let is_interface tenv c =
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, c)) with
| Some (Sil.Tstruct (fields, sfields, Sil.Class, Some c1', supers1, methods, iann)) ->
(list_length fields = 0) && (list_length methods = 0)
(IList.length fields = 0) && (IList.length methods = 0)
| _ -> false
(** check if c1 is a subclass of c2 *)
@ -1460,7 +1460,7 @@ let check_subclass_tenv tenv c1 c2 =
Mangled.equal c c2 || (Mangled.equal c2 object_type) ||
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, c)) with
| Some (Sil.Tstruct (_, _, Sil.Class, Some c1', supers1, _, _)) ->
list_exists check supers1
IList.exists check supers1
| _ -> false in
(check (Sil.Class, c1))
@ -1601,7 +1601,7 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2
let filter = function
| Sil.Hpointsto(e', _, _) -> Sil.exp_equal e' e
| _ -> false in
list_exists filter (Prop.get_sigma prop1) in
IList.exists filter (Prop.get_sigma prop1) in
let type_rhs e =
let sub_opt = ref None in
let filter = function
@ -1609,7 +1609,7 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2
sub_opt := Some (t, sub);
true
| _ -> false in
if list_exists filter sigma2 then !sub_opt else None in
if IList.exists filter sigma2 then !sub_opt else None in
let add_subtype () = match texp1, texp2, se1, se2 with
| Sil.Sizeof(Sil.Tptr (_t1, _), _), Sil.Sizeof(Sil.Tptr (_t2, _), sub2), Sil.Eexp(e1', _), Sil.Eexp(e2', _) when not (is_allocated_lhs e1') ->
begin
@ -1735,7 +1735,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let elist2 = IList.map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in
L.d_increase_indent 1;
let res =
@ -1745,7 +1745,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
L.d_decrease_indent 1;
res
| Some iter1' ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let elist2 = IList.map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in
let hpred1 = match Prop.prop_iter_current iter1' with
@ -1799,7 +1799,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let elist2 = IList.map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let _, para_inst2 =
if Sil.exp_equal iF2 iB2 then
Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2
@ -1812,7 +1812,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
L.d_decrease_indent 1;
res
| Some iter1' -> (** Only consider implications between identical listsegs for now *)
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let elist2 = IList.map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let subs' = exp_list_imply calc_missing subs (iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1')
@ -1846,7 +1846,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
let se = Sil.Eexp (Sil.Var (Ident.create_fresh Ident.kprimed), Sil.Inone) in
(fld, se) in
let fields = ["java.lang.String.count"; "java.lang.String.hash"; "java.lang.String.offset"; "java.lang.String.value"] in
Sil.Estruct (list_map mk_fld_sexp fields, Sil.inst_none) in
Sil.Estruct (IList.map mk_fld_sexp fields, Sil.inst_none) in
let const_string_texp =
match !Config.curr_language with
| Config.C_CPP -> Sil.Sizeof (Sil.Tarray (Sil.Tint Sil.IChar, size), Sil.Subtype.exact)
@ -1941,7 +1941,7 @@ let imply_pi calc_missing (sub1, sub2) prop pi2 =
| IMPL_EXC _ when calc_missing ->
L.d_str "imply_pi: adding missing atom "; Sil.d_atom a; L.d_ln ();
ProverState.add_missing_pi a in
list_iter do_atom pi2
IList.iter do_atom pi2
let imply_atom calc_missing (sub1, sub2) prop a =
imply_pi calc_missing (sub1, sub2) prop [a]
@ -2001,12 +2001,12 @@ let check_array_bounds (sub1, sub2) prop =
(* L.d_strln_color Orange "check_bound "; Sil.d_exp size1; L.d_str " "; Sil.d_exp size2; L.d_ln(); *)
let indices_to_check = match size2 with
| _ -> [Sil.BinOp(Sil.PlusA, size2, Sil.exp_minus_one)] (* only check size *) in
list_iter (fail_if_le size1) indices_to_check
IList.iter (fail_if_le size1) indices_to_check
| ProverState.BCfrom_pre _atom ->
let atom_neg = Prop.atom_negate (Sil.atom_sub sub2 _atom) in
(* L.d_strln_color Orange "BCFrom_pre"; Sil.d_atom atom_neg; L.d_ln (); *)
if check_atom prop atom_neg then check_failed atom_neg in
list_iter check_bound (ProverState.get_bounds_checks ())
IList.iter check_bound (ProverState.get_bounds_checks ())
(** [check_implication_base] returns true if [prop1|-prop2],
ignoring the footprint part of the props *)
@ -2021,8 +2021,8 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2
let sigma1, sigma2 = Prop.get_sigma prop1, Prop.get_sigma prop2 in
let subs = pre_check_pure_implication calc_missing (Prop.get_sub prop1, sub1_base) pi1 pi2 in
let pi2_bcheck, pi2_nobcheck = (* find bounds checks implicit in pi2 *)
list_partition ProverState.atom_is_array_bounds_check pi2 in
list_iter (fun a -> ProverState.add_bounds_check (ProverState.BCfrom_pre a)) pi2_bcheck;
IList.partition ProverState.atom_is_array_bounds_check pi2 in
IList.iter (fun a -> ProverState.add_bounds_check (ProverState.BCfrom_pre a)) pi2_bcheck;
L.d_strln "pre_check_pure_implication";
L.d_strln "pi1:";
L.d_increase_indent 1; Prop.d_pi pi1; L.d_decrease_indent 1; L.d_ln ();
@ -2099,7 +2099,7 @@ let is_cover cases =
match cases with
| [] -> check_inconsistency_pi acc_pi
| (pi, _):: cases' ->
list_for_all (fun a -> _is_cover ((Prop.atom_negate a) :: acc_pi) cases') pi in
IList.for_all (fun a -> _is_cover ((Prop.atom_negate a) :: acc_pi) cases') pi in
_is_cover [] cases
exception NO_COVER
@ -2107,8 +2107,8 @@ exception NO_COVER
(** Find miminum set of pi's in [cases] whose disjunction covers true *)
let find_minimum_pure_cover cases =
let cases =
let compare (pi1, _) (pi2, _) = int_compare (list_length pi1) (list_length pi2)
in list_sort compare cases in
let compare (pi1, _) (pi2, _) = int_compare (IList.length pi1) (IList.length pi2)
in IList.sort compare cases in
let rec grow seen todo = match todo with
| [] -> raise NO_COVER
| (pi, x):: todo' ->
@ -2120,7 +2120,7 @@ let find_minimum_pure_cover cases =
if is_cover (seen @ todo') then _shrink seen todo'
else _shrink ((pi, x):: seen) todo' in
let shrink cases =
if list_length cases > 2 then _shrink [] cases
if IList.length cases > 2 then _shrink [] cases
else cases
in try Some (shrink (grow [] cases))
with NO_COVER -> None

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

@ -17,10 +17,10 @@ open Utils
let (++) = Sil.Int.add
let list_product l1 l2 =
let l1' = list_rev l1 in
let l2' = list_rev l2 in
list_fold_left
(fun acc x -> list_fold_left (fun acc' y -> (x, y):: acc') acc l2')
let l1' = IList.rev l1 in
let l2' = IList.rev l2 in
IList.fold_left
(fun acc x -> IList.fold_left (fun acc' y -> (x, y):: acc') acc l2')
[] l1'
let rec list_rev_and_concat l1 l2 =
@ -29,7 +29,7 @@ let rec list_rev_and_concat l1 l2 =
| x1:: l1' -> list_rev_and_concat l1' (x1:: l2)
let pp_off fmt off =
list_iter (fun n -> match n with
IList.iter (fun n -> match n with
| Sil.Off_fld (f, t) -> F.fprintf fmt "%a " Ident.pp_fieldname f
| Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off
@ -106,14 +106,14 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
([], Sil.Estruct ([], inst), t)
| Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann), (Sil.Off_fld (f, _)):: off' ->
let _, t', _ =
try list_find (fun (f', _, _) -> Ident.fieldname_equal f f') ftal
try IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') ftal
with Not_found -> raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
let atoms', se', res_t' =
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp t' off' inst in
let se = Sil.Estruct ([(f, se')], inst) in
let replace_typ_of_f (f', t', a') = if Ident.fieldname_equal f f' then (f, res_t', a') else (f', t', a') in
let ftal' = list_sort Sil.fld_typ_ann_compare (list_map replace_typ_of_f ftal) in
let ftal' = IList.sort Sil.fld_typ_ann_compare (IList.map replace_typ_of_f ftal) in
(atoms', se, Sil.Tstruct (ftal', sftal, csu, nameo, supers, def_mthds, iann))
| Sil.Tstruct _, (Sil.Off_index e):: off' ->
let atoms', se', res_t' =
@ -199,28 +199,28 @@ let rec _strexp_extend_values
| (Sil.Off_fld (f, _)):: off', Sil.Estruct (fsel, inst'), Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) ->
let replace_fv new_v fv = if Ident.fieldname_equal (fst fv) f then (f, new_v) else fv in
let typ' =
try (fun (x, y, z) -> y) (list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal)
try (fun (x, y, z) -> y) (IList.find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal)
with Not_found -> raise (Exceptions.Missing_fld (f, try assert false with Assert_failure x -> x)) in
begin
try
let _, se' = list_find (fun (f', _) -> Ident.fieldname_equal f f') fsel in
let _, se' = IList.find (fun (f', _) -> Ident.fieldname_equal f f') fsel in
let atoms_se_typ_list' =
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se' typ' off' inst in
let replace acc (res_atoms', res_se', res_typ') =
let replace_fse = replace_fv res_se' in
let res_fsel' = list_sort Sil.fld_strexp_compare (list_map replace_fse fsel) in
let res_fsel' = IList.sort Sil.fld_strexp_compare (IList.map replace_fse fsel) in
let replace_fta (f, t, a) = let f', t' = replace_fv res_typ' (f, t) in (f', t', a) in
let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in
let res_ftl' = IList.sort Sil.fld_typ_ann_compare (IList.map replace_fta ftal) in
(res_atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann)) :: acc in
list_fold_left replace [] atoms_se_typ_list'
IList.fold_left replace [] atoms_se_typ_list'
with Not_found ->
let atoms', se', res_typ' =
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in
let res_fsel' = list_sort Sil.fld_strexp_compare ((f, se'):: fsel) in
let res_fsel' = IList.sort Sil.fld_strexp_compare ((f, se'):: fsel) in
let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in
let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in
let res_ftl' = IList.sort Sil.fld_typ_ann_compare (IList.map replace_fta ftal) in
[(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))]
end
| (Sil.Off_fld (f, _)):: off', _, _ ->
@ -247,17 +247,17 @@ let rec _strexp_extend_values
bounds_check pname tenv orig_prop size e (State.get_loc ());
begin
try
let _, se' = list_find (fun (e', _) -> Sil.exp_equal e e') esel in
let _, se' = IList.find (fun (e', _) -> Sil.exp_equal e e') esel in
let atoms_se_typ_list' =
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se' typ' off' inst in
let replace acc (res_atoms', res_se', res_typ') =
let replace_ise ise = if Sil.exp_equal e (fst ise) then (e, res_se') else ise in
let res_esel' = list_map replace_ise esel in
if (Sil.typ_equal res_typ' typ') || (list_length res_esel' = 1)
let res_esel' = IList.map replace_ise esel in
if (Sil.typ_equal res_typ' typ') || (IList.length res_esel' = 1)
then (res_atoms', Sil.Earray(size, res_esel', inst_arr), Sil.Tarray(res_typ', size_for_typ')) :: acc
else raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
list_fold_left replace [] atoms_se_typ_list'
IList.fold_left replace [] atoms_se_typ_list'
with Not_found ->
array_case_analysis_index pname tenv orig_prop
footprint_part kind max_stamp
@ -278,10 +278,10 @@ and array_case_analysis_index pname tenv orig_prop
if not (Sil.typ_equal typ_cont t' || array_cont == [])
then raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
let index_in_array =
list_exists (fun (i, _) -> Prover.check_equal Prop.prop_emp index i) array_cont in
IList.exists (fun (i, _) -> Prover.check_equal Prop.prop_emp index i) array_cont in
let array_is_full =
match array_size with
| Sil.Const (Sil.Cint n') -> Sil.Int.geq (Sil.Int.of_int (list_length array_cont)) n'
| Sil.Const (Sil.Cint n') -> Sil.Int.geq (Sil.Int.of_int (IList.length array_cont)) n'
| _ -> false in
if index_in_array then
@ -293,7 +293,7 @@ and array_case_analysis_index pname tenv orig_prop
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp typ_cont off inst in
check_sound elem_typ;
let cont_new = list_sort Sil.exp_strexp_compare ((index, elem_se):: array_cont) in
let cont_new = IList.sort Sil.exp_strexp_compare ((index, elem_se):: array_cont) in
let array_new = Sil.Earray(array_size, cont_new, inst_arr) in
let typ_new = Sil.Tarray(elem_typ, typ_array_size) in
[(atoms, array_new, typ_new)]
@ -306,19 +306,19 @@ and array_case_analysis_index pname tenv orig_prop
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp typ_cont off inst in
check_sound elem_typ;
let cont_new = list_sort Sil.exp_strexp_compare ((index, elem_se):: array_cont) in
let cont_new = IList.sort Sil.exp_strexp_compare ((index, elem_se):: array_cont) in
let array_new = Sil.Earray(array_size, cont_new, inst_arr) in
let typ_new = Sil.Tarray(elem_typ, typ_array_size) in
[(atoms, array_new, typ_new)]
end in
let rec handle_case acc isel_seen_rev = function
| [] -> list_flatten (list_rev (res_new:: acc))
| [] -> IList.flatten (IList.rev (res_new:: acc))
| (i, se) as ise :: isel_unseen ->
let atoms_se_typ_list =
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se typ_cont off inst in
let atoms_se_typ_list' =
list_fold_left (fun acc' (atoms', se', typ') ->
IList.fold_left (fun acc' (atoms', se', typ') ->
check_sound typ';
let atoms_new = Sil.Aeq(index, i) :: atoms' in
let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in
@ -341,7 +341,7 @@ let laundry_offset_for_footprint max_stamp offs_in =
let rec laundry offs_seen eqs offs =
match offs with
| [] ->
(list_rev offs_seen, list_rev eqs)
(IList.rev offs_seen, IList.rev eqs)
| (Sil.Off_fld _ as off):: offs' ->
let offs_seen' = off:: offs_seen in
laundry offs_seen' eqs offs'
@ -367,7 +367,7 @@ let strexp_extend_values
let off', eqs = laundry_offset_for_footprint max_stamp off in
(* do laundry_offset whether footprint_part is true or not, so max_stamp is modified anyway *)
if footprint_part then
off', list_map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs
off', IList.map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs
else off, [] in
if !Config.trace_rearrange then (L.d_str "entering strexp_extend_values se: "; Sil.d_sexp se; L.d_str " typ: ";
Sil.d_typ_full typ; L.d_str " off': "; Sil.d_offset_list off'; L.d_strln (if footprint_part then " FP" else " RE"));
@ -377,13 +377,13 @@ let strexp_extend_values
let atoms_se_typ_list_filtered =
let neg_atom = function Sil.Aeq(e1, e2) -> Sil.Aneq(e1, e2) | Sil.Aneq(e1, e2) -> Sil.Aeq(e1, e2) in
let check_neg_atom atom = Prover.check_atom Prop.prop_emp (neg_atom atom) in
let check_not_inconsistent (atoms, _, _) = not (list_exists check_neg_atom atoms) in
list_filter check_not_inconsistent atoms_se_typ_list in
let check_not_inconsistent (atoms, _, _) = not (IList.exists check_neg_atom atoms) in
IList.filter check_not_inconsistent atoms_se_typ_list in
if !Config.trace_rearrange then L.d_strln "exiting strexp_extend_values";
let st = match te with
| Sil.Sizeof(_, st) -> st
| _ -> Sil.Subtype.exact in
list_map (fun (atoms', se', typ') -> (laundry_atoms @ atoms', se', Sil.Sizeof (typ', st))) atoms_se_typ_list_filtered
IList.map (fun (atoms', se', typ') -> (laundry_atoms @ atoms', se', Sil.Sizeof (typ', st))) atoms_se_typ_list_filtered
let collect_root_offset exp =
let root = Sil.root_of_lexp exp in
@ -432,7 +432,7 @@ let mk_ptsto_exp_footprint
let atoms, ptsto_foot = create_ptsto true off_foot in
let sub = Sil.sub_of_list eqs in
let ptsto = Sil.hpred_sub sub ptsto_foot in
let atoms' = list_map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs in
let atoms' = IList.map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs in
(ptsto, ptsto_foot, atoms @ atoms')
(** Check if the path in exp exists already in the current ptsto predicate.
@ -449,7 +449,7 @@ let prop_iter_check_fields_ptsto_shallow iter lexp =
(match se with
| Sil.Estruct (fsel, _) ->
(try
let _, se' = list_find (fun (fld', _) -> Sil.fld_equal fld fld') fsel in
let _, se' = IList.find (fun (fld', _) -> Sil.fld_equal fld fld') fsel in
check_offset se' off'
with Not_found -> Some fld)
| _ -> Some fld)
@ -459,7 +459,7 @@ let prop_iter_check_fields_ptsto_shallow iter lexp =
let fav_max_stamp fav =
let max_stamp = ref 0 in
let f id = max_stamp := max !max_stamp (Ident.get_stamp id) in
list_iter f (Sil.fav_to_list fav);
IList.iter f (Sil.fav_to_list fav);
max_stamp
(** [prop_iter_extend_ptsto iter lexp] extends the current psto
@ -476,7 +476,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let atoms_se_te_list =
strexp_extend_values
pname tenv orig_prop true Ident.kfootprint (ref max_stamp_val) se te offset inst in
list_map (fun (atoms', se', te') -> (atoms', Sil.Hpointsto (e, se', te'))) atoms_se_te_list
IList.map (fun (atoms', se', te') -> (atoms', Sil.Hpointsto (e, se', te'))) atoms_se_te_list
| Sil.Hlseg (k, hpara, e1, e2, el) ->
begin
match hpara.Sil.body with
@ -486,15 +486,15 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
pname tenv orig_prop true Ident.kfootprint
(ref max_stamp_val) se' te' offset inst in
let atoms_body_list =
list_map (fun (atoms0, se0, te0) -> (atoms0, Sil.Hpointsto(e', se0, te0):: body_rest)) atoms_se_te_list in
IList.map (fun (atoms0, se0, te0) -> (atoms0, Sil.Hpointsto(e', se0, te0):: body_rest)) atoms_se_te_list in
let atoms_hpara_list =
list_map (fun (atoms, body') -> (atoms, { hpara with Sil.body = body'})) atoms_body_list in
list_map (fun (atoms, hpara') -> (atoms, Sil.Hlseg(k, hpara', e1, e2, el))) atoms_hpara_list
IList.map (fun (atoms, body') -> (atoms, { hpara with Sil.body = body'})) atoms_body_list in
IList.map (fun (atoms, hpara') -> (atoms, Sil.Hlseg(k, hpara', e1, e2, el))) atoms_hpara_list
| _ -> assert false
end
| _ -> assert false in
let atoms_se_te_to_iter e (atoms, se, te) =
let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in
let iter' = IList.fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in
Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se, te)) in
let do_extend e se te =
if !Config.trace_rearrange then begin
@ -510,7 +510,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let atoms_se_te_list =
strexp_extend_values
pname tenv orig_prop false extend_kind max_stamp se te offset inst in
list_map (atoms_se_te_to_iter e) atoms_se_te_list in
IList.map (atoms_se_te_to_iter e) atoms_se_te_list in
let res_iter_list =
if Ident.kind_equal extend_kind Ident.kprimed
then iter_list (* normal part already extended: nothing to do *)
@ -518,7 +518,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let atoms_fp_sigma_list =
let footprint_sigma = Prop.prop_iter_get_footprint_sigma iter in
let sigma_pto, sigma_rest =
list_partition (function
IList.partition (function
| Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e'
| Sil.Hlseg (_, _, e1, e2, _) -> Sil.exp_equal e e1
| Sil.Hdllseg (_, _, e_iF, e_oB, e_oF, e_iB, _) -> Sil.exp_equal e e_iF || Sil.exp_equal e e_iB
@ -527,19 +527,19 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
match sigma_pto with
| [hpred] ->
let atoms_hpred_list = extend_footprint_pred hpred in
list_map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list
IList.map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list
| _ ->
L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln();
[([], footprint_sigma)] in
list_map (fun (atoms, sigma') -> (atoms, list_stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in
IList.map (fun (atoms, sigma') -> (atoms, IList.stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in
let iter_atoms_fp_sigma_list =
list_product iter_list atoms_fp_sigma_list in
list_map (fun (iter, (atoms, fp_sigma)) ->
let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in
IList.map (fun (iter, (atoms, fp_sigma)) ->
let iter' = IList.fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in
Prop.prop_iter_replace_footprint_sigma iter' fp_sigma
) iter_atoms_fp_sigma_list in
let res_prop_list =
list_map Prop.prop_iter_to_prop res_iter_list in
IList.map Prop.prop_iter_to_prop res_iter_list in
begin
L.d_str "in prop_iter_extend_ptsto lexp: "; Sil.d_exp lexp; L.d_ln ();
L.d_strln "prop before:";
@ -573,7 +573,7 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
let foot_sigma = ptsto_foot :: Prop.get_sigma_footprint eprop in
let nfoot_sigma = Prop.sigma_normalize_prop Prop.prop_emp foot_sigma in
let prop' = Prop.normalize (Prop.replace_sigma_footprint nfoot_sigma eprop) in
let prop_new = list_fold_left (Prop.prop_atom_and ~footprint:!Config.footprint) prop' atoms in
let prop_new = IList.fold_left (Prop.prop_atom_and ~footprint:!Config.footprint) prop' atoms in
let iter = match (Prop.prop_iter_create prop_new) with
| None ->
let prop_new' = Prop.normalize (Prop.prop_hpred_star prop_new ptsto) in
@ -599,14 +599,14 @@ let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst =
L.d_ln (); L.d_ln ();
let foot_sigma = ptsto_foot :: (Prop.prop_iter_get_footprint_sigma iter) in
let iter_foot = Prop.prop_iter_prev_then_insert iter ptsto in
let iter_foot_atoms = list_fold_left (Prop.prop_iter_add_atom (!Config.footprint)) iter_foot atoms in
let iter_foot_atoms = IList.fold_left (Prop.prop_iter_add_atom (!Config.footprint)) iter_foot atoms in
let iter' = Prop.prop_iter_replace_footprint_sigma iter_foot_atoms foot_sigma in
let offsets_default = Sil.exp_get_offsets lexp in
Prop.prop_iter_set_state iter' offsets_default
let sort_ftl ftl =
let compare (f1, _) (f2, _) = Sil.fld_compare f1 f2 in
list_sort compare ftl
IList.sort compare ftl
exception ARRAY_ACCESS
@ -663,18 +663,18 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
strexp_extend_values
pname tenv orig_prop false Ident.kprimed max_stamp se te offset inst in
let handle_case (atoms', se', te') =
let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms' in
let iter' = IList.fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms' in
Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se', te')) in
let filter it =
let p = Prop.prop_iter_to_prop it in
not (Prover.check_inconsistency p) in
list_filter filter (list_map handle_case atoms_se_te_list)
IList.filter filter (IList.map handle_case atoms_se_te_list)
| _ -> [iter]
end in
begin
if !Config.trace_rearrange then begin
L.d_strln "exiting iter_rearrange_ptsto, returning results";
Prop.d_proplist_with_typ (list_map Prop.prop_iter_to_prop res);
Prop.d_proplist_with_typ (IList.map Prop.prop_iter_to_prop res);
L.d_decrease_indent 1;
L.d_ln (); L.d_ln ()
end;
@ -796,7 +796,7 @@ let type_at_offset texp off =
(try
let typ' =
(fun (x, y, z) -> y)
(list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in
(IList.find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in
strip_offset off' typ'
with Not_found -> None)
| (Sil.Off_index _):: off', Sil.Tarray (typ', _) ->
@ -882,7 +882,7 @@ let rec iter_rearrange
if Prover.check_inconsistency prop' then []
else iter_rearrange pname tenv (Prop.lexp_normalize_prop prop' lexp) typ prop' iter' inst in
let rec f_many_iters iters_lst = function
| [] -> list_flatten (list_rev iters_lst)
| [] -> IList.flatten (IList.rev iters_lst)
| iter':: iters' ->
let iters_res' = f_one_iter iter' in
f_many_iters (iters_res':: iters_lst) iters' in
@ -924,7 +924,7 @@ let rec iter_rearrange
end in
if !Config.trace_rearrange then begin
L.d_strln "exiting iter_rearrange, returning results";
Prop.d_proplist_with_typ (list_map Prop.prop_iter_to_prop res);
Prop.d_proplist_with_typ (IList.map Prop.prop_iter_to_prop res);
L.d_decrease_indent 1;
L.d_ln (); L.d_ln ()
end;
@ -936,7 +936,7 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
(* return true if deref_exp is only pointed to by fields/params with @Nullable annotations *)
let is_only_pt_by_nullable_fld_or_param deref_exp =
let ann_sig = Models.get_modelled_annotated_signature (Specs.pdesc_resolve_attributes pdesc) in
list_for_all
IList.for_all
(fun hpred ->
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (Sil.Var _ as exp, _), _)
@ -959,7 +959,7 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
nullable_obj_str := Some (Ident.fieldname_to_simplified_string fld);
is_nullable
| _ -> true in
list_for_all is_strexp_pt_by_nullable_fld flds
IList.for_all is_strexp_pt_by_nullable_fld flds
| _ -> true)
(Prop.get_sigma prop) &&
!nullable_obj_str <> None in
@ -1046,7 +1046,7 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
match get_exp_called () with
| Some (_, Sil.Lvar pvar) -> (* pvar is the block *)
let name = Sil.pvar_get_name pvar in
list_exists (fun (cn, _) -> (Mangled.to_string name) = (Mangled.to_string cn)) (Cfg.Procdesc.get_captured pdesc)
IList.exists (fun (cn, _) -> (Mangled.to_string name) = (Mangled.to_string cn)) (Cfg.Procdesc.get_captured pdesc)
| _ -> false in
let is_field_deref () = (*Called expression is a field *)
match get_exp_called () with

259
infer/src/backend/sil.ml
Unescape View File

@ -37,18 +37,18 @@ type access = Default | Public | Private | Protected
(** Compare function for annotations. *)
let annotation_compare a1 a2 =
let n = string_compare a1.class_name a2.class_name in
if n <> 0 then n else list_compare string_compare a1.parameters a2.parameters
if n <> 0 then n else IList.compare string_compare a1.parameters a2.parameters
(** Compare function for annotation items. *)
let item_annotation_compare ia1 ia2 =
let cmp (a1, b1) (a2, b2) =
let n = annotation_compare a1 a2 in
if n <> 0 then n else bool_compare b1 b2 in
list_compare cmp ia1 ia2
IList.compare cmp ia1 ia2
(** Compare function for Method annotations. *)
let method_annotation_compare (ia1, ial1) (ia2, ial2) =
list_compare item_annotation_compare (ia1 :: ial1) (ia2 :: ial2)
IList.compare item_annotation_compare (ia1 :: ial1) (ia2 :: ial2)
(** Empty item annotation. *)
let item_annotation_empty = []
@ -65,7 +65,7 @@ let item_annotation_is_empty ia = ia = []
(** Check if the method annodation is empty. *)
let method_annotation_is_empty (ia, ial) =
list_for_all item_annotation_is_empty (ia :: ial)
IList.for_all item_annotation_is_empty (ia :: ial)
(** Pretty print an annotation. *)
let pp_annotation fmt annotation = F.fprintf fmt "@@%s" annotation.class_name
@ -84,7 +84,7 @@ let get_sentinel_func_attribute_value attr_list =
(* Sentinel is the only kind of attributes *)
let is_sentinel a = true in
try
match list_find is_sentinel attr_list with
match IList.find is_sentinel attr_list with
| FA_sentinel (sentinel, null_pos) -> Some (sentinel, null_pos)
with Not_found -> None
@ -216,14 +216,9 @@ module Subtype = struct
let s = (aux rest) in
if (s = "") then (Mangled.to_string el)
else (Mangled.to_string el)^", "^s in
if (list_length list = 0) then "( sub )"
if (IList.length list = 0) then "( sub )"
else ("- {"^(aux list)^"}")
let list_equal list1 list2 =
if (list_length list1 = list_length list2) then
list_for_all2 Mangled.equal list1 list2
else false
type t' =
| Exact (** denotes the current type only *)
| Subtypes of Mangled.t list(** denotes the current type and a list of types that are not their subtypes *)
@ -278,8 +273,8 @@ module Subtype = struct
let is_instof t = snd t = INSTOF
let list_intersect equal l1 l2 =
let in_l2 a = list_mem equal a l2 in
list_filter in_l2 l1
let in_l2 a = IList.mem equal a l2 in
IList.filter in_l2 l1
let join_flag flag1 flag2 =
match flag1, flag2 with
@ -297,7 +292,7 @@ module Subtype = struct
s, flag
let subtypes_compare l1 l2 =
list_compare Mangled.compare l1 l2
IList.compare Mangled.compare l1 l2
let compare_flag flag1 flag2 =
match flag1, flag2 with
@ -348,7 +343,7 @@ module Subtype = struct
(match t with
| Exact -> Some (t, new_flag)
| Subtypes l ->
Some (Subtypes (list_sort Mangled.compare l), new_flag))
Some (Subtypes (IList.sort Mangled.compare l), new_flag))
| None -> None
let subtypes_to_string t =
@ -358,7 +353,7 @@ module Subtype = struct
(* c is a subtype when it does not appear in the list l of no-subtypes *)
let is_subtype f c l =
try ignore( list_find (f c) l); false
try ignore( IList.find (f c) l); false
with Not_found -> true
let is_strict_subtype f c1 c2 =
@ -375,7 +370,7 @@ module Subtype = struct
else if (f c ci) then (ci:: l, false)
else (ci:: l, true) in
l, (add && should_add) in
(list_fold_left aux ([], true) l)
(IList.fold_left aux ([], true) l)
let rec updates_head f c l =
match l with
@ -832,7 +827,7 @@ let is_objc_ref_counter_field (fld, t, a) =
let has_objc_ref_counter hpred =
match hpred with
| Hpointsto(_, _, Sizeof(Tstruct(fl, _, _, _, _, _, _), _)) ->
list_exists is_objc_ref_counter_field fl
IList.exists is_objc_ref_counter_field fl
| _ -> false
(** turn a *T into a T. fails if [typ] is not a pointer type *)
@ -1295,7 +1290,7 @@ let rec const_compare (c1 : const) (c2 : const) : int =
if n <> 0 then n else typ_compare t1 t2
| Cptr_to_fld _, _ -> -1
| _, Cptr_to_fld _ -> 1
| Ctuple el1, Ctuple el2 -> list_compare exp_compare el1 el2
| Ctuple el1, Ctuple el2 -> IList.compare exp_compare el1 el2
(** Comparision for types. *)
and typ_compare t1 t2 =
@ -1335,7 +1330,7 @@ and typ_compare t1 t2 =
let compare_pair (n1, e1) (n2, e2) =
let n = Mangled.compare n1 n2 in
if n <> 0 then n else const_compare e1 e2 in
list_compare compare_pair l1 l2
IList.compare compare_pair l1 l2
and typ_opt_compare to1 to2 = match to1, to2 with
| None, None -> 0
@ -1347,7 +1342,7 @@ and fld_typ_ann_compare fta1 fta2 =
triple_compare fld_compare typ_compare item_annotation_compare fta1 fta2
and fld_typ_ann_list_compare ftal1 ftal2 =
list_compare fld_typ_ann_compare ftal1 ftal2
IList.compare fld_typ_ann_compare ftal1 ftal2
and attribute_compare (att1 : attribute) (att2 : attribute) : int =
match att1, att2 with
@ -1448,7 +1443,7 @@ let ident_exp_equal ide1 ide2 =
ident_exp_compare ide1 ide2 = 0
let exp_list_compare =
list_compare exp_compare
IList.compare exp_compare
let exp_list_equal el1 el2 =
exp_list_compare el1 el2 = 0
@ -1473,7 +1468,7 @@ let atom_equal x y =
atom_compare x y = 0
let atom_list_compare l1 l2 =
list_compare atom_compare l1 l2
IList.compare atom_compare l1 l2
let lseg_kind_compare k1 k2 = match k1, k2 with
| Lseg_NE, Lseg_NE -> 0
@ -1502,13 +1497,13 @@ and fld_strexp_compare fse1 fse2 =
pair_compare fld_compare strexp_compare fse1 fse2
and fld_strexp_list_compare fsel1 fsel2 =
list_compare fld_strexp_compare fsel1 fsel2
IList.compare fld_strexp_compare fsel1 fsel2
and exp_strexp_compare ese1 ese2 =
pair_compare exp_compare strexp_compare ese1 ese2
and exp_strexp_list_compare esel1 esel2 =
list_compare exp_strexp_compare esel1 esel2
IList.compare exp_strexp_compare esel1 esel2
(** Comparsion between heap predicates. Hpointsto comes before others. *)
and hpred_compare hpred1 hpred2 =
@ -1561,7 +1556,7 @@ and hpred_compare hpred1 hpred2 =
else exp_list_compare el2 el1
and hpred_list_compare l1 l2 =
list_compare hpred_compare l1 l2
IList.compare hpred_compare l1 l2
and hpara_compare hp1 hp2 =
let n = Ident.compare hp1.root hp2.root in
@ -1631,7 +1626,7 @@ module ExpMap = Map.Make(struct
let elist_to_eset es =
list_fold_left (fun set e -> ExpSet.add e set) ExpSet.empty es
IList.fold_left (fun set e -> ExpSet.add e set) ExpSet.empty es
(** {2 Sets of heap predicates} *)
@ -1793,7 +1788,7 @@ let pp_pvar_list pe f pvl =
(** Dump a list of program variables. *)
let d_pvar_list pvl =
list_iter (fun pv -> d_pvar pv; L.d_str " ") pvl
IList.iter (fun pv -> d_pvar pv; L.d_str " ") pvl
let ikind_to_string = function
| IChar -> "char"
@ -2134,13 +2129,13 @@ let instr_get_exps = function
| Prune (cond, _, _, _) ->
[cond]
| Call (ret_ids, e, _, _, _) ->
e :: (list_map (fun id -> Var id)) ret_ids
e :: (IList.map (fun id -> Var id)) ret_ids
| Nullify (pvar, _, _) ->
[Lvar pvar]
| Abstract _ ->
[]
| Remove_temps (temps, _) ->
list_map (fun id -> Var id) temps
IList.map (fun id -> Var id) temps
| Stackop _ ->
[]
| Declare_locals _ ->
@ -2227,7 +2222,7 @@ let rec typ_iter_types (f : typ -> unit) typ =
| Tptr (t', pk) ->
typ_iter_types f t'
| Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) ->
list_iter (fun (_, t, _) -> typ_iter_types f t) ftal
IList.iter (fun (_, t, _) -> typ_iter_types f t) ftal
| Tarray (t, e) ->
typ_iter_types f t;
exp_iter_types f e
@ -2241,7 +2236,7 @@ and exp_iter_types f e =
| Const (Cexn e1) ->
exp_iter_types f e1
| Const (Ctuple el) ->
list_iter (exp_iter_types f) el
IList.iter (exp_iter_types f) el
| Const _ ->
()
| Cast (t, e1) ->
@ -2279,7 +2274,7 @@ let instr_iter_types f instr = match instr with
exp_iter_types f cond
| Call (ret_ids, e, arg_ts, loc, cf) ->
exp_iter_types f e;
list_iter (fun (e, t) -> exp_iter_types f e; typ_iter_types f t) arg_ts
IList.iter (fun (e, t) -> exp_iter_types f e; typ_iter_types f t) arg_ts
| Nullify (pvar, loc, deallocate) ->
()
| Abstract loc ->
@ -2289,7 +2284,7 @@ let instr_iter_types f instr = match instr with
| Stackop (stackop, loc) ->
()
| Declare_locals (ptl, loc) ->
list_iter (fun (_, t) -> typ_iter_types f t) ptl
IList.iter (fun (_, t) -> typ_iter_types f t) ptl
| Goto_node _ ->
()
@ -2420,19 +2415,19 @@ end = struct
let rec process_sexp env = function
| Eexp _ -> ()
| Earray (_, esel, _) ->
list_iter (fun (e, se) -> process_sexp env se) esel
IList.iter (fun (e, se) -> process_sexp env se) esel
| Estruct (fsel, _) ->
list_iter (fun (f, se) -> process_sexp env se) fsel
IList.iter (fun (f, se) -> process_sexp env se) fsel
(** Process one hpred, updating env *)
let rec process_hpred env = function
| Hpointsto (_, se, _) ->
process_sexp env se
| Hlseg (_, hpara, _, _, _) ->
list_iter (process_hpred env) hpara.body;
IList.iter (process_hpred env) hpara.body;
process_hpara env hpara
| Hdllseg(_, hpara_dll, _, _, _, _, _) ->
list_iter (process_hpred env) hpara_dll.body_dll;
IList.iter (process_hpred env) hpara_dll.body_dll;
process_hpara_dll env hpara_dll
(** create an empty predicate environment *)
@ -2452,15 +2447,15 @@ end = struct
while env.todo != [] || env.todo_dll != [] do
if env.todo != [] then
begin
let hpara = list_hd env.todo in
let () = env.todo <- list_tl env.todo in
let hpara = IList.hd env.todo in
let () = env.todo <- IList.tl env.todo in
let (n, emitted) = HparaHash.find env.hash hpara in
if not emitted then f n hpara
end
else if env.todo_dll != [] then
begin
let hpara_dll = list_hd env.todo_dll in
let () = env.todo_dll <- list_tl env.todo_dll in
let hpara_dll = IList.hd env.todo_dll in
let () = env.todo_dll <- IList.tl env.todo_dll in
let (n, emitted) = HparaDllHash.find env.hash_dll hpara_dll in
if not emitted then f_dll n hpara_dll
end
@ -2527,7 +2522,7 @@ let inst_to_string inst =
let inst_partial_join inst1 inst2 =
let fail () =
L.d_strln ("inst_partial_join failed on " ^ inst_to_string inst1 ^ " " ^ inst_to_string inst2);
raise Fail in
raise IList.Fail in
if inst1 = inst2 then inst1
else match inst1, inst2 with
| _, Inone | Inone, _ -> inst_none
@ -2741,13 +2736,13 @@ let rec strexp_expmap (f: exp * inst option -> exp * inst option) =
Eexp (e', inst')
| Estruct (fld_se_list, inst) ->
let f_fld_se (fld, se) = (fld, strexp_expmap f se) in
Estruct (list_map f_fld_se fld_se_list, inst)
Estruct (IList.map f_fld_se fld_se_list, inst)
| Earray (size, idx_se_list, inst) ->
let size' = fe size in
let f_idx_se (idx, se) =
let idx' = fe idx in
(idx', strexp_expmap f se) in
Earray (size', list_map f_idx_se idx_se_list, inst)
Earray (size', IList.map f_idx_se idx_se_list, inst)
let hpred_expmap (f: exp * inst option -> exp * inst option) =
let fe e = fst (f (e, None)) in
@ -2760,14 +2755,14 @@ let hpred_expmap (f: exp * inst option -> exp * inst option) =
| Hlseg (k, hpara, root, next, shared) ->
let root' = fe root in
let next' = fe next in
let shared' = list_map fe shared in
let shared' = IList.map fe shared in
Hlseg (k, hpara, root', next', shared')
| Hdllseg (k, hpara, iF, oB, oF, iB, shared) ->
let iF' = fe iF in
let oB' = fe oB in
let oF' = fe oF in
let iB' = fe iB in
let shared' = list_map fe shared in
let shared' = IList.map fe shared in
Hdllseg (k, hpara, iF', oB', oF', iB', shared')
let rec strexp_instmap (f: inst -> inst) strexp = match strexp with
@ -2775,17 +2770,17 @@ let rec strexp_instmap (f: inst -> inst) strexp = match strexp with
Eexp (e, f inst)
| Estruct (fld_se_list, inst) ->
let f_fld_se (fld, se) = (fld, strexp_instmap f se) in
Estruct (list_map f_fld_se fld_se_list, f inst)
Estruct (IList.map f_fld_se fld_se_list, f inst)
| Earray (size, idx_se_list, inst) ->
let f_idx_se (idx, se) =
(idx, strexp_instmap f se) in
Earray (size, list_map f_idx_se idx_se_list, f inst)
Earray (size, IList.map f_idx_se idx_se_list, f inst)
and hpara_instmap (f: inst -> inst) hpara =
{ hpara with body = list_map (hpred_instmap f) hpara.body }
{ hpara with body = IList.map (hpred_instmap f) hpara.body }
and hpara_dll_instmap (f: inst -> inst) hpara_dll =
{ hpara_dll with body_dll = list_map (hpred_instmap f) hpara_dll.body_dll }
{ hpara_dll with body_dll = IList.map (hpred_instmap f) hpara_dll.body_dll }
and hpred_instmap (fn: inst -> inst) (hpred: hpred) : hpred = match hpred with
| Hpointsto (e, se, te) ->
@ -2797,14 +2792,14 @@ and hpred_instmap (fn: inst -> inst) (hpred: hpred) : hpred = match hpred with
Hdllseg (k, hpara_dll_instmap fn hpar_dll, e, f, g, h, el)
let hpred_list_expmap (f: exp * inst option -> exp * inst option) (hlist: hpred list) =
list_map (hpred_expmap f) hlist
IList.map (hpred_expmap f) hlist
let atom_expmap (f: exp -> exp) = function
| Aeq (e1, e2) -> Aeq (f e1, f e2)
| Aneq (e1, e2) -> Aneq (f e1, f e2)
let atom_list_expmap (f: exp -> exp) (alist: atom list) =
list_map (atom_expmap f) alist
IList.map (atom_expmap f) alist
(** {2 Function for computing lexps in sigma} *)
@ -2814,8 +2809,8 @@ let hpred_get_lexp acc = function
| Hdllseg(_, _, e1, _, _, e2, _) -> e1:: e2:: acc
let hpred_list_get_lexps (filter: exp -> bool) (hlist: hpred list) : exp list =
let lexps = list_fold_left hpred_get_lexp [] hlist in
list_filter filter lexps
let lexps = IList.fold_left hpred_get_lexp [] hlist in
IList.filter filter lexps
(** {2 Utility Functions for Expressions} *)
@ -2838,7 +2833,7 @@ let struct_typ_fld default_opt f =
let def () = unsome_typ "struct_typ_fld" default_opt in
function
| Tstruct (ftal, sftal, _, _, _, _, _) ->
(try (fun (x, y, z) -> y) (list_find (fun (_f, t, ann) -> Ident.fieldname_equal _f f) ftal)
(try (fun (x, y, z) -> y) (IList.find (fun (_f, t, ann) -> Ident.fieldname_equal _f f) ftal)
with Not_found -> def ())
| _ -> def ()
@ -2922,7 +2917,7 @@ let rec exp_fpv = function
| Lindex (e1, e2) -> exp_fpv e1 @ exp_fpv e2
| Sizeof _ -> []
and exp_list_fpv el = list_flatten (list_map exp_fpv el)
and exp_list_fpv el = IList.flatten (IList.map exp_fpv el)
let atom_fpv = function
| Aeq (e1, e2) -> exp_fpv e1 @ exp_fpv e2
@ -2932,11 +2927,11 @@ let rec strexp_fpv = function
| Eexp (e, inst) -> exp_fpv e
| Estruct (fld_se_list, inst) ->
let f (_, se) = strexp_fpv se in
list_flatten (list_map f fld_se_list)
IList.flatten (IList.map f fld_se_list)
| Earray (size, idx_se_list, inst) ->
let fpv_in_size = exp_fpv size in
let f (idx, se) = exp_fpv idx @ strexp_fpv se in
fpv_in_size @ list_flatten (list_map f idx_se_list)
fpv_in_size @ IList.flatten (IList.map f idx_se_list)
and hpred_fpv = function
| Hpointsto (base, se, te) ->
@ -2961,7 +2956,7 @@ and hpred_fpv = function
analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *)
and hpara_fpv para =
let fpvars_in_body = list_flatten (list_map hpred_fpv para.body) in
let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body) in
match fpvars_in_body with
| [] -> []
| _ -> assert false
@ -2971,7 +2966,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 = list_flatten (list_map hpred_fpv para.body_dll) in
let fpvars_in_body = IList.flatten (IList.map hpred_fpv para.body_dll) in
match fpvars_in_body with
| [] -> []
| _ -> assert false
@ -2991,22 +2986,22 @@ let fav_is_empty fav = match !fav with
(** Check whether a predicate holds for all elements. *)
let fav_for_all fav predicate =
list_for_all predicate !fav
IList.for_all predicate !fav
(** Check whether a predicate holds for some elements. *)
let fav_exists fav predicate =
list_exists predicate !fav
IList.exists predicate !fav
(** flag to indicate whether fav's are stored in duplicate form -- only to be used with fav_to_list *)
let fav_duplicates = ref false
(** extend [fav] with a [id] *)
let (++) fav id =
if !fav_duplicates || not (list_exists (Ident.equal id) !fav) then fav := id::!fav
if !fav_duplicates || not (IList.exists (Ident.equal id) !fav) then fav := id::!fav
(** extend [fav] with ident list [idl] *)
let (+++) fav idl =
list_iter (fun id -> fav ++ id) idl
IList.iter (fun id -> fav ++ id) idl
(** add identity lists to fav *)
let ident_list_fav_add idl fav =
@ -3015,7 +3010,7 @@ let ident_list_fav_add idl fav =
(** Convert a list to a fav. *)
let fav_from_list l =
let fav = fav_new () in
let _ = list_iter (fun id -> fav ++ id) l in
let _ = IList.iter (fun id -> fav ++ id) l in
fav
let rec remove_duplicates_from_sorted special_equal = function
@ -3029,7 +3024,7 @@ let rec remove_duplicates_from_sorted special_equal = function
(** Convert a [fav] to a list of identifiers while preserving the order
that the identifiers were added to [fav]. *)
let fav_to_list fav =
list_rev !fav
IList.rev !fav
(** Pretty print a fav. *)
let pp_fav pe f fav =
@ -3037,7 +3032,7 @@ let pp_fav pe f fav =
(** Copy a [fav]. *)
let fav_copy fav =
ref (list_map (fun x -> x) !fav)
ref (IList.map (fun x -> x) !fav)
(** Turn a xxx_fav_add function into a xxx_fav function *)
let fav_imperative_to_functional f x =
@ -3047,11 +3042,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 := list_filter filter !fav
fav := IList.filter filter !fav
(** Like [fav_filter_ident] but return a copy. *)
let fav_copy_filter_ident fav filter =
ref (list_filter filter !fav)
ref (IList.filter filter !fav)
(** checks whether every element in l1 appears l2 **)
let rec ident_sorted_list_subset l1 l2 =
@ -3070,12 +3065,12 @@ let fav_subset_ident fav1 fav2 =
ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2)
let fav_mem fav id =
list_exists (Ident.equal id) !fav
IList.exists (Ident.equal id) !fav
let rec exp_fav_add fav = function
| Var id -> fav ++ id
| Const (Cexn e) -> exp_fav_add fav e
| Const (Ctuple el) -> list_iter (exp_fav_add fav) el
| Const (Ctuple el) -> IList.iter (exp_fav_add fav) el
| Const _ -> ()
| Cast (_, e) | UnOp (_, e, _) -> exp_fav_add fav e
| BinOp (_, e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2
@ -3110,22 +3105,22 @@ let hpara_dll_fav_add fav para = () (* Global invariant: hpara_dll is closed *)
let rec strexp_fav_add fav = function
| Eexp (e, inst) -> exp_fav_add fav e
| Estruct (fld_se_list, inst) ->
list_iter (fun (_, se) -> strexp_fav_add fav se) fld_se_list
IList.iter (fun (_, se) -> strexp_fav_add fav se) fld_se_list
| Earray (size, idx_se_list, inst) ->
exp_fav_add fav size;
list_iter (fun (e, se) -> exp_fav_add fav e; strexp_fav_add fav se) idx_se_list
IList.iter (fun (e, se) -> exp_fav_add fav e; strexp_fav_add fav se) idx_se_list
let hpred_fav_add fav = function
| Hpointsto (base, sexp, te) -> exp_fav_add fav base; strexp_fav_add fav sexp; exp_fav_add fav te
| Hlseg (_, para, e1, e2, elist) ->
hpara_fav_add fav para;
exp_fav_add fav e1; exp_fav_add fav e2;
list_iter (exp_fav_add fav) elist
IList.iter (exp_fav_add fav) elist
| Hdllseg (_, para, e1, e2, e3, e4, elist) ->
hpara_dll_fav_add fav para;
exp_fav_add fav e1; exp_fav_add fav e2;
exp_fav_add fav e3; exp_fav_add fav e4;
list_iter (exp_fav_add fav) elist
IList.iter (exp_fav_add fav) elist
let hpred_fav =
fav_imperative_to_functional hpred_fav_add
@ -3154,12 +3149,12 @@ let exp_av_add = exp_fav_add (** Expressions do not bind variables *)
let strexp_av_add = strexp_fav_add (** Structured expressions do not bind variables *)
let rec hpara_av_add fav para =
list_iter (hpred_av_add fav) para.body;
IList.iter (hpred_av_add fav) para.body;
fav ++ para.root; fav ++ para.next;
fav +++ para.svars; fav +++ para.evars
and hpara_dll_av_add fav para =
list_iter (hpred_av_add fav) para.body_dll;
IList.iter (hpred_av_add fav) para.body_dll;
fav ++ para.cell; fav ++ para.blink; fav ++ para.flink;
fav +++ para.svars_dll; fav +++ para.evars_dll
@ -3169,20 +3164,20 @@ and hpred_av_add fav = function
| Hlseg (_, para, e1, e2, elist) ->
hpara_av_add fav para;
exp_av_add fav e1; exp_av_add fav e2;
list_iter (exp_av_add fav) elist
IList.iter (exp_av_add fav) elist
| Hdllseg (_, para, e1, e2, e3, e4, elist) ->
hpara_dll_av_add fav para;
exp_av_add fav e1; exp_av_add fav e2;
exp_av_add fav e3; exp_av_add fav e4;
list_iter (exp_av_add fav) elist
IList.iter (exp_av_add fav) elist
let hpara_shallow_av_add fav para =
list_iter (hpred_fav_add fav) para.body;
IList.iter (hpred_fav_add fav) para.body;
fav ++ para.root; fav ++ para.next;
fav +++ para.svars; fav +++ para.evars
let hpara_dll_shallow_av_add fav para =
list_iter (hpred_fav_add fav) para.body_dll;
IList.iter (hpred_fav_add fav) para.body_dll;
fav ++ para.cell; fav ++ para.blink; fav ++ para.flink;
fav +++ para.svars_dll; fav +++ para.evars_dll
@ -3239,7 +3234,7 @@ let sub_check_duplicated_ids sub =
sorted_list_check_consecutives f sub
let sub_check_sortedness sub =
let sub' = list_sort ident_exp_compare sub in
let sub' = IList.sort ident_exp_compare sub in
sub_equal sub sub'
let sub_check_inv sub =
@ -3249,14 +3244,14 @@ let sub_check_inv sub =
For all (id1, e1), (id2, e2) in the input list,
if id1 = id2, then e1 = e2. *)
let sub_of_list sub =
let sub' = list_sort ident_exp_compare sub in
let sub' = IList.sort ident_exp_compare sub in
let sub'' = remove_duplicates_from_sorted ident_exp_equal sub' in
(if sub_check_duplicated_ids sub'' then assert false);
sub'
(** like sub_of_list, but allow duplicate ids and only keep the first occurrence *)
let sub_of_list_duplicates sub =
let sub' = list_sort ident_exp_compare sub in
let sub' = IList.sort ident_exp_compare sub in
let rec remove_duplicate_ids = function
| (id1, e1) :: (id2, e2) :: l ->
if Ident.equal id1 id2
@ -3308,46 +3303,46 @@ let typ_update_memo = Typtbl.create 17
(** [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 (list_find (fun (i, _) -> filter i) sub)
snd (IList.find (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) =
list_filter (fun (i, _) -> filter i) sub
IList.filter (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 = list_filter
let sub_filter_pair = IList.filter
(** [sub_range_partition filter sub] partitions [sub] according to
whether range expressions satisfy [filter]. *)
let sub_range_partition filter (sub: subst) =
list_partition (fun (_, e) -> filter e) sub
IList.partition (fun (_, e) -> filter e) sub
(** [sub_domain_partition filter sub] partitions [sub] according to
whether domain identifiers satisfy [filter]. *)
let sub_domain_partition filter (sub: subst) =
list_partition (fun (i, _) -> filter i) sub
IList.partition (fun (i, _) -> filter i) sub
(** Return the list of identifiers in the domain of the substitution. *)
let sub_domain sub =
list_map fst sub
IList.map fst sub
(** Return the list of expressions in the range of the substitution. *)
let sub_range sub =
list_map snd sub
IList.map snd sub
(** [sub_range_map f sub] applies [f] to the expressions in the range of [sub]. *)
let sub_range_map f sub =
sub_of_list (list_map (fun (i, e) -> (i, f e)) sub)
sub_of_list (IList.map (fun (i, e) -> (i, f e)) sub)
(** [sub_map f g sub] applies the renaming [f] to identifiers in the domain
of [sub] and the substitution [g] to the expressions in the range of [sub]. *)
let sub_map f g sub =
sub_of_list (list_map (fun (i, e) -> (f i, g e)) sub)
sub_of_list (IList.map (fun (i, e) -> (f i, g e)) sub)
let mem_sub id sub =
list_exists (fun (id1, _) -> Ident.equal id id1) sub
IList.exists (fun (id1, _) -> Ident.equal id id1) sub
(** Extend substitution and return [None] if not possible. *)
let extend_sub sub id exp : subst option =
@ -3358,10 +3353,10 @@ let extend_sub sub id exp : subst option =
(** Free auxilary variables in the domain and range of the
substitution. *)
let sub_fav_add fav (sub: subst) =
list_iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub
IList.iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub
let sub_fpv (sub: subst) =
list_flatten (list_map (fun (_, e) -> exp_fpv e) sub)
IList.flatten (IList.map (fun (_, e) -> exp_fpv e) sub)
(** Substitutions do not contain binders *)
let sub_av_add = sub_fav_add
@ -3393,7 +3388,7 @@ and exp_sub (subst: subst) e =
let e1' = exp_sub subst e1 in
Const (Cexn e1')
| Const (Ctuple el) ->
let el' = list_map (exp_sub subst) el in
let el' = IList.map (exp_sub subst) el in
Const (Ctuple el')
| Const _ ->
e
@ -3438,18 +3433,18 @@ let instr_sub (subst: subst) instr =
Prune (exp_s cond, loc, true_branch, ik)
| Call (ret_ids, e, arg_ts, loc, cf) ->
let arg_s (e, t) = (exp_s e, typ_s t) in
Call (list_map id_s ret_ids, exp_s e, list_map arg_s arg_ts, loc, cf)
Call (IList.map id_s ret_ids, exp_s e, IList.map arg_s arg_ts, loc, cf)
| Nullify (pvar, loc, deallocate) ->
instr
| Abstract loc ->
instr
| Remove_temps (temps, loc) ->
Remove_temps (list_map id_s temps, loc)
Remove_temps (IList.map id_s temps, loc)
| Stackop (stackop, loc) ->
instr
| Declare_locals (ptl, loc) ->
let pt_s (pv, t) = (pv, typ_s t) in
Declare_locals (list_map pt_s ptl, loc)
Declare_locals (IList.map pt_s ptl, loc)
| Goto_node (e, loc) ->
Goto_node (exp_s e, loc)
@ -3484,9 +3479,9 @@ let instr_compare instr1 instr2 = match instr1, instr2 with
| Prune _, _ -> -1
| _, Prune _ -> 1
| Call (ret_ids1, e1, arg_ts1, loc1, cf1), Call (ret_ids2, e2, arg_ts2, loc2, cf2) ->
let n = list_compare Ident.compare ret_ids1 ret_ids2 in
let n = IList.compare Ident.compare ret_ids1 ret_ids2 in
if n <> 0 then n else let n = exp_compare e1 e2 in
if n <> 0 then n else let n = list_compare exp_typ_compare arg_ts1 arg_ts2 in
if n <> 0 then n else let n = IList.compare exp_typ_compare arg_ts1 arg_ts2 in
if n <> 0 then n else let n = Location.compare loc1 loc2 in
if n <> 0 then n else call_flags_compare cf1 cf2
| Call _, _ -> -1
@ -3502,7 +3497,7 @@ let instr_compare instr1 instr2 = match instr1, instr2 with
| Abstract _, _ -> -1
| _, Abstract _ -> 1
| Remove_temps (temps1, loc1), Remove_temps (temps2, loc2) ->
let n = list_compare Ident.compare temps1 temps2 in
let n = IList.compare Ident.compare temps1 temps2 in
if n <> 0 then n else Location.compare loc1 loc2
| Remove_temps _, _ -> -1
| _, Remove_temps _ -> 1
@ -3516,7 +3511,7 @@ let instr_compare instr1 instr2 = match instr1, instr2 with
let n = pvar_compare pv1 pv2 in
if n <> 0 then n else typ_compare t1 t2 in
let n = list_compare pt_compare ptl1 ptl2 in
let n = IList.compare pt_compare ptl1 ptl2 in
if n <> 0 then n else Location.compare loc1 loc2
| Declare_locals _, _ -> -1
| _, Declare_locals _ -> 1
@ -3575,10 +3570,10 @@ let exp_typ_compare_structural (e1, t1) (e2, t2) exp_map =
used in the procedure of [instr2] *)
let instr_compare_structural instr1 instr2 exp_map =
let id_list_compare_structural ids1 ids2 exp_map =
let n = Pervasives.compare (list_length ids1) (list_length ids2) in
let n = Pervasives.compare (IList.length ids1) (IList.length ids2) in
if n <> 0 then n, exp_map
else
list_fold_left2
IList.fold_left2
(fun (n, exp_map) id1 id2 ->
if n <> 0 then (n, exp_map)
else exp_compare_structural (Var id1) (Var id2) exp_map)
@ -3607,10 +3602,10 @@ let instr_compare_structural instr1 instr2 exp_map =
else Pervasives.compare ik1 ik2), exp_map
| Call (ret_ids1, e1, arg_ts1, loc1, cf1), Call (ret_ids2, e2, arg_ts2, loc2, cf2) ->
let args_compare_structural args1 args2 exp_map =
let n = Pervasives.compare (list_length args1) (list_length args2) in
let n = Pervasives.compare (IList.length args1) (IList.length args2) in
if n <> 0 then n, exp_map
else
list_fold_left2
IList.fold_left2
(fun (n, exp_map) arg1 arg2 ->
if n <> 0 then (n, exp_map)
else exp_typ_compare_structural arg1 arg2 exp_map)
@ -3633,10 +3628,10 @@ let instr_compare_structural instr1 instr2 exp_map =
| Stackop (stackop1, loc1), Stackop (stackop2, loc2) ->
Pervasives.compare stackop1 stackop2, exp_map
| Declare_locals (ptl1, loc1), Declare_locals (ptl2, loc2) ->
let n = Pervasives.compare (list_length ptl1) (list_length ptl2) in
let n = Pervasives.compare (IList.length ptl1) (IList.length ptl2) in
if n <> 0 then n, exp_map
else
list_fold_left2
IList.fold_left2
(fun (n, exp_map) (pv1, t1) (pv2, t2) ->
if n <> 0 then (n, exp_map)
else
@ -3670,12 +3665,12 @@ let hpara_dll_sub subst para = para
let exp_replace_exp epairs e =
try
let (_, e') = list_find (fun (e1, _) -> exp_equal e e1) epairs in
let (_, e') = IList.find (fun (e1, _) -> exp_equal e e1) epairs in
e'
with Not_found -> e
let exp_list_replace_exp epairs l =
list_map (exp_replace_exp epairs) l
IList.map (exp_replace_exp epairs) l
let atom_replace_exp epairs = function
| Aeq (e1, e2) ->
@ -3692,13 +3687,13 @@ let rec strexp_replace_exp epairs = function
Eexp (exp_replace_exp epairs e, inst)
| Estruct (fsel, inst) ->
let f (fld, se) = (fld, strexp_replace_exp epairs se) in
Estruct (list_map f fsel, inst)
Estruct (IList.map f fsel, inst)
| Earray (size, isel, inst) ->
let size' = exp_replace_exp epairs size in
let f (idx, se) =
let idx' = exp_replace_exp epairs idx in
(idx', strexp_replace_exp epairs se) in
Earray (size', list_map f isel, inst)
Earray (size', IList.map f isel, inst)
let hpred_replace_exp epairs = function
| Hpointsto (root, se, te) ->
@ -3709,14 +3704,14 @@ let hpred_replace_exp epairs = function
| Hlseg (k, para, root, next, shared) ->
let root_repl = exp_replace_exp epairs root in
let next_repl = exp_replace_exp epairs next in
let shared_repl = list_map (exp_replace_exp epairs) shared in
let shared_repl = IList.map (exp_replace_exp epairs) shared in
Hlseg (k, para, root_repl, next_repl, shared_repl)
| Hdllseg (k, para, e1, e2, e3, e4, shared) ->
let e1' = exp_replace_exp epairs e1 in
let e2' = exp_replace_exp epairs e2 in
let e3' = exp_replace_exp epairs e3 in
let e4' = exp_replace_exp epairs e4 in
let shared_repl = list_map (exp_replace_exp epairs) shared in
let shared_repl = IList.map (exp_replace_exp epairs) shared in
Hdllseg (k, para, e1', e2', e3', e4', shared_repl)
(** {2 Compaction} *)
@ -3751,7 +3746,7 @@ let rec sexp_compact sh se =
| Eexp (e, inst) ->
Eexp (exp_compact sh e, inst)
| Estruct (fsel, inst) ->
Estruct (list_map (fun (f, se) -> (f, sexp_compact sh se)) fsel, inst)
Estruct (IList.map (fun (f, se) -> (f, sexp_compact sh se)) fsel, inst)
| Earray _ ->
se
@ -3911,14 +3906,14 @@ let sigma_to_sigma_ne sigma : (atom list * hpred list) list =
let f eqs_sigma_list hpred = match hpred with
| Hpointsto _ | Hlseg(Lseg_NE, _, _, _, _) | Hdllseg(Lseg_NE, _, _, _, _, _, _) ->
let g (eqs, sigma) = (eqs, hpred:: sigma) in
list_map g eqs_sigma_list
IList.map g eqs_sigma_list
| Hlseg(Lseg_PE, para, e1, e2, el) ->
let g (eqs, sigma) = [(Aeq(e1, e2):: eqs, sigma); (eqs, Hlseg(Lseg_NE, para, e1, e2, el):: sigma)] in
list_flatten (list_map g eqs_sigma_list)
IList.flatten (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)] in
list_flatten (list_map g eqs_sigma_list) in
list_fold_left f [([],[])] sigma
IList.flatten (IList.map g eqs_sigma_list) in
IList.fold_left f [([],[])] sigma
else
[([], sigma)]
@ -3929,17 +3924,17 @@ let sigma_to_sigma_ne sigma : (atom list * hpred list) list =
let hpara_instantiate para e1 e2 elist =
let subst_for_svars =
let g id e = (id, e) in
try (list_map2 g para.svars elist)
try (IList.map2 g para.svars elist)
with Invalid_argument _ -> assert false in
let ids_evars =
let g id = Ident.create_fresh Ident.kprimed in
list_map g para.evars in
IList.map g para.evars in
let subst_for_evars =
let g id id' = (id, Var id') in
try (list_map2 g para.evars ids_evars)
try (IList.map2 g para.evars ids_evars)
with Invalid_argument _ -> assert false in
let subst = sub_of_list ((para.root, e1):: (para.next, e2):: subst_for_svars@subst_for_evars) in
(ids_evars, list_map (hpred_sub subst) para.body)
(ids_evars, IList.map (hpred_sub subst) para.body)
(** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell],
[blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b],
@ -3948,25 +3943,25 @@ let hpara_instantiate para e1 e2 elist =
let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist =
let subst_for_svars =
let g id e = (id, e) in
try (list_map2 g para.svars_dll elist)
try (IList.map2 g para.svars_dll elist)
with Invalid_argument _ -> assert false in
let ids_evars =
let g id = Ident.create_fresh Ident.kprimed in
list_map g para.evars_dll in
IList.map g para.evars_dll in
let subst_for_evars =
let g id id' = (id, Var id') in
try (list_map2 g para.evars_dll ids_evars)
try (IList.map2 g para.evars_dll ids_evars)
with Invalid_argument _ -> assert false in
let subst = sub_of_list ((para.cell, cell):: (para.blink, blink):: (para.flink, flink):: subst_for_svars@subst_for_evars) in
(ids_evars, list_map (hpred_sub subst) para.body_dll)
(ids_evars, IList.map (hpred_sub subst) para.body_dll)
(** Return the list of expressions that could be understood as outgoing arrows from the strexp *)
let rec strexp_get_target_exps = function
| Eexp (e, inst) -> [e]
| Estruct (fsel, inst) -> list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) fsel)
| Estruct (fsel, inst) -> IList.flatten (IList.map (fun (_, se) -> strexp_get_target_exps se) fsel)
| Earray (_, esel, _) ->
(* We ignore size and indices since they are not quite outgoing arrows. *)
list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) esel)
IList.flatten (IList.map (fun (_, se) -> strexp_get_target_exps se) esel)
let global_error =
mk_pvar_global (Mangled.from_string "INFER_ERROR")

42
infer/src/backend/specs.ml
Unescape View File

@ -147,13 +147,13 @@ let visited_str vis =
let s = ref "" in
let lines = ref IntSet.empty in
let do_one (node, ns) =
(* if list_length ns > 1 then
(* if IList.length ns > 1 then
begin
let ss = ref "" in
list_iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns;
IList.iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns;
L.err "Node %d has lines %s@." node !ss
end; *)
list_iter (fun n -> lines := IntSet.add n !lines) ns in
IList.iter (fun n -> lines := IntSet.add n !lines) ns in
Visitedset.iter do_one vis;
IntSet.iter (fun n -> s := !s ^ " " ^ string_of_int n) !lines;
!s
@ -181,12 +181,12 @@ end = struct
let spec_fav (spec: Prop.normal spec) : Sil.fav =
let fav = Sil.fav_new () in
Jprop.fav_add_dfs fav spec.pre;
list_iter (fun (p, path) -> Prop.prop_fav_add_dfs fav p) spec.posts;
IList.iter (fun (p, path) -> Prop.prop_fav_add_dfs fav p) spec.posts;
fav
let spec_sub sub spec =
{ pre = Jprop.normalize (Jprop.jprop_sub sub spec.pre);
posts = list_map (fun (p, path) -> (Prop.normalize (Prop.prop_sub sub p), path)) spec.posts;
posts = IList.map (fun (p, path) -> (Prop.normalize (Prop.prop_sub sub p), path)) spec.posts;
visited = spec.visited }
(** Convert spec into normal form w.r.t. variable renaming *)
@ -194,13 +194,13 @@ end = struct
let fav = spec_fav spec in
let idlist = Sil.fav_to_list fav in
let count = ref 0 in
let sub = Sil.sub_of_list (list_map (fun id -> incr count; (id, Sil.Var (Ident.create_normal Ident.name_spec !count))) idlist) in
let sub = Sil.sub_of_list (IList.map (fun id -> incr count; (id, Sil.Var (Ident.create_normal Ident.name_spec !count))) idlist) in
spec_sub sub spec
(** Return a compact representation of the spec *)
let compact sh spec =
let pre = Jprop.compact sh spec.pre in
let posts = list_map (fun (p, path) -> (Prop.prop_compact sh p, path)) spec.posts in
let posts = IList.map (fun (p, path) -> (Prop.prop_compact sh p, path)) spec.posts in
{ pre = pre; posts = posts; visited = spec.visited }
(** Erase join info from pre of spec *)
@ -244,7 +244,7 @@ module CallStats = struct (** module for tracing stats of function calls *)
let init calls =
let hash = PnameLocHash.create 1 in
let do_call pn_loc = PnameLocHash.add hash pn_loc empty_trace in
list_iter do_call calls;
IList.iter do_call calls;
hash
let trace t proc_name loc res in_footprint =
@ -264,7 +264,7 @@ module CallStats = struct (** module for tracing stats of function calls *)
let s2 = if in_footprint then "FP" else "RE" in
s1 ^ ":" ^ s2
let pp_trace fmt tr = Utils.pp_seq (fun fmt x -> F.fprintf fmt "%s" (tr_elem_str x)) fmt (list_rev tr)
let pp_trace fmt tr = Utils.pp_seq (fun fmt x -> F.fprintf fmt "%s" (tr_elem_str x)) fmt (IList.rev tr)
let iter f t =
let elems = ref [] in
@ -273,8 +273,8 @@ module CallStats = struct (** module for tracing stats of function calls *)
let compare ((pname1, loc1), _) ((pname2, loc2), _) =
let n = Procname.compare pname1 pname2 in
if n <> 0 then n else Location.compare loc1 loc2 in
list_sort compare !elems in
list_iter (fun (x, tr) -> f x tr) sorted_elems
IList.sort compare !elems in
IList.iter (fun (x, tr) -> f x tr) sorted_elems
let pp fmt t =
let do_call (pname, loc) tr =
@ -354,7 +354,7 @@ let pp_spec pe num_opt fmt spec =
| Some (n, tot) -> Format.sprintf "%d of %d [nvisited:%s]" n tot (visited_str spec.visited) in
let pre = Jprop.to_prop spec.pre in
let pe_post = Prop.prop_update_obj_sub pe pre in
let post_list = list_map fst spec.posts in
let post_list = IList.map fst spec.posts in
match pe.pe_kind with
| PP_TEXT ->
F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str;
@ -374,15 +374,15 @@ let pp_spec pe num_opt fmt spec =
let d_spec (spec: 'a spec) = L.add_print_action (L.PTspec, Obj.repr spec)
let pp_specs pe fmt specs =
let total = list_length specs in
let total = IList.length specs in
let cnt = ref 0 in
match pe.pe_kind with
| PP_TEXT ->
list_iter (fun spec -> incr cnt; F.fprintf fmt "%a@\n" (pp_spec pe (Some (!cnt, total))) spec) specs
IList.iter (fun spec -> incr cnt; F.fprintf fmt "%a@\n" (pp_spec pe (Some (!cnt, total))) spec) specs
| PP_HTML ->
list_iter (fun spec -> incr cnt; F.fprintf fmt "%a<br>@\n" (pp_spec pe (Some (!cnt, total))) spec) specs
IList.iter (fun spec -> incr cnt; F.fprintf fmt "%a<br>@\n" (pp_spec pe (Some (!cnt, total))) spec) specs
| PP_LATEX ->
list_iter (fun spec -> incr cnt; F.fprintf fmt "\\subsection*{Spec %d of %d}@\n\\(%a\\)@\n" !cnt total (pp_spec pe None) spec) specs
IList.iter (fun spec -> incr cnt; F.fprintf fmt "\\subsection*{Spec %d of %d}@\n\\(%a\\)@\n" !cnt total (pp_spec pe None) spec) specs
(** Print the decpendency map *)
let pp_dependency_map fmt dependency_map =
@ -401,7 +401,7 @@ let describe_phase summary =
(** Return the signature of a procedure declaration as a string *)
let get_signature summary =
let s = ref "" in
list_iter (fun (p, typ) ->
IList.iter (fun (p, typ) ->
let pp_name f () = F.fprintf f "%s" p in
let pp f () = Sil.pp_type_decl pe_text pp_name Sil.pp_exp f typ in
let decl = pp_to_string pp () in
@ -479,7 +479,7 @@ let rec post_equal pl1 pl2 = match pl1, pl2 with
else false
let payload_compact sh payload = match payload with
| PrePosts specs -> PrePosts (list_map (NormSpec.compact sh) specs)
| PrePosts specs -> PrePosts (IList.map (NormSpec.compact sh) specs)
| TypeState _ -> payload
(** Return a compact representation of the summary *)
@ -510,7 +510,7 @@ let summary_exists pname =
(** paths to the .specs file for the given procedure in the current spec libraries *)
let specs_library_filenames pname =
list_map
IList.map
(fun specs_dir -> DB.filename_from_string (Filename.concat specs_dir (specs_filename pname)))
!Config.specs_library
@ -527,7 +527,7 @@ let summary_serializer : summary Serialization.serializer =
(** Save summary for the procedure into the spec database *)
let store_summary pname (summ: summary) =
let process_payload = function
| PrePosts specs -> PrePosts (list_map NormSpec.erase_join_info_pre specs)
| PrePosts specs -> PrePosts (IList.map NormSpec.erase_join_info_pre specs)
| TypeState typestate_opt -> TypeState typestate_opt in
let summ1 = { summ with payload = process_payload summ.payload } in
let summ2 = if !Config.save_compact_summaries
@ -754,7 +754,7 @@ let set_status proc_name status =
(** Create the initial dependency map with the given list of dependencies *)
let mk_initial_dependency_map proc_list : dependency_map_t =
list_fold_left (fun map pname -> Procname.Map.add pname (- 1) map) Procname.Map.empty proc_list
IList.fold_left (fun map pname -> Procname.Map.add pname (- 1) map) Procname.Map.empty proc_list
(** Re-initialize a dependency map *)
let re_initialize_dependency_map dependency_map =

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

@ -111,14 +111,14 @@ let node_simple_key node =
| Sil.Stackop _ -> add_key 8
| Sil.Declare_locals _ -> add_key 9
| Sil.Goto_node _ -> add_key 10 in
list_iter do_instr (Cfg.Node.get_instrs node);
IList.iter do_instr (Cfg.Node.get_instrs node);
Hashtbl.hash !key
(** key for a node: look at the current node, successors and predecessors *)
let node_key node =
let succs = Cfg.Node.get_succs node in
let preds = Cfg.Node.get_preds node in
let v = (node_simple_key node, list_map node_simple_key succs, list_map node_simple_key preds) in
let v = (node_simple_key node, IList.map node_simple_key succs, IList.map node_simple_key preds) in
Hashtbl.hash v
(** normalize the list of instructions by renaming let-bound ids *)
@ -127,14 +127,14 @@ let instrs_normalize instrs =
let do_instr ids = function
| Sil.Letderef (id, _, _, _) -> id :: ids
| _ -> ids in
list_fold_left do_instr [] instrs in
IList.fold_left do_instr [] instrs in
let subst =
let count = ref min_int in
let gensym id =
incr count;
Ident.set_stamp id !count in
Sil.sub_of_list (list_map (fun id -> (id, Sil.Var (gensym id))) bound_ids) in
list_map (Sil.instr_sub subst) instrs
Sil.sub_of_list (IList.map (fun id -> (id, Sil.Var (gensym id))) bound_ids) in
IList.map (Sil.instr_sub subst) instrs
(** Create a function to find duplicate nodes.
A node is a duplicate of another one if they have the same kind and location
@ -179,7 +179,7 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
let nodes = Cfg.Procdesc.get_nodes proc_desc in
try
list_iter do_node nodes;
IList.iter do_node nodes;
!m
with E.Threshold ->
M.empty in
@ -190,14 +190,14 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
let elements = S.elements s in
let (_, node_normalized_instrs), others =
let filter (node', _) = Cfg.Node.equal node node' in
match list_partition filter elements with
match IList.partition filter elements with
| [this], others -> this, others
| _ -> raise Not_found in
let duplicates =
let equal_normalized_instrs (_, normalized_instrs') =
list_compare Sil.instr_compare node_normalized_instrs normalized_instrs' = 0 in
list_filter equal_normalized_instrs elements in
list_fold_left
IList.compare Sil.instr_compare node_normalized_instrs normalized_instrs' = 0 in
IList.filter equal_normalized_instrs elements in
IList.fold_left
(fun nset (node', _) -> Cfg.NodeSet.add node' nset)
Cfg.NodeSet.empty duplicates
with Not_found -> Cfg.NodeSet.singleton node in
@ -231,7 +231,7 @@ let extract_pre p tenv pdesc abstract_fun =
let fav = Prop.prop_fav p in
let idlist = Sil.fav_to_list fav in
let count = ref 0 in
Sil.sub_of_list (list_map (fun id -> incr count; (id, Sil.Var (Ident.create_normal Ident.name_spec !count))) idlist) in
Sil.sub_of_list (IList.map (fun id -> incr count; (id, Sil.Var (Ident.create_normal Ident.name_spec !count))) idlist) in
let _, p' = Cfg.remove_locals_formals pdesc p in
let pre, _ = Prop.extract_spec p' in
let pre' = try abstract_fun tenv pre with exn when exn_not_timeout exn -> pre in

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

@ -35,7 +35,7 @@ let append_list_op list_op1 list_op2 =
let reverse_list_op list_op =
match list_op with
| None -> None
| Some list -> Some (list_rev list)
| Some list -> Some (IList.rev list)
let rec unroll_type tenv typ off =
match (typ, off) with
@ -61,18 +61,9 @@ let rec unroll_type tenv typ off =
L.d_str "Type : "; Sil.d_typ_full typ; L.d_ln ();
assert false
(* This function has the same name the standard list_split in Utils.*)
(* Maybe it's better to change name as we open Utils. *)
let list_split equal x xys =
let (xy, xys') = list_partition (fun (x', _) -> equal x x') xys in
match xy with
| [] -> (xys', None)
| [(x', y')] -> (xys', Some y')
| _ -> assert false
(* Given a node, returns a list of pvar of blocks that have been nullified in the block *)
let get_nullified_block node =
let null_blocks = list_flatten(list_map (fun i -> match i with
let null_blocks = IList.flatten(IList.map (fun i -> match i with
| Sil.Nullify(pvar, _, true) when Sil.is_block_pvar pvar -> [pvar]
| _ -> []) (Cfg.Node.get_instrs node)) in
null_blocks
@ -82,7 +73,7 @@ let get_nullified_block node =
let check_block_retain_cycle cfg tenv pname _prop block_nullified =
let mblock = Sil.pvar_get_name block_nullified in
let block_captured = (match Cfg.get_block_pdesc cfg mblock with
| Some pd -> fst (Utils.list_split (Cfg.Procdesc.get_captured pd))
| Some pd -> fst (IList.split (Cfg.Procdesc.get_captured pd))
| None -> []) in
let _prop' = Cfg.remove_seed_captured_vars_block block_captured _prop in
let _prop'' = Prop.prop_rename_fav_with_existentials _prop' in
@ -168,15 +159,15 @@ let rec apply_offlist
let ftal, sftal, csu, nameo, supers, def_mthds, iann = match typ' with Sil.Tstruct (ftal, sftal, csu, nameo, supers, def_mthds, iann) -> ftal, sftal, csu, nameo, supers, def_mthds, iann | _ -> assert false in
let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in
try
let _, se' = list_find (fun fse -> Ident.fieldname_equal fld (fst fse)) fsel in
let _, se' = IList.find (fun fse -> Ident.fieldname_equal fld (fst fse)) fsel in
let res_e', res_se', res_t', res_pred_insts_op' =
apply_offlist
footprint_part pdesc tenv p fp_root nullify_struct
(root_lexp, se', t') offlist' f inst lookup_inst in
let replace_fse fse = if Sil.fld_equal fld (fst fse) then (fld, res_se') else fse in
let res_se = Sil.Estruct (list_map replace_fse fsel, inst') in
let res_se = Sil.Estruct (IList.map replace_fse fsel, inst') in
let replace_fta (f, t, a) = if Sil.fld_equal fld f then (fld, res_t', a) else (f, t, a) in
let res_t = Sil.Tstruct (list_map replace_fta ftal, sftal, csu, nameo, supers, def_mthds, iann) in
let res_t = Sil.Tstruct (IList.map replace_fta ftal, sftal, csu, nameo, supers, def_mthds, iann) in
(res_e', res_se, res_t, res_pred_insts_op')
with Not_found ->
pp_error();
@ -194,13 +185,13 @@ let rec apply_offlist
let typ' = Sil.expand_type tenv typ in
let t', size' = match typ' with Sil.Tarray (t', size') -> (t', size') | _ -> assert false in
try
let idx_ese', se' = list_find (fun ese -> Prover.check_equal p nidx (fst ese)) esel in
let idx_ese', se' = IList.find (fun ese -> Prover.check_equal p nidx (fst ese)) esel in
let res_e', res_se', res_t', res_pred_insts_op' =
apply_offlist
footprint_part pdesc tenv p fp_root nullify_struct
(root_lexp, se', t') offlist' f inst lookup_inst in
let replace_ese ese = if Sil.exp_equal idx_ese' (fst ese) then (idx_ese', res_se') else ese in
let res_se = Sil.Earray(size, list_map replace_ese esel, inst1) in
let res_se = Sil.Earray(size, IList.map replace_ese esel, inst1) in
let res_t = Sil.Tarray(res_t', size') 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 *)
@ -269,7 +260,7 @@ let ptsto_update footprint_part pdesc tenv p (lexp, se, typ, st) offlist exp =
let update_iter iter pi sigma =
let iter' = Prop.prop_iter_update_current_by_list iter sigma in
list_fold_left (Prop.prop_iter_add_atom false) iter' pi
IList.fold_left (Prop.prop_iter_add_atom false) iter' pi
let execute_letderef pdesc tenv id rhs_exp acc_in iter =
let iter_ren = Prop.prop_iter_make_id_primed id iter in
@ -293,7 +284,7 @@ let execute_letderef pdesc tenv id rhs_exp acc_in iter =
begin
match pred_insts_op with
| None -> update acc_in ([],[])
| Some pred_insts -> list_rev (list_fold_left update acc_in pred_insts)
| Some pred_insts -> IList.rev (IList.fold_left update acc_in pred_insts)
end
| (Sil.Hpointsto _, _) ->
@ -321,7 +312,7 @@ let execute_set pdesc tenv rhs_exp acc_in iter =
prop' :: acc in
match pred_insts_op with
| None -> update acc_in ([],[])
| Some pred_insts -> list_fold_left update acc_in pred_insts
| Some pred_insts -> IList.fold_left update acc_in pred_insts
(** Module for builtin functions with their symbolic execution handler *)
module Builtin = struct
@ -372,10 +363,10 @@ module Builtin = struct
let pp_registered fmt () =
let builtin_names = ref [] in
Procname.Hash.iter (fun name _ -> builtin_names := name :: !builtin_names) builtin_functions;
builtin_names := list_sort Procname.compare !builtin_names;
builtin_names := IList.sort Procname.compare !builtin_names;
let pp pname = Format.fprintf fmt "%a@\n" Procname.pp pname in
Format.fprintf fmt "Registered builtins:@\n @[";
list_iter pp !builtin_names;
IList.iter pp !builtin_names;
Format.fprintf fmt "@]@."
end
@ -393,10 +384,10 @@ let rec execute_nullify_se = function
| Sil.Eexp _ ->
Sil.Eexp (Sil.exp_zero, Sil.inst_nullify)
| Sil.Estruct (fsel, _) ->
let fsel' = list_map (fun (fld, se) -> (fld, execute_nullify_se se)) fsel in
let fsel' = IList.map (fun (fld, se) -> (fld, execute_nullify_se se)) fsel in
Sil.Estruct (fsel', Sil.inst_nullify)
| Sil.Earray (size, esel, inst) ->
let esel' = list_map (fun (idx, se) -> (idx, execute_nullify_se se)) esel in
let esel' = IList.map (fun (idx, se) -> (idx, execute_nullify_se se)) esel in
Sil.Earray (size, esel', Sil.inst_nullify)
(** Do pruning for conditional [if (e1 != e2) ] if [positive] is true
@ -505,10 +496,10 @@ let prune_prop tenv condition prop =
let dangerous_functions =
let dangerous_list = ["gets"] in
ref ((list_map Procname.from_string_c_fun) dangerous_list)
ref ((IList.map Procname.from_string_c_fun) dangerous_list)
let check_inherently_dangerous_function caller_pname callee_pname =
if list_exists (Procname.equal callee_pname) !dangerous_functions then
if IList.exists (Procname.equal callee_pname) !dangerous_functions then
let exn = Exceptions.Inherently_dangerous_function (Localise.desc_inherently_dangerous_function callee_pname) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop caller_pname) in
Reporting.log_warning caller_pname ~pre: pre_opt exn
@ -580,7 +571,7 @@ let exp_norm_check_arith pname prop exp =
(** Check if [cond] is testing for NULL a pointer already dereferenced *)
let check_already_dereferenced pname cond prop =
let find_hpred lhs =
try Some (list_find (function
try Some (IList.find (function
| Sil.Hpointsto (e, _, _) -> Sil.exp_equal e lhs
| _ -> false) (Prop.get_sigma prop))
with Not_found -> None in
@ -632,7 +623,7 @@ let check_deallocate_static_memory prop_after =
raise (Exceptions.Deallocate_static_memory freed_desc)
| _ -> () in
let exp_att_list = Prop.get_all_attributes prop_after in
list_iter check_deallocated_attribute exp_att_list;
IList.iter check_deallocated_attribute exp_att_list;
prop_after
(** create a copy of a procdesc with a new proc name *)
@ -651,7 +642,7 @@ let proc_desc_copy cfg pdesc pname pname' =
let method_exists right_proc_name methods =
if !Config.curr_language = Config.Java then
list_exists (fun meth_name -> Procname.equal right_proc_name meth_name) methods
IList.exists (fun meth_name -> Procname.equal right_proc_name meth_name) methods
else (* ObjC case *)
Specs.summary_exists right_proc_name
@ -822,7 +813,7 @@ let handle_objc_method_call actual_pars actual_params pre tenv cfg ret_ids pdesc
let propset = prune_ne tenv false receiver Sil.exp_zero pre_with_attr_or_null in
if Propset.is_empty propset then []
else
let prop = list_hd (Propset.to_proplist propset) in
let prop = IList.hd (Propset.to_proplist propset) in
let path = Paths.Path.add_description path path_description in
[(prop, path)] in
res_null @ res
@ -832,8 +823,8 @@ let normalize_params pdesc prop actual_params =
let norm_arg (p, args) (e, t) =
let e', p' = exp_norm_check_arith pdesc p e in
(p', (e', t) :: args) in
let prop, args = list_fold_left norm_arg (prop, []) actual_params in
(prop, list_rev args)
let prop, args = IList.fold_left norm_arg (prop, []) actual_params in
(prop, IList.rev args)
(** Execute [instr] with a symbolic heap [prop].*)
let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
@ -843,14 +834,14 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
State.set_prop_tenv_pdesc _prop tenv pdesc; (* mark prop,tenv,pdesc last seen *)
SymOp.pay(); (* pay one symop *)
let ret_old_path pl = (* return the old path unchanged *)
list_map (fun p -> (p, path)) pl in
IList.map (fun p -> (p, path)) pl in
let instr = match _instr with
| Sil.Call (ret, exp, par, loc, call_flags) ->
let exp' = Prop.exp_normalize_prop _prop exp in
let instr' = match exp' with
| Sil.Const (Sil.Ctuple (e1 :: el)) -> (* closure: combine arguments to call *)
let e1' = Prop.exp_normalize_prop _prop e1 in
let par' = list_map (fun e -> (e, Sil.Tvoid)) el in
let par' = IList.map (fun e -> (e, Sil.Tvoid)) el in
Sil.Call (ret, e1', par' @ par, loc, call_flags)
| _ ->
Sil.Call (ret, exp', par, loc, call_flags) in
@ -870,7 +861,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
let fold_undef_pname callee_opt attr =
if Option.is_none callee_opt && Sil.attr_is_undef attr then Some attr
else callee_opt in
list_fold_left fold_undef_pname None (Prop.get_exp_attributes prop exp) in
IList.fold_left fold_undef_pname None (Prop.get_exp_attributes prop exp) in
let prop' =
if !Config.angelic_execution then
(* when we try to deref an undefined value, add it to the footprint *)
@ -881,8 +872,8 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
else prop in
let iter_list = Rearrange.rearrange pdesc tenv n_rhs_exp' typ prop' loc in
let prop_list =
list_fold_left (execute_letderef pdesc tenv id n_rhs_exp') [] iter_list in
ret_old_path (list_rev prop_list)
IList.fold_left (execute_letderef pdesc tenv id n_rhs_exp') [] iter_list in
ret_old_path (IList.rev prop_list)
with
| Rearrange.ARRAY_ACCESS ->
if (!Config.array_level = 0) then assert false
@ -898,8 +889,8 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
let prop = Prop.replace_objc_null prop n_lhs_exp n_rhs_exp in
let n_lhs_exp' = Prop.exp_collapse_consecutive_indices_prop prop typ n_lhs_exp in
let iter_list = Rearrange.rearrange pdesc tenv n_lhs_exp' typ prop loc in
let prop_list = list_fold_left (execute_set pdesc tenv n_rhs_exp) [] iter_list in
ret_old_path (list_rev prop_list)
let prop_list = IList.fold_left (execute_set pdesc tenv n_rhs_exp) [] iter_list in
ret_old_path (IList.rev prop_list)
with
| Rearrange.ARRAY_ACCESS ->
if (!Config.array_level = 0) then assert false
@ -934,7 +925,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
| Sil.Tvar (Sil.TN_csu (Sil.Class, name)) -> Mangled.to_string name = "NSNumber"
| _ -> false in
let lhs_is_ns_ptr () =
list_exists
IList.exists
(function
| Sil.Hpointsto (_, Sil.Eexp (exp, _), Sil.Sizeof (Sil.Tptr (typ, _), _)) ->
Sil.exp_equal exp lhs_normal && is_nsnumber typ
@ -999,7 +990,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
| Some summary ->
sym_exec_call
cfg pdesc tenv prop path ret_ids n_actual_params summary loc in
list_flatten (list_map do_call sentinel_result)
IList.flatten (IList.map do_call sentinel_result)
| Sil.Call (ret_ids, fun_exp, actual_params, loc, call_flags) -> (** Call via function pointer *)
let (prop_r, n_actual_params) = normalize_params pname _prop actual_params in
if call_flags.Sil.cf_is_objc_block then
@ -1017,7 +1008,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
| Sil.Nullify (pvar, loc, deallocate) ->
begin
let eprop = Prop.expose _prop in
match list_partition
match IList.partition
(function
| Sil.Hpointsto (Sil.Lvar pvar', _, _) -> Sil.pvar_equal pvar pvar'
| _ -> false) (Prop.get_sigma eprop) with
@ -1034,7 +1025,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
| Sil.Abstract loc ->
let node = State.get_node () in
let blocks_nullified = get_nullified_block node in
list_iter (check_block_retain_cycle cfg tenv pname _prop) blocks_nullified;
IList.iter (check_block_retain_cycle cfg tenv pname _prop) blocks_nullified;
if Prover.check_inconsistency _prop
then
ret_old_path []
@ -1049,9 +1040,9 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
let fp_mode = !Config.footprint in
Config.footprint := false; (* no footprint vars for locals *)
let sigma_locals =
list_map
IList.map
(Prop.mk_ptsto_lvar (Some tenv) Prop.Fld_init Sil.inst_initial)
(list_map add_None ptl) in
(IList.map add_None ptl) in
Config.footprint := fp_mode;
sigma_locals in
let sigma' = Prop.get_sigma _prop @ sigma_locals in
@ -1087,8 +1078,8 @@ and sym_exec_generated mask_errors cfg tenv pdesc instrs ppl =
| None -> "") in
L.d_warning ("Generated Instruction Failed with: " ^ (Localise.to_string err_name)^loc ); L.d_ln();
[(p, path)] in
let f plist instr = list_flatten (list_map (exe_instr instr) plist) in
list_fold_left f ppl instrs
let f plist instr = IList.flatten (IList.map (exe_instr instr) plist) in
IList.fold_left f ppl instrs
and add_to_footprint abducted_pv typ prop =
let abducted_lvar = Sil.Lvar abducted_pv in
@ -1113,7 +1104,7 @@ and add_constraints_on_retval pdesc prop exp typ callee_pname callee_loc =
(* introduce a fresh program variable to allow abduction on the return value *)
let abducted_ret_pv = Sil.mk_pvar_abducted_ret callee_pname callee_loc in
let already_has_abducted_retval p =
list_exists
IList.exists
(fun hpred -> match hpred with
| Sil.Hpointsto (Sil.Lvar pv, _, _) -> Sil.pvar_equal pv abducted_ret_pv
| _ -> false)
@ -1133,7 +1124,7 @@ and add_constraints_on_retval pdesc prop exp typ callee_pname callee_loc =
when Sil.pvar_equal pv abducted_pvar ->
Prop.conjoin_eq exp_to_bind rhs prop
| _ -> prop in
list_fold_left bind_exp prop (Prop.get_sigma prop) in
IList.fold_left bind_exp prop (Prop.get_sigma prop) in
(* bind return id to the abducted value pointed to by the pvar we introduced *)
bind_exp_to_abducted_val exp abducted_ret_pv prop
else add_ret_non_null exp typ prop
@ -1142,7 +1133,7 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname callee_lo
(* replace an hpred of the form actual_var |-> _ with new_hpred in prop *)
let replace_actual_hpred actual_var new_hpred prop =
let sigma' =
list_map
IList.map
(function
| Sil.Hpointsto (lhs, _, _) when Sil.exp_equal lhs actual_var -> new_hpred
| hpred -> hpred)
@ -1156,7 +1147,7 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname callee_lo
let abducted_ref_pv =
Sil.mk_pvar_abducted_ref_param callee_pname actual_pv callee_loc in
let already_has_abducted_retval p =
list_exists
IList.exists
(fun hpred -> match hpred with
| Sil.Hpointsto (Sil.Lvar pv, _, _) -> Sil.pvar_equal pv abducted_ref_pv
| _ -> false)
@ -1169,7 +1160,7 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname callee_lo
add_to_footprint abducted_ref_pv (Sil.typ_strip_ptr actual_typ) prop in
(* replace [actual] |-> _ with [actual] |-> [fresh_fp_var] *)
let filtered_sigma =
list_map
IList.map
(function
| Sil.Hpointsto (lhs, _, typ_exp) when Sil.exp_equal lhs actual ->
Sil.Hpointsto (lhs, Sil.Eexp (fresh_fp_var, Sil.Inone), typ_exp)
@ -1180,14 +1171,14 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname callee_lo
(* bind actual passed by ref to the abducted value pointed to by the synthetic pvar *)
let prop' =
let filtered_sigma =
list_filter
IList.filter
(function
| Sil.Hpointsto (lhs, _, typ_exp) when Sil.exp_equal lhs actual ->
false
| _ -> true)
(Prop.get_sigma prop) in
Prop.normalize (Prop.replace_sigma filtered_sigma prop) in
list_fold_left
IList.fold_left
(fun p hpred ->
match hpred with
| Sil.Hpointsto (Sil.Lvar pv, rhs, texp) when Sil.pvar_equal pv abducted_ref_pv ->
@ -1197,7 +1188,7 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname callee_lo
prop'
(Prop.get_sigma prop')
| _ -> assert false in
list_fold_left add_actual_by_ref_to_footprint prop actuals_by_ref
IList.fold_left add_actual_by_ref_to_footprint prop actuals_by_ref
else
(* non-angelic mode; havoc each var passed by reference by assigning it to a fresh id *)
let havoc_actual_by_ref (actual, actual_typ) prop =
@ -1206,7 +1197,7 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname callee_lo
let sizeof_exp = Sil.Sizeof (Sil.typ_strip_ptr actual_typ, Sil.Subtype.subtypes) in
Prop.mk_ptsto actual (Sil.Eexp (havocd_var, Sil.Inone)) sizeof_exp in
replace_actual_hpred actual actual_pt_havocd_var prop in
list_fold_left (fun p var -> havoc_actual_by_ref var p) prop actuals_by_ref
IList.fold_left (fun p var -> havoc_actual_by_ref var p) prop actuals_by_ref
(** execute a call for an unknown or scan function *)
and call_unknown_or_scan is_scan cfg pdesc tenv pre path
@ -1218,10 +1209,10 @@ and call_unknown_or_scan is_scan cfg pdesc tenv pre path
when res_action.Sil.ra_res = Sil.Rfile ->
Prop.remove_attribute res q
| _ -> q in
list_fold_left do_attribute p (Prop.get_exp_attributes p e) in
list_fold_left do_exp prop actual_pars in
IList.fold_left do_attribute p (Prop.get_exp_attributes p e) in
IList.fold_left do_exp prop actual_pars in
let actuals_by_ref =
list_filter
IList.filter
(function
| Sil.Lvar _, _ -> true
| _ -> false)
@ -1238,8 +1229,8 @@ and call_unknown_or_scan is_scan cfg pdesc tenv pre path
else
(* otherwise, add undefined attribute to retvals and actuals passed by ref *)
let exps_to_mark =
let ret_exps = list_map (fun ret_id -> Sil.Var ret_id) ret_ids in
list_fold_left
let ret_exps = IList.map (fun ret_id -> Sil.Var ret_id) ret_ids in
IList.fold_left
(fun exps_to_mark (exp, _) -> exp :: exps_to_mark) ret_exps actuals_by_ref in
let path_pos = State.get_path_pos () in
[(Prop.mark_vars_as_undefined pre''' exps_to_mark callee_pname loc path_pos, path)]
@ -1251,14 +1242,14 @@ and sym_exe_check_variadic_sentinel ?(fails_on_nil = false) cfg pdesc tenv prop
(* useful if you would prefer to not have *any* formal parameters, *)
(* but the language forces you to have at least one. *)
let first_var_arg_pos = if null_pos > n_formals then 0 else n_formals - null_pos in
let nargs = list_length actual_params in
let nargs = IList.length actual_params in
(* sentinels start counting from the last argument to the function *)
let sentinel_pos = nargs - sentinel - 1 in
let mk_non_terminal_argsi (acc, i) a =
if i < first_var_arg_pos || i >= sentinel_pos then (acc, i +1)
else ((a, i):: acc, i +1) in
(* list_fold_left reverses the arguments *)
let non_terminal_argsi = fst (list_fold_left mk_non_terminal_argsi ([], 0) actual_params) in
(* IList.fold_left reverses the arguments *)
let non_terminal_argsi = fst (IList.fold_left mk_non_terminal_argsi ([], 0) actual_params) in
let check_allocated result ((lexp, typ), i) =
(* simulate a Letderef for [lexp] *)
let tmp_id_deref = Ident.create_fresh Ident.kprimed in
@ -1275,9 +1266,9 @@ and sym_exe_check_variadic_sentinel ?(fails_on_nil = false) cfg pdesc tenv prop
(err_desc, try assert false with Assert_failure x -> x))
else
raise e in
(* list_fold_left reverses the arguments back so that we report an *)
(* IList.fold_left reverses the arguments back so that we report an *)
(* error on the first premature nil argument *)
list_fold_left check_allocated [(prop, path)] non_terminal_argsi
IList.fold_left check_allocated [(prop, path)] non_terminal_argsi
and sym_exe_check_variadic_sentinel_if_present
cfg pdesc tenv prop path actual_params callee_pname loc =
@ -1291,7 +1282,7 @@ and sym_exe_check_variadic_sentinel_if_present
| Some sentinel_arg ->
let formals = callee_attributes.ProcAttributes.formals in
sym_exe_check_variadic_sentinel
cfg pdesc tenv prop path (list_length formals)
cfg pdesc tenv prop path (IList.length formals)
actual_params sentinel_arg callee_pname loc
@ -1318,7 +1309,7 @@ and sym_exec_call cfg pdesc tenv pre path ret_ids actual_pars summary loc =
Reporting.log_warning caller_pname ~pre: pre_opt exn in
check_inherently_dangerous_function caller_pname callee_pname;
begin
let formal_types = list_map (fun (_, typ) -> typ) (Specs.get_formals summary) in
let formal_types = IList.map (fun (_, typ) -> typ) (Specs.get_formals summary) in
let rec comb actual_pars formal_types =
match actual_pars, formal_types with
| [], [] -> actual_pars
@ -1331,13 +1322,13 @@ and sym_exec_call cfg pdesc tenv pre path ret_ids actual_pars summary loc =
| _,[] ->
if !Config.developer_mode then Errdesc.warning_err (State.get_loc ()) "likely use of variable-arguments function, or function prototype missing@.";
L.d_warning "likely use of variable-arguments function, or function prototype missing"; L.d_ln();
L.d_str "actual parameters: "; Sil.d_exp_list (list_map fst actual_pars); L.d_ln ();
L.d_str "actual parameters: "; Sil.d_exp_list (IList.map fst actual_pars); L.d_ln ();
L.d_str "formal parameters: "; Sil.d_typ_list formal_types; L.d_ln ();
actual_pars
| [], _ ->
L.d_str ("**** ERROR: Procedure " ^ Procname.to_string callee_pname);
L.d_strln (" mismatch in the number of parameters ****");
L.d_str "actual parameters: "; Sil.d_exp_list (list_map fst actual_pars); L.d_ln ();
L.d_str "actual parameters: "; Sil.d_exp_list (IList.map fst actual_pars); L.d_ln ();
L.d_str "formal parameters: "; Sil.d_typ_list formal_types; L.d_ln ();
raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in
let actual_params = comb actual_pars formal_types in
@ -1366,10 +1357,10 @@ and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t)
Sil.fav_filter_ident fav Ident.is_primed;
let ids_primed = Sil.fav_to_list fav in
let ids_primed_normal =
list_map (fun id -> (id, Ident.create_fresh Ident.knormal)) ids_primed in
let ren_sub = Sil.sub_of_list (list_map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_primed_normal) in
IList.map (fun id -> (id, Ident.create_fresh Ident.knormal)) ids_primed in
let ren_sub = Sil.sub_of_list (IList.map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_primed_normal) in
let p' = Prop.normalize (Prop.prop_sub ren_sub p) in
let fav_normal = Sil.fav_from_list (list_map snd ids_primed_normal) in
let fav_normal = Sil.fav_from_list (IList.map snd ids_primed_normal) in
p', fav_normal in
let prop_normal_to_primed fav_normal p = (* rename given normal vars to fresh primed *)
if Sil.fav_to_list fav_normal = [] then p
@ -1393,7 +1384,7 @@ and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t)
let instr_is_abstraction = function
| Sil.Abstract _ -> true
| _ -> false in
list_exists instr_is_abstraction (Cfg.Node.get_instrs node) in
IList.exists instr_is_abstraction (Cfg.Node.get_instrs node) in
let curr_node = State.get_node () in
match Cfg.Node.get_kind curr_node with
| Cfg.Node.Prune_node _ when not (node_has_abstraction curr_node) ->
@ -1406,10 +1397,10 @@ and sym_exec_wrapper handle_exn cfg tenv pdesc instr ((prop: Prop.normal Prop.t)
let res_list = run_with_abs_val_eq_zero (* no exp abstraction during sym exe *)
(fun () ->
sym_exec cfg tenv pdesc instr prop' path) in
let res_list_nojunk = list_map (fun (p, path) -> (post_process_result fav_normal p path, path)) res_list in
let results = list_map (fun (p, path) -> (Prop.prop_rename_primed_footprint_vars p, path)) res_list_nojunk in
let res_list_nojunk = IList.map (fun (p, path) -> (post_process_result fav_normal p path, path)) res_list in
let results = IList.map (fun (p, path) -> (Prop.prop_rename_primed_footprint_vars p, path)) res_list_nojunk in
L.d_strln "Instruction Returns";
Propgraph.d_proplist prop (list_map fst results); L.d_ln ();
Propgraph.d_proplist prop (IList.map fst results); L.d_ln ();
State.mark_instr_ok ();
Paths.PathSet.from_renamed_list results
with exn when Exceptions.handle_exception exn && !Config.footprint ->
@ -1458,7 +1449,7 @@ let lifted_sym_exec
let pset' = Paths.PathSet.fold (exe_instr_prop instr) pset Paths.PathSet.empty in
(pset', stack) in
let stack = [] in
let pset', stack' = list_fold_left exe_instr_pset (pset, stack) instrs in
let pset', stack' = IList.fold_left exe_instr_pset (pset, stack) instrs in
if stack' != [] then assert false; (* final stack must be empty *)
pset'
@ -1501,13 +1492,13 @@ module ModelBuiltins = struct
let execute___get_array_size cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
: Builtin.ret_typ =
match args with
| [(lexp, typ)] when list_length ret_ids <= 1 ->
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let return_result_for_array_size e prop ret_ids = return_result e prop ret_ids in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
begin
try
let hpred = list_find (function
let hpred = IList.find (function
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in
match hpred with
@ -1540,7 +1531,7 @@ module ModelBuiltins = struct
let n_size, prop = exp_norm_check_arith pname _prop' size in
begin
try
let hpred, sigma' = list_partition (function
let hpred, sigma' = IList.partition (function
| Sil.Hpointsto(e, _, t) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in
match hpred with
@ -1574,7 +1565,7 @@ module ModelBuiltins = struct
let do_arg (lexp, typ) =
let n_lexp, _ = exp_norm_check_arith pname prop lexp in
L.err "%a " (Sil.pp_exp pe_text) n_lexp in
list_iter do_arg args;
IList.iter do_arg args;
L.err "@.";
[(prop, path)]
@ -1588,7 +1579,7 @@ module ModelBuiltins = struct
let create_type tenv n_lexp typ prop =
let prop_type =
try
let _ = list_find (function
let _ = IList.find (function
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in
prop
@ -1626,23 +1617,23 @@ module ModelBuiltins = struct
let sil_is_nonnull = Sil.UnOp(Sil.LNot, sil_is_null, None) in
let null_case = Propset.to_proplist (prune_prop tenv sil_is_null prop) in
let non_null_case = Propset.to_proplist (prune_prop tenv sil_is_nonnull prop_type) in
if ((list_length non_null_case) > 0) && (!Config.footprint) then
if ((IList.length non_null_case) > 0) && (!Config.footprint) then
non_null_case
else if ((list_length non_null_case) > 0) && (is_undefined_opt prop n_lexp) then
else if ((IList.length non_null_case) > 0) && (is_undefined_opt prop n_lexp) then
non_null_case
else null_case@non_null_case
let execute___get_type_of cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
: Builtin.ret_typ =
match args with
| [(lexp, typ)] when list_length ret_ids <= 1 ->
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
let props = create_type tenv n_lexp typ prop in
let aux prop =
begin
try
let hpred = list_find (function
let hpred = IList.find (function
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in
match hpred with
@ -1651,14 +1642,14 @@ module ModelBuiltins = struct
| _ -> assert false
with Not_found -> (return_result Sil.exp_zero prop ret_ids), path
end in
(list_map aux props)
(IList.map aux props)
| _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x))
(** replace the type of the ptsto rooted at [root_e] with [texp] in [prop] *)
let replace_ptsto_texp prop root_e texp =
let process_sigma sigma =
let sigma1, sigma2 =
list_partition (function
IList.partition (function
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e root_e
| _ -> false) sigma in
match sigma1 with
@ -1674,7 +1665,7 @@ module ModelBuiltins = struct
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc instof
: Builtin.ret_typ =
match args with
| [(_val1, typ1); (_texp2, typ2)] when list_length ret_ids <= 1 ->
| [(_val1, typ1); (_texp2, typ2)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let val1, __prop = exp_norm_check_arith pname _prop _val1 in
let texp2, prop = exp_norm_check_arith pname __prop _texp2 in
@ -1684,7 +1675,7 @@ module ModelBuiltins = struct
else
begin
try
let hpred = list_find (function
let hpred = IList.find (function
| Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1
| _ -> false) (Prop.get_sigma prop) in
match hpred with
@ -1731,7 +1722,7 @@ module ModelBuiltins = struct
[(return_result val1 prop ret_ids, path)]
end in
let props = create_type tenv val1 typ1 prop in
list_flatten (list_map exe_one_prop props)
IList.flatten (IList.map exe_one_prop props)
| _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x))
let execute___instanceof cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
@ -1838,7 +1829,7 @@ module ModelBuiltins = struct
| None -> p in
let foot_var = lazy (Sil.Var (Ident.create_fresh Ident.kfootprint)) in
let filter_fld_hidden (f, _ ) = Ident.fieldname_is_hidden f in
let has_fld_hidden fsel = list_exists filter_fld_hidden fsel in
let has_fld_hidden fsel = IList.exists filter_fld_hidden fsel in
let do_hpred in_foot hpred = match hpred with
| Sil.Hpointsto(e, Sil.Estruct (fsel, inst), texp) when Sil.exp_equal e n_lexp && (not (has_fld_hidden fsel)) ->
let foot_e = Lazy.force foot_var in
@ -1848,14 +1839,14 @@ module ModelBuiltins = struct
Sil.Hpointsto(e, Sil.Estruct (fsel', inst), texp)
| Sil.Hpointsto(e, Sil.Estruct (fsel, _), texp) when Sil.exp_equal e n_lexp && not in_foot && has_fld_hidden fsel ->
let set_ret_val () =
match list_find filter_fld_hidden fsel with
match IList.find filter_fld_hidden fsel with
| _, Sil.Eexp(e, _) -> ret_val := Some e
| _ -> () in
set_ret_val();
hpred
| _ -> hpred in
let sigma' = list_map (do_hpred false) (Prop.get_sigma prop) in
let sigma_fp' = list_map (do_hpred true) (Prop.get_sigma_footprint prop) in
let sigma' = IList.map (do_hpred false) (Prop.get_sigma prop) in
let sigma_fp' = IList.map (do_hpred true) (Prop.get_sigma_footprint prop) in
let prop' = Prop.replace_sigma_footprint sigma_fp' (Prop.replace_sigma sigma' prop) in
let prop'' = return_val (Prop.normalize prop') in
[(prop'', path)]
@ -1871,11 +1862,11 @@ module ModelBuiltins = struct
let n_lexp2, prop = exp_norm_check_arith pname _prop1 lexp2 in
let foot_var = lazy (Sil.Var (Ident.create_fresh Ident.kfootprint)) in
let filter_fld_hidden (f, _ ) = Ident.fieldname_is_hidden f in
let has_fld_hidden fsel = list_exists filter_fld_hidden fsel in
let has_fld_hidden fsel = IList.exists filter_fld_hidden fsel in
let do_hpred in_foot hpred = match hpred with
| Sil.Hpointsto(e, Sil.Estruct (fsel, inst), texp) when Sil.exp_equal e n_lexp1 && not in_foot ->
let se = Sil.Eexp(n_lexp2, Sil.inst_none) in
let fsel' = (Ident.fieldname_hidden, se) :: (list_filter (fun x -> not (filter_fld_hidden x)) fsel) in
let fsel' = (Ident.fieldname_hidden, se) :: (IList.filter (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 Sil.exp_equal e n_lexp1 && in_foot && not (has_fld_hidden fsel) ->
let foot_e = Lazy.force foot_var in
@ -1883,8 +1874,8 @@ module ModelBuiltins = struct
let fsel' = (Ident.fieldname_hidden, se) :: fsel in
Sil.Hpointsto(e, Sil.Estruct (fsel', inst), texp)
| _ -> hpred in
let sigma' = list_map (do_hpred false) (Prop.get_sigma prop) in
let sigma_fp' = list_map (do_hpred true) (Prop.get_sigma_footprint prop) in
let sigma' = IList.map (do_hpred false) (Prop.get_sigma prop) in
let sigma_fp' = IList.map (do_hpred true) (Prop.get_sigma_footprint prop) in
let prop' = Prop.replace_sigma_footprint sigma_fp' (Prop.replace_sigma sigma' prop) in
let prop'' = Prop.normalize prop' in
[(prop'', path)]
@ -1893,7 +1884,7 @@ module ModelBuiltins = struct
let execute___state_untainted cfg pdesc instr tenv _prop path ret_ids args callee_name loc
: Builtin.ret_typ =
match args with
| [(lexp, typ)] when list_length ret_ids <= 1 ->
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
(match ret_ids with
| [ret_id] ->
@ -1998,7 +1989,7 @@ module ModelBuiltins = struct
match res with
| (prop, path):: _ ->
(try
let hpred = list_find (function
let hpred = IList.find (function
| Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 exp
| _ -> false) (Prop.get_sigma _prop) in
match hpred with
@ -2010,18 +2001,18 @@ module ModelBuiltins = struct
| _ -> res
with Not_found -> res)
| [] -> res in
list_fold_left call_release [(prop, path)] autoreleased_objects
IList.fold_left call_release [(prop, path)] autoreleased_objects
else execute___no_op _prop path
let execute___objc_cast cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
: Builtin.ret_typ =
match args with
| [(_val1, typ1); (_texp2, typ2)] when list_length ret_ids <= 1 ->
| [(_val1, typ1); (_texp2, typ2)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let val1, __prop = exp_norm_check_arith pname _prop _val1 in
let texp2, prop = exp_norm_check_arith pname __prop _texp2 in
(try
let hpred = list_find (function
let hpred = IList.find (function
| Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1
| _ -> false) (Prop.get_sigma prop) in
match hpred, texp2 with
@ -2061,9 +2052,9 @@ module ModelBuiltins = struct
assert false
| Some _ ->
let prop_list =
list_fold_left (_execute_free tenv mk loc) []
IList.fold_left (_execute_free tenv mk loc) []
(Rearrange.rearrange pdesc tenv lexp typ prop loc) in
list_rev prop_list
IList.rev prop_list
end
with Rearrange.ARRAY_ACCESS ->
if (!Config.array_level = 0) then assert false
@ -2087,10 +2078,10 @@ module ModelBuiltins = struct
Propset.to_proplist (prune_polarity tenv false n_lexp prop) in
let plist =
prop_zero @ (* model: if 0 then skip else _execute_free_nonzero *)
list_flatten (list_map (fun p ->
IList.flatten (IList.map (fun p ->
_execute_free_nonzero mk pdesc tenv instr p path
(Prop.exp_normalize_prop p lexp) typ loc) prop_nonzero) in
list_map (fun p -> (p, path)) plist
IList.map (fun p -> (p, path)) plist
end
| _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x))
@ -2170,9 +2161,9 @@ module ModelBuiltins = struct
skip_n_arguments cfg pdesc instr tenv prop path ret_ids args callee_pname loc
: Builtin.ret_typ =
match args with
| _ when list_length args >= skip_n_arguments ->
| _ when IList.length args >= skip_n_arguments ->
let varargs = ref args in
for i = 1 to skip_n_arguments do varargs := list_tl !varargs done;
for i = 1 to skip_n_arguments do varargs := IList.tl !varargs done;
call_unknown_or_scan true cfg pdesc tenv prop path ret_ids None !varargs callee_pname loc
| _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x))
@ -2214,7 +2205,7 @@ module ModelBuiltins = struct
(let n = Sil.Int.to_int n_sil in
try
let parts = Str.split (Str.regexp_string str2) str1 in
let n_part = list_nth parts n in
let n_part = IList.nth parts n in
let res = Sil.Const (Sil.Cstr n_part) in
[(return_result res prop ret_ids, path)]
with Not_found -> assert false)
@ -2223,7 +2214,7 @@ module ModelBuiltins = struct
let execute___create_tuple cfg pdesc instr tenv prop path ret_ids args callee_pname loc
: Builtin.ret_typ =
let el = list_map fst args in
let el = IList.map fst args in
let res = Sil.Const (Sil.Ctuple el) in
[(return_result res prop ret_ids, path)]
@ -2237,7 +2228,7 @@ module ModelBuiltins = struct
(match n_lexp1, n_lexp2 with
| Sil.Const (Sil.Ctuple el), Sil.Const (Sil.Cint i) ->
let n = Sil.Int.to_int i in
let en = list_nth el n in
let en = IList.nth el n in
[(return_result en prop ret_ids, path)]
| _ -> [(prop, path)])
| _ -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x))
@ -2275,7 +2266,7 @@ module ModelBuiltins = struct
: Builtin.ret_typ =
let error_str =
match args with
| l when list_length l = 4 ->
| l when IList.length l = 4 ->
Config.default_failure_name
| _ ->
raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in

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

@ -89,14 +89,14 @@ let spec_rename_vars pname spec =
| Specs.Jprop.Joined (n, p, jp1, jp2) -> Specs.Jprop.Joined (n, prop_add_callee_suffix p, jp1, jp2) in
let fav = Sil.fav_new () in
Specs.Jprop.fav_add fav spec.Specs.pre;
list_iter (fun (p, path) -> Prop.prop_fav_add fav p) spec.Specs.posts;
IList.iter (fun (p, path) -> Prop.prop_fav_add fav p) spec.Specs.posts;
let ids = Sil.fav_to_list fav in
let ids' = list_map (fun i -> (i, Ident.create_fresh Ident.kprimed)) ids in
let ren_sub = Sil.sub_of_list (list_map (fun (i, i') -> (i, Sil.Var i')) ids') in
let ids' = IList.map (fun i -> (i, Ident.create_fresh Ident.kprimed)) ids in
let ren_sub = Sil.sub_of_list (IList.map (fun (i, i') -> (i, Sil.Var i')) ids') in
let pre' = Specs.Jprop.jprop_sub ren_sub spec.Specs.pre in
let posts' = list_map (fun (p, path) -> (Prop.prop_sub ren_sub p, path)) spec.Specs.posts in
let posts' = IList.map (fun (p, path) -> (Prop.prop_sub ren_sub p, path)) spec.Specs.posts in
let pre'' = jprop_add_callee_suffix pre' in
let posts'' = list_map (fun (p, path) -> (prop_add_callee_suffix p, path)) posts' in
let posts'' = IList.map (fun (p, path) -> (prop_add_callee_suffix p, path)) posts' in
{ Specs.pre = pre''; Specs.posts = posts''; Specs.visited = spec.Specs.visited }
(** Find and number the specs for [proc_name], after renaming their vars, and also return the parameters *)
@ -112,8 +112,8 @@ let spec_find_rename trace_call (proc_name : Procname.t) : (int * Prop.exposed S
raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x))
end;
let formal_parameters =
list_map (fun (x, _) -> Sil.mk_pvar_callee (Mangled.from_string x) proc_name) formals in
list_map f specs, formal_parameters
IList.map (fun (x, _) -> Sil.mk_pvar_callee (Mangled.from_string x) proc_name) formals in
IList.map f specs, formal_parameters
with Not_found -> begin
L.d_strln ("ERROR: found no entry for procedure " ^ Procname.to_string proc_name ^ ". Give up...");
raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x))
@ -130,11 +130,11 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
let rng1 = Sil.sub_range sub1 in
let dom2 = Sil.sub_domain sub2 in
let rng2 = Sil.sub_range sub2 in
let overlap = list_exists (fun id -> list_exists (Ident.equal id) dom1) dom2 in
let overlap = IList.exists (fun id -> IList.exists (Ident.equal id) dom1) dom2 in
if overlap then begin
L.d_str "Dom(Sub1): "; Sil.d_exp_list (list_map (fun id -> Sil.Var id) dom1); L.d_ln ();
L.d_str "Dom(Sub1): "; Sil.d_exp_list (IList.map (fun id -> Sil.Var id) dom1); L.d_ln ();
L.d_str "Ran(Sub1): "; Sil.d_exp_list rng1; L.d_ln ();
L.d_str "Dom(Sub2): "; Sil.d_exp_list (list_map (fun id -> Sil.Var id) dom2); L.d_ln ();
L.d_str "Dom(Sub2): "; Sil.d_exp_list (IList.map (fun id -> Sil.Var id) dom2); L.d_ln ();
L.d_str "Ran(Sub2): "; Sil.d_exp_list rng2; L.d_ln ();
assert false
end in
@ -144,13 +144,13 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
let sub1_inverse =
let sub1_list = Sil.sub_to_list sub1 in
let sub1_list' = list_filter (function (_, Sil.Var _) -> true | _ -> false) sub1_list in
let sub1_inverse_list = list_map (function (id, Sil.Var id') -> (id', Sil.Var id) | _ -> assert false) sub1_list'
let sub1_list' = IList.filter (function (_, Sil.Var _) -> true | _ -> false) sub1_list in
let sub1_inverse_list = IList.map (function (id, Sil.Var id') -> (id', Sil.Var id) | _ -> assert false) sub1_list'
in Sil.sub_of_list_duplicates sub1_inverse_list in
let fav_actual_pre =
let fav_sub2 = (* vars which represent expansions of fields *)
let fav = Sil.fav_new () in
list_iter (Sil.exp_fav_add fav) (Sil.sub_range sub2);
IList.iter (Sil.exp_fav_add fav) (Sil.sub_range sub2);
let filter id = Ident.get_stamp id = - 1 in
Sil.fav_filter_ident fav filter;
fav in
@ -176,7 +176,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
let sub_list = Sil.sub_to_list sub in
let fav_sub_list =
let fav_sub = Sil.fav_new () in
list_iter (fun (_, e) -> Sil.exp_fav_add fav_sub e) sub_list;
IList.iter (fun (_, e) -> Sil.exp_fav_add fav_sub e) sub_list;
Sil.fav_to_list fav_sub in
let sub1 =
let f id =
@ -189,21 +189,21 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
let rng1 = Sil.sub_range sub1 in
let dom2 = Sil.sub_domain sub2 in
let rng2 = Sil.sub_range sub2 in
let vars_actual_pre = list_map (fun id -> Sil.Var id) (Sil.fav_to_list fav_actual_pre) in
let vars_actual_pre = IList.map (fun id -> Sil.Var id) (Sil.fav_to_list fav_actual_pre) in
L.d_str "fav_actual_pre: "; Sil.d_exp_list vars_actual_pre; L.d_ln ();
L.d_str "Dom(Sub1): "; Sil.d_exp_list (list_map (fun id -> Sil.Var id) dom1); L.d_ln ();
L.d_str "Dom(Sub1): "; Sil.d_exp_list (IList.map (fun id -> Sil.Var id) dom1); L.d_ln ();
L.d_str "Ran(Sub1): "; Sil.d_exp_list rng1; L.d_ln ();
L.d_str "Dom(Sub2): "; Sil.d_exp_list (list_map (fun id -> Sil.Var id) dom2); L.d_ln ();
L.d_str "Dom(Sub2): "; Sil.d_exp_list (IList.map (fun id -> Sil.Var id) dom2); L.d_ln ();
L.d_str "Ran(Sub2): "; Sil.d_exp_list rng2; L.d_ln ();
L.d_str "Don't know about id: "; Sil.d_exp (Sil.Var id); L.d_ln ();
assert false;
end
in Sil.sub_of_list (list_map f fav_sub_list) in
in Sil.sub_of_list (IList.map f fav_sub_list) in
let sub2_list =
let f id = (id, Sil.Var (Ident.create_fresh Ident.kfootprint))
in list_map f (Sil.fav_to_list fav_missing_primed) in
in IList.map f (Sil.fav_to_list fav_missing_primed) in
let sub_list' =
list_map (fun (id, e) -> (id, Sil.exp_sub sub1 e)) sub_list in
IList.map (fun (id, e) -> (id, Sil.exp_sub sub1 e)) sub_list in
let sub' = Sil.sub_of_list (sub2_list @ sub_list') in
{ sub = sub'; frame = frame; missing_pi = missing_pi; missing_sigma = missing_sigma; frame_fld = frame_fld; missing_fld = missing_fld; frame_typ = frame_typ; missing_typ = missing_typ }
@ -219,12 +219,12 @@ let rec find_dereference_without_null_check_in_sexp = function
| Sil.Estruct (fsel, inst) ->
let res = find_dereference_without_null_check_in_inst inst in
if res = None then
find_dereference_without_null_check_in_sexp_list (list_map snd fsel)
find_dereference_without_null_check_in_sexp_list (IList.map snd fsel)
else res
| Sil.Earray (_, esel, inst) ->
let res = find_dereference_without_null_check_in_inst inst in
if res = None then
find_dereference_without_null_check_in_sexp_list (list_map snd esel)
find_dereference_without_null_check_in_sexp_list (IList.map snd esel)
else res
and find_dereference_without_null_check_in_sexp_list = function
| [] -> None
@ -276,7 +276,7 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
| Sil.Hpointsto (lexp, se, _) ->
check_dereference (Sil.root_of_lexp lexp) se
| _ -> None in
let deref_err_list = list_fold_left (fun deref_errs hpred -> match check_hpred hpred with
let deref_err_list = IList.fold_left (fun deref_errs hpred -> match check_hpred hpred with
| Some reason -> reason :: deref_errs
| None -> deref_errs
) [] (Prop.get_sigma spec_pre) in
@ -290,7 +290,7 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
(* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *)
Some
(try
list_find
IList.find
(fun err -> match err with
| (Deref_null _, _) -> true
| _ -> false )
@ -301,7 +301,7 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
let post_process_sigma (sigma: Sil.hpred list) loc : Sil.hpred list =
let map_inst inst = Sil.inst_new_loc loc inst in
let do_hpred (_, _, hpred) = Sil.hpred_instmap map_inst hpred in (** update the location of instrumentations *)
list_map (fun hpred -> do_hpred (Prover.expand_hpred_pointer false hpred)) sigma
IList.map (fun hpred -> do_hpred (Prover.expand_hpred_pointer false hpred)) sigma
(** check for interprocedural path errors in the post *)
let check_path_errors_in_post caller_pname post post_path =
@ -319,7 +319,7 @@ let check_path_errors_in_post caller_pname post post_path =
let pre_opt = State.get_normalized_pre (fun te p -> p) (* Abs.abstract_no_symop *) in
Reporting.log_warning caller_pname ~pre: pre_opt exn
| _ -> () in
list_iter check_attr (Prop.get_all_attributes post)
IList.iter check_attr (Prop.get_all_attributes post)
(** Post process the instantiated post after the function call so that
x.f |-> se becomes x |-> \{ f: se \}.
@ -339,7 +339,7 @@ let post_process_post
Sil.Aneq (e, c)
| a -> a in
let prop' = Prop.replace_sigma (post_process_sigma (Prop.get_sigma post) loc) post in
let pi' = list_map atom_update_alloc_attribute (Prop.get_pi prop') in (* update alloc attributes to refer to the caller *)
let pi' = IList.map atom_update_alloc_attribute (Prop.get_pi prop') in (* update alloc attributes to refer to the caller *)
let post' = Prop.replace_pi pi' prop' in
check_path_errors_in_post caller_pname post' post_path;
post', post_path
@ -360,9 +360,9 @@ let rec sexp_set_inst inst = function
| Sil.Eexp (e, _) ->
Sil.Eexp (e, inst)
| Sil.Estruct (fsel, _) ->
Sil.Estruct ((list_map (fun (f, se) -> (f, sexp_set_inst inst se)) fsel), inst)
Sil.Estruct ((IList.map (fun (f, se) -> (f, sexp_set_inst inst se)) fsel), inst)
| Sil.Earray (size, esel, _) ->
Sil.Earray (size, list_map (fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst)
Sil.Earray (size, IList.map (fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst)
let rec fsel_star_fld fsel1 fsel2 = match fsel1, fsel2 with
| [], fsel2 -> fsel2
@ -379,7 +379,7 @@ and array_content_star se1 se2 =
and esel_star_fld esel1 esel2 = match esel1, esel2 with
| [], esel2 -> (* don't know whether element is read or written in fun call with array *)
list_map (fun (e, se) -> (e, sexp_set_inst Sil.Inone se)) esel2
IList.map (fun (e, se) -> (e, sexp_set_inst Sil.Inone se)) esel2
| esel1,[] -> esel1
| (e1, se1):: esel1', (e2, se2):: esel2' ->
(match Sil.exp_compare e1 e2 with
@ -432,8 +432,8 @@ let hpred_star_fld (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred =
(** Implementation of [*] for the field-splitting model *)
let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpred list =
let sigma1 = list_stable_sort hpred_lhs_compare sigma1 in
let sigma2 = list_stable_sort hpred_lhs_compare sigma2 in
let sigma1 = IList.stable_sort hpred_lhs_compare sigma1 in
let sigma2 = IList.stable_sort hpred_lhs_compare sigma2 in
(* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *)
let rec star sg1 sg2 : Sil.hpred list =
match sg1, sg2 with
@ -468,8 +468,8 @@ let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Sil.exp * Sil.exp) lis
if !Config.Experiment.activate_subtyping_in_cpp || !Config.curr_language = Config.Java then
begin
let typing_lhs_compare (e1, _) (e2, _) = Sil.exp_compare e1 e2 in
let sigma1 = list_stable_sort hpred_lhs_compare sigma1 in
let typings2 = list_stable_sort typing_lhs_compare typings2 in
let sigma1 = IList.stable_sort hpred_lhs_compare sigma1 in
let typings2 = IList.stable_sort typing_lhs_compare typings2 in
let rec star sg1 typ2 : Sil.hpred list =
match sg1, typ2 with
| [], _ -> []
@ -538,11 +538,11 @@ let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with
let prop_copy_footprint_pure p1 p2 =
let p2' = Prop.replace_sigma_footprint (Prop.get_sigma_footprint p1) (Prop.replace_pi_footprint (Prop.get_pi_footprint p1) p2) in
let pi2 = Prop.get_pi p2' in
let pi2_attr, pi2_noattr = list_partition Prop.atom_is_attribute pi2 in
let pi2_attr, pi2_noattr = IList.partition Prop.atom_is_attribute pi2 in
let res_noattr = Prop.replace_pi (Prop.get_pure p1 @ pi2_noattr) p2' in
let replace_attr prop atom = (* call replace_atom_attribute which deals with existing attibutes *)
Prop.replace_atom_attribute check_attr_dealloc_mismatch prop atom in
list_fold_left replace_attr (Prop.normalize res_noattr) pi2_attr
IList.fold_left replace_attr (Prop.normalize res_noattr) pi2_attr
(** check if an expression is an exception *)
let exp_is_exn = function
@ -556,7 +556,7 @@ let prop_is_exn pname prop =
| Sil.Hpointsto (e1, Sil.Eexp(e2, _), _) when Sil.exp_equal e1 ret_pvar ->
exp_is_exn e2
| _ -> false in
list_exists is_exn (Prop.get_sigma prop)
IList.exists is_exn (Prop.get_sigma prop)
(** when prop is an exception, return the exception name *)
let prop_get_exn_name pname prop =
@ -567,13 +567,13 @@ let prop_get_exn_name pname prop =
| Sil.Hpointsto (e1, _, Sil.Sizeof(Sil.Tstruct (_, _, _, Some name, _, _, _), _)) when Sil.exp_equal e1 e ->
exn_name := name
| _ -> () in
list_iter do_hpred (Prop.get_sigma prop) in
IList.iter do_hpred (Prop.get_sigma prop) in
let find_ret () =
let do_hpred = function
| Sil.Hpointsto (e1, Sil.Eexp(Sil.Const (Sil.Cexn e2), _), _) when Sil.exp_equal e1 ret_pvar ->
find_exn_name e2
| _ -> () in
list_iter do_hpred (Prop.get_sigma prop) in
IList.iter do_hpred (Prop.get_sigma prop) in
find_ret ();
!exn_name
@ -593,7 +593,7 @@ let prop_set_exn pname prop se_exn =
| Sil.Hpointsto (e, _, t) when Sil.exp_equal e ret_pvar ->
Sil.Hpointsto(e, se_exn, t)
| hpred -> hpred in
let sigma' = list_map map_hpred (Prop.get_sigma prop) in
let sigma' = IList.map map_hpred (Prop.get_sigma prop) in
Prop.normalize (Prop.replace_sigma sigma' prop)
(** Include a subtrace for a procedure call if the callee is not a model. *)
@ -609,8 +609,8 @@ let combine
let new_footprint_pi = Prop.pi_sub split.sub split.missing_pi in
let new_footprint_sigma = Prop.sigma_sub split.sub split.missing_sigma in
let new_frame_fld = Prop.sigma_sub split.sub split.frame_fld in
let new_frame_typ = list_map (fun (e, te) -> Sil.exp_sub split.sub e, Sil.exp_sub split.sub te) split.frame_typ in
let new_missing_typ = list_map (fun (e, te) -> Sil.exp_sub split.sub e, Sil.exp_sub split.sub te) split.missing_typ in
let new_frame_typ = IList.map (fun (e, te) -> Sil.exp_sub split.sub e, Sil.exp_sub split.sub te) split.frame_typ in
let new_missing_typ = IList.map (fun (e, te) -> Sil.exp_sub split.sub e, Sil.exp_sub split.sub te) split.missing_typ in
let new_missing_fld =
let sigma = Prop.sigma_sub split.sub split.missing_fld in
let filter hpred =
@ -625,7 +625,7 @@ let combine
| _ ->
L.d_warning "Missing fields in complex pred: "; Sil.d_hpred hpred; L.d_ln ();
false in
list_filter filter sigma in
IList.filter filter sigma in
let instantiated_frame = Prop.sigma_sub split.sub split.frame in
let instantiated_post =
let posts' =
@ -634,7 +634,7 @@ let combine
(* with updated footprint and inconsistent current *)
[(Prop.replace_pi [Sil.Aneq (Sil.exp_zero, Sil.exp_zero)] Prop.prop_emp, path_pre)]
else
list_map
IList.map
(fun (p, path_post) ->
(p,
Paths.Path.add_call
@ -643,7 +643,7 @@ let combine
callee_pname
path_post))
posts in
list_map
IList.map
(fun (p, path) ->
(post_process_post
caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path)))
@ -655,7 +655,7 @@ let combine
L.d_strln "Missing fld:"; Prop.d_sigma new_missing_fld; L.d_ln ();
if new_frame_typ <> [] then L.d_strln "Missing typ:"; Prover.d_typings new_missing_typ; L.d_ln ();
L.d_strln "Instantiated frame:"; Prop.d_sigma instantiated_frame; L.d_ln ();
L.d_strln "Instantiated post:"; Propgraph.d_proplist Prop.prop_emp (list_map fst instantiated_post);
L.d_strln "Instantiated post:"; Propgraph.d_proplist Prop.prop_emp (IList.map fst instantiated_post);
L.d_decrease_indent 1; L.d_ln ();
let compute_result post_p =
let post_p' =
@ -670,7 +670,7 @@ let combine
| Sil.Aeq (Sil.Var id', Sil.Const (Sil.Cint i)) ->
Ident.equal id id' && Sil.Int.isnull i
| _ -> false in
list_exists filter new_footprint_pi in
IList.exists filter new_footprint_pi in
let f (e, inst_opt) = match e, inst_opt with
| Sil.Var id, Some inst when id_assigned_to_null id ->
let inst' = Sil.inst_set_null_case_flag inst in
@ -700,11 +700,11 @@ let combine
| Sil.Hpointsto (e, Sil.Eexp (e', inst), t) when exp_is_exn e' -> (* resuls is an exception: set in caller *)
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
prop_set_exn caller_pname p (Sil.Eexp (e', inst))
| Sil.Hpointsto (e, Sil.Eexp (e', inst), t) when list_length ret_ids = 1 ->
| Sil.Hpointsto (e, Sil.Eexp (e', inst), t) when IList.length ret_ids = 1 ->
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
Prop.conjoin_eq e' (Sil.Var (list_hd ret_ids)) p
Prop.conjoin_eq e' (Sil.Var (IList.hd ret_ids)) p
| Sil.Hpointsto (e, Sil.Estruct (ftl, _), t)
when list_length ftl = list_length ret_ids ->
when IList.length ftl = IList.length ret_ids ->
let rec do_ftl_ids p = function
| [], [] -> p
| (f, Sil.Eexp (e', inst')):: ftl', ret_id:: ret_ids' ->
@ -722,12 +722,12 @@ let combine
prop_footprint_add_pi_sigma_starfld_sigma post_p3 new_footprint_pi new_footprint_sigma new_missing_fld new_missing_typ
else Some post_p3 in
post_p4 in
let _results = list_map (fun (p, path) -> (compute_result p, path)) instantiated_post in
if list_exists (fun (x, _) -> x = None) _results then (* at least one combine failed *)
let _results = IList.map (fun (p, path) -> (compute_result p, path)) instantiated_post in
if IList.exists (fun (x, _) -> x = None) _results then (* at least one combine failed *)
None
else
let results = list_map (function (Some x, path) -> (x, path) | (None, _) -> assert false) _results in
print_results actual_pre (list_map fst results);
let results = IList.map (function (Some x, path) -> (x, path) | (None, _) -> assert false) _results in
print_results actual_pre (IList.map fst results);
Some results
(** Construct the actual precondition: add to the current state a copy
@ -739,14 +739,14 @@ let mk_actual_precondition prop actual_params formal_params =
| f:: fpars', a:: apars' -> (f, a) :: comb fpars' apars'
| [], _ ->
if apars != [] then
(let str = "more actual pars than formal pars in fun call (" ^ string_of_int (list_length actual_params) ^ " vs " ^ string_of_int (list_length formal_params) ^ ")" in
(let str = "more actual pars than formal pars in fun call (" ^ string_of_int (IList.length actual_params) ^ " vs " ^ string_of_int (IList.length formal_params) ^ ")" in
L.d_warning str; L.d_ln ());
[]
| _:: _,[] -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in
comb formal_params actual_params in
let mk_instantiation (formal_var, (actual_e, actual_t)) =
Prop.mk_ptsto (Sil.Lvar formal_var) (Sil.Eexp (actual_e, Sil.inst_actual_precondition)) (Sil.Sizeof (actual_t, Sil.Subtype.exact)) in
let instantiated_formals = list_map mk_instantiation formals_actuals in
let instantiated_formals = IList.map mk_instantiation formals_actuals in
let actual_pre = Prop.prop_sigma_star prop instantiated_formals in
Prop.normalize actual_pre
@ -757,7 +757,7 @@ let inconsistent_actualpre_missing actual_pre split_opt =
let norm_missing_pi = Prop.pi_sub split.sub split.missing_pi in
let norm_missing_sigma = Prop.sigma_sub split.sub split.missing_sigma in
let prop'= Prop.normalize (Prop.prop_sigma_star actual_pre norm_missing_sigma) in
let prop''= list_fold_left Prop.prop_atom_and prop' norm_missing_pi in
let prop''= IList.fold_left Prop.prop_atom_and prop' norm_missing_pi in
Prover.check_inconsistency prop''
| None -> false
@ -780,7 +780,7 @@ let do_taint_check caller_pname actual_pre missing_pi missing_sigma sub1 sub2 =
let rec intersection_taint_untaint taint untaint = (* note: return the first element in the intersection*)
match taint with
| [] -> None
| e:: taint' -> if (list_exists (fun e' -> Sil.exp_equal e e') untaint) then (Some e)
| e:: taint' -> if (IList.exists (fun e' -> Sil.exp_equal e e') untaint) then (Some e)
else intersection_taint_untaint taint' untaint in
let augmented_actual_pre = Prop.replace_pi ((Prop.get_pi actual_pre) @ missing_pi) actual_pre in
let augmented_actual_pre = Prop.replace_sigma ((Prop.get_sigma actual_pre) @ missing_sigma) augmented_actual_pre in
@ -819,7 +819,7 @@ let get_check_exn check callee_pname loc ml_location = match check with
class_cast_exn (Some callee_pname) texp1 texp2 exp ml_location
let check_uninitialize_dangling_deref callee_pname actual_pre sub formal_params props =
list_iter (fun (p, _ ) ->
IList.iter (fun (p, _ ) ->
match check_dereferences callee_pname actual_pre sub p formal_params with
| Some (Deref_undef_exp, desc) ->
raise (Exceptions.Dangling_pointer_dereference (Some Sil.DAuninit, desc, try assert false with Assert_failure x -> x))
@ -838,7 +838,7 @@ let exe_spec
meant to eliminate false NPE warnings from the common "if (get() != null) get().something()"
pattern *)
let last_call_ret_non_null =
list_exists
IList.exists
(fun (exp, attr) ->
match attr with
| Sil.Aretval pname when Procname.equal callee_pname pname ->
@ -847,13 +847,13 @@ let exe_spec
(Prop.get_all_attributes prop) in
if last_call_ret_non_null then
let returns_null prop =
list_exists
IList.exists
(function
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (e, _), _) when Sil.pvar_is_return pvar ->
Prover.check_equal (Prop.normalize prop) e Sil.exp_zero
| _ -> false)
(Prop.get_sigma prop) in
list_filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts
IList.filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts
else spec.Specs.posts
| _ -> spec.Specs.posts in
let actual_pre = mk_actual_precondition prop actual_params formal_params in
@ -886,7 +886,7 @@ let exe_spec
(* After combining we check that we have not added a points-to of initialized variables.*)
check_uninitialize_dangling_deref callee_pname actual_pre split.sub formal_params results;
let inconsistent_results, consistent_results =
list_partition (fun (p, _) -> Prover.check_inconsistency p) results in
IList.partition (fun (p, _) -> Prover.check_inconsistency p) results in
let incons_pre_missing = inconsistent_actualpre_missing actual_pre (Some split) in
Valid_res { incons_pre_missing = incons_pre_missing;
vr_pi = norm_missing_pi;
@ -894,7 +894,7 @@ let exe_spec
vr_cons_res = consistent_results;
vr_incons_res = inconsistent_results } in
begin
list_iter log_check_exn checks;
IList.iter log_check_exn checks;
if (!Config.taint_analysis && !Config.developer_mode) then
do_taint_check caller_pname actual_pre missing_pi missing_sigma sub1 sub2;
let subbed_pre = (Prop.prop_sub sub1 actual_pre) in
@ -919,7 +919,7 @@ let exe_spec
| _ -> false in
(* missing fields minus hidden fields *)
let missing_fld_nohidden =
list_filter (fun hp -> not (hpred_missing_hidden hp)) missing_fld in
IList.filter (fun hp -> not (hpred_missing_hidden hp)) missing_fld in
if !Config.footprint = false && norm_missing_sigma != [] then
begin
L.d_strln "Implication error: missing_sigma not empty in re-execution";
@ -937,8 +937,8 @@ let remove_constant_string_class prop =
let filter = function
| Sil.Hpointsto (Sil.Const (Sil.Cstr _ | Sil.Cclass _), _, _) -> false
| _ -> true in
let sigma = list_filter filter (Prop.get_sigma prop) in
let sigmafp = list_filter filter (Prop.get_sigma_footprint prop) in
let sigma = IList.filter filter (Prop.get_sigma prop) in
let sigmafp = IList.filter filter (Prop.get_sigma_footprint prop) in
let prop' = Prop.replace_sigma_footprint sigmafp (Prop.replace_sigma sigma prop) in
Prop.normalize prop'
@ -957,7 +957,7 @@ let prop_pure_to_footprint (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 = list_filter is_footprint_atom_not_attribute pure in
let new_footprint_atoms = IList.filter is_footprint_atom_not_attribute pure in
if new_footprint_atoms == []
then p
else (** add pure fact to footprint *)
@ -969,7 +969,7 @@ let sigma_has_null_pointer sigma =
| Sil.Hpointsto (e, _, _) ->
Sil.exp_equal e Sil.exp_zero
| _ -> false in
list_exists hpred_null_pointer sigma
IList.exists hpred_null_pointer sigma
(** post-process the raw result of a function call *)
let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop results =
@ -977,16 +977,16 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
| Invalid_res _ -> false
| Valid_res _ -> true in
let valid_res0, invalid_res0 =
list_partition filter_valid_res results in
IList.partition filter_valid_res results in
let valid_res =
list_map (function Valid_res cr -> cr | Invalid_res _ -> assert false) valid_res0 in
IList.map (function Valid_res cr -> cr | Invalid_res _ -> assert false) valid_res0 in
let invalid_res =
list_map (function Valid_res cr -> assert false | Invalid_res ir -> ir) invalid_res0 in
IList.map (function Valid_res cr -> assert false | Invalid_res ir -> ir) invalid_res0 in
let valid_res_miss_pi, valid_res_no_miss_pi =
list_partition (fun vr -> vr.vr_pi != []) valid_res in
IList.partition (fun vr -> vr.vr_pi != []) valid_res in
let valid_res_incons_pre_missing, valid_res_cons_pre_missing =
list_partition (fun vr -> vr.incons_pre_missing) valid_res in
let deref_errors = list_filter (function Dereference_error _ -> true | _ -> false) invalid_res in
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 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
@ -1002,7 +1002,7 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
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 list_hd deref_errors with
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;
@ -1032,9 +1032,9 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
assert false
else (* no dereference error detected *)
let desc =
if list_exists (function Cannot_combine -> true | _ -> false) invalid_res then
if IList.exists (function Cannot_combine -> true | _ -> false) invalid_res then
call_desc (Some Localise.Pnm_dangling)
else if list_exists (function
else if IList.exists (function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn check callee_pname loc (try assert false with Assert_failure x -> x) in
@ -1049,36 +1049,36 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
let process_valid_res vr =
let save_diverging_states () =
if not vr.incons_pre_missing && vr.vr_cons_res = [] then (* no consistent results on one spec: divergence *)
let incons_res = list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in
let incons_res = IList.map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in
State.add_diverging_states (Paths.PathSet.from_renamed_list incons_res) in
save_diverging_states ();
vr.vr_cons_res in
list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) (list_flatten (list_map process_valid_res valid_res))
IList.map (fun (p, path) -> (prop_pure_to_footprint p, path)) (IList.flatten (IList.map process_valid_res valid_res))
end
else if valid_res_no_miss_pi != [] then
list_flatten (list_map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
IList.flatten (IList.map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
else if valid_res_miss_pi == [] then
raise (Exceptions.Precondition_not_met (call_desc None, try assert false with Assert_failure x -> x))
else
begin
L.d_strln "Missing pure facts for the function call:";
list_iter print_pi (list_map (fun vr -> vr.vr_pi) valid_res_miss_pi);
match Prover.find_minimum_pure_cover (list_map (fun vr -> (vr.vr_pi, vr.vr_cons_res)) valid_res_miss_pi) with
IList.iter print_pi (IList.map (fun vr -> vr.vr_pi) valid_res_miss_pi);
match Prover.find_minimum_pure_cover (IList.map (fun vr -> (vr.vr_pi, vr.vr_cons_res)) valid_res_miss_pi) with
| None ->
trace_call Specs.CallStats.CR_not_met;
raise (Exceptions.Precondition_not_met (call_desc None, try assert false with Assert_failure x -> x))
| Some cover ->
L.d_strln "Found minimum cover";
list_iter print_pi (list_map fst cover);
list_flatten (list_map snd cover)
IList.iter print_pi (IList.map fst cover);
IList.flatten (IList.map snd cover)
end in
trace_call Specs.CallStats.CR_success;
let res =
list_map
IList.map
(fun (p, path) -> (quantify_path_idents_remove_constant_strings p, path))
res_with_path_idents in
let should_add_ret_attr _ =
let is_likely_getter pn = list_length (Procname.java_get_parameters pn) = 0 in
let is_likely_getter pn = IList.length (Procname.java_get_parameters pn) = 0 in
!Config.idempotent_getters &&
!Config.curr_language = Config.Java &&
is_likely_getter callee_pname in
@ -1089,7 +1089,7 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
let mark_id_as_retval (p, path) =
let att_retval = Sil.Aretval callee_pname in
Prop.set_exp_attribute p ret_var att_retval, path in
list_map mark_id_as_retval res
IList.map mark_id_as_retval res
| _ -> res
(** Execute the function call and return the list of results with return value *)
@ -1102,10 +1102,10 @@ let exe_function_call tenv cfg ret_ids caller_pdesc callee_pname loc actual_para
Specs.CallStats.trace
summary.Specs.stats.Specs.call_stats callee_pname loc res !Config.footprint in
let spec_list, formal_params = spec_find_rename trace_call callee_pname in
let nspecs = list_length spec_list in
let nspecs = IList.length spec_list in
L.d_strln ("Found " ^ string_of_int nspecs ^ " specs for function " ^ Procname.to_string callee_pname);
L.d_strln ("START EXECUTING SPECS FOR " ^ Procname.to_string callee_pname ^ " from state");
Prop.d_prop prop; L.d_ln ();
let exe_one_spec (n, spec) = exe_spec tenv cfg ret_ids (n, nspecs) caller_pdesc callee_pname loc prop path spec actual_params formal_params in
let results = list_map exe_one_spec spec_list in
let results = IList.map exe_one_spec spec_list in
exe_call_postprocess tenv ret_ids trace_call callee_pname loc prop results

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

@ -62,8 +62,8 @@ module Control_flow =
let new_set_items' = items @ new_set_items in
let todo' =
if (TM.save_items_to_set) then
let new_set_items'' = list_map TM.to_t new_set_items' in
list_fold_right add_to_todo new_set_items'' todo
let new_set_items'' = IList.map TM.to_t new_set_items' in
IList.fold_right add_to_todo new_set_items'' todo
else todo in
let items =
if (TM.save_items_to_set) then []
@ -123,7 +123,7 @@ struct
module TypeSet = Set.Make(struct
type t = type_signature
let compare = Utils.list_compare pair_compare
let compare = IList.compare pair_compare
end)
let map_value_to_string set =
@ -177,8 +177,8 @@ struct
| VarBasic
let path_equal p1 p2 =
if (list_length p1) != (list_length p2) then false
else list_for_all2 (fun el1 el2 -> Ident.fieldname_equal el1 el2) p1 p2
if (IList.length p1) != (IList.length p2) then false
else IList.for_all2 (fun el1 el2 -> Ident.fieldname_equal el1 el2) p1 p2
let typ_to_var_kind typ =
match typ with
@ -279,7 +279,7 @@ struct
let varname = Mangled.from_string name in
let pvar = Sil.mk_pvar varname pname in
add_type pvar typ 0 context in
list_fold_left aux context type_signature
IList.fold_left aux context type_signature
(* Returns the top type of a variable in the context *)
let get_type pvar context =
@ -432,7 +432,7 @@ struct
match ityp with
| Sil.Tstruct (fields, sftal, csu, nameo, supers, def_mthds, iann) ->
let (_, typ, _) =
try ((list_find (fun (f, t, _) -> Ident.fieldname_equal f field)) fields)
try ((IList.find (fun (f, t, _) -> Ident.fieldname_equal f field)) fields)
with Not_found -> assert false in
typ
| _ -> assert false
@ -486,16 +486,16 @@ struct
(* print_endline "backtracking..."; *)
let preds = Cfg.Node.get_preds old_node in
let pred =
try list_find (fun p -> not (Set.mem p set)) preds
try IList.find (fun p -> not (Set.mem p set)) preds
with Not_found ->
try list_hd preds
try IList.hd preds
with Failure "hd" -> Set.min_elt set in
(aux pred) in
if (Set.mem old_node set) then backtrack ()
else
let succs = Cfg.Node.get_succs old_node in
let node =
try list_find (fun n -> ( Set.mem n set)) succs
try IList.find (fun n -> ( Set.mem n set)) succs
with Not_found -> backtrack () in
node in
match el with
@ -562,7 +562,7 @@ struct
let formals = Cfg.Procdesc.get_formals pdesc in
let create_typ_bundle (exp, typ) (name, typ2) =
(name, (get_type tenv exp id_context context field_context)) in
let typ_bundle = list_map2 create_typ_bundle actual_params formals in
let typ_bundle = IList.map2 create_typ_bundle actual_params formals in
let set = Type_map.find_dyn_types callee_pname map in
if Type_map.TypeSet.mem typ_bundle set
then id_context, context, field_context, map, list
@ -594,7 +594,7 @@ struct
| _ -> id_context, context, field_context, map, list in
let instrs = Cfg.Node.get_instrs node in
let id_context, context, field_context, map, items =
list_fold_left aux (IdContext.empty, context, field_context, map, []) instrs in
IList.fold_left aux (IdContext.empty, context, field_context, map, []) instrs in
context, field_context, map, items
end
@ -709,9 +709,9 @@ let arg_desc =
let base_arg =
let options_to_keep = ["-results_dir"] in
let filter arg_desc =
list_filter (fun desc ->
IList.filter (fun desc ->
let (option_name, _, _, _) = desc in
list_mem string_equal option_name options_to_keep)
IList.mem string_equal option_name options_to_keep)
arg_desc in
let desc = (filter Utils.base_arg_desc) in
Utils.Arg2.create_options_desc false "Parsing Options" desc in
@ -732,7 +732,7 @@ let initialize_map exe_env methods =
initial_methods := Procname.Set.add pname !initial_methods;
Type_map.add_to_map pname formals map in
let meth_list = Procname.Set.elements methods in
let map' = (list_fold_right (init_method exe_env) meth_list Type_map.Map.empty) in
let map' = (IList.fold_right (init_method exe_env) meth_list Type_map.Map.empty) in
map'
(* Collects all the methods that are defined in the program. *)
@ -747,8 +747,8 @@ let collect_methods exe_env =
if Cg.node_defined global_cg n1 && Cg.node_defined global_cg n2 then
Procname.Set.add n2 no_main_methods
else no_main_methods in
let defined = list_fold_right do_node nodes Procname.Set.empty in
let no_main_methods = list_fold_right do_edge edges Procname.Set.empty in
let defined = IList.fold_right do_node nodes Procname.Set.empty in
let no_main_methods = IList.fold_right do_edge edges Procname.Set.empty in
let main_methods = Procname.Set.diff defined no_main_methods in
defined_methods := defined;
(* TM.set_to_string main_methods; *)
@ -772,7 +772,7 @@ let load_cg_files _exe_env (source_dirs : DB.source_dir list) =
| None -> ()
| Some cg ->
(*L.err "loaded %s@." (DB.source_dir_to_string source_dir) *) () in
list_iter (fun source_dir -> load_cg_file _exe_env source_dir) source_dirs;
IList.iter (fun source_dir -> load_cg_file _exe_env source_dir) source_dirs;
let exe_env = Exe_env.freeze _exe_env in
exe_env

211
infer/src/backend/utils.ml
Unescape View File

@ -12,6 +12,10 @@
module F = Format
(** List police: don't use the list module to avoid non-tail recursive
functions and builtin equality. Use IList instead. *)
module List = struct end
(** initial time of the analysis, i.e. when this module is loaded, gotten from Unix.time *)
let initial_analysis_time = Unix.time ()
@ -56,185 +60,6 @@ let triple_compare compare compare' compare'' (x1, y1, z1) (x2, y2, z2) =
if n <> 0 then n else let n = compare' y1 y2 in
if n <> 0 then n else compare'' z1 z2
let list_exists = List.exists
let list_filter = List.filter
let list_find = List.find
let list_fold_left = List.fold_left
let list_fold_left2 = List.fold_left2
let list_for_all = List.for_all
let list_for_all2 = List.for_all2
let list_hd = List.hd
let list_iter = List.iter
let list_iter2 = List.iter2
let list_length = List.length
let list_nth = List.nth
let list_partition = List.partition
let list_rev = List.rev
let list_rev_append = List.rev_append
let list_rev_map = List.rev_map
let list_sort = List.sort
let list_stable_sort = List.stable_sort
let list_tl = List.tl
(** tail-recursive variant of List.fold_right *)
let list_fold_right f l a =
let g x y = f y x in
list_fold_left g a (list_rev l)
(** tail-recursive variant of List.combine *)
let list_combine =
let rec combine acc l1 l2 = match l1, l2 with
| [], [] -> acc
| x1:: l1, x2:: l2 -> combine ((x1, x2):: acc) l1 l2
| [], _:: _
| _:: _, [] -> raise (Invalid_argument "list_combine") in
fun l1 l2 -> list_rev (combine [] l1 l2)
(** tail-recursive variant of List.split *)
let list_split =
let rec split acc1 acc2 = function
| [] -> (acc1, acc2)
| (x, y):: l -> split (x:: acc1) (y:: acc2) l in
fun l ->
let acc1, acc2 = split [] [] l in
list_rev acc1, list_rev acc2
(** Like List.mem but without builtin equality *)
let list_mem equal x l = list_exists (equal x) l
(** tail-recursive variant of List.flatten *)
let list_flatten =
let rec flatten acc l = match l with
| [] -> acc
| x:: l' -> flatten (list_rev_append x acc) l' in
fun l -> list_rev (flatten [] l)
let list_flatten_options list =
list_fold_left (fun list -> function | Some x -> x:: list | None -> list) [] list
|> list_rev
let rec list_drop_first n = function
| xs when n == 0 -> xs
| x:: xs -> list_drop_first (n - 1) xs
| [] -> []
let list_drop_last n list =
list_rev (list_drop_first n (list_rev list))
(** List police: don't use the list module to avoid non-tail recursive functions and builtin equality *)
module List = struct end
(** Generic comparison of lists given a compare function for the elements of the list *)
let rec list_compare compare l1 l2 =
match l1, l2 with
| [],[] -> 0
| [], _ -> - 1
| _, [] -> 1
| x1:: l1', x2:: l2' ->
let n = compare x1 x2 in
if n <> 0 then n else list_compare compare l1' l2'
(** Generic equality of lists given a compare function for the elements of the list *)
let list_equal compare l1 l2 =
list_compare compare l1 l2 = 0
(** Returns (reverse input_list) *)
let rec list_rev_with_acc acc = function
| [] -> acc
| x :: xs -> list_rev_with_acc (x:: acc) xs
(** tail-recursive variant of List.append *)
let list_append l1 l2 =
list_rev_append (list_rev l1) l2
(** tail-recursive variant of List.map *)
let list_map f l =
list_rev (list_rev_map f l)
(** Remove consecutive equal elements from a list (according to the given comparison functions) *)
let list_remove_duplicates compare l =
let rec remove compare acc = function
| [] -> list_rev acc
| [x] -> list_rev (x:: acc)
| x:: ((y:: l'') as l') ->
if compare x y = 0 then remove compare acc (x:: l'')
else remove compare (x:: acc) l' in
remove compare [] l
(** Remove consecutive equal irrelevant elements from a list (according to the given comparison and relevance functions) *)
let list_remove_irrelevant_duplicates compare relevant l =
let rec remove compare acc = function
| [] -> list_rev acc
| [x] -> list_rev (x:: acc)
| x:: ((y:: l'') as l') ->
if compare x y = 0 then begin
match relevant x, relevant y with
| false, _ -> remove compare acc l'
| true, false -> remove compare acc (x:: l'')
| true, true -> remove compare (x:: acc) l'
end
else remove compare (x:: acc) l' in
remove compare [] l
(** The function works on sorted lists without duplicates *)
let rec list_merge_sorted_nodup compare res xs1 xs2 =
match xs1, xs2 with
| [], _ ->
list_rev_with_acc xs2 res
| _, [] ->
list_rev_with_acc xs1 res
| x1 :: xs1', x2 :: xs2' ->
let n = compare x1 x2 in
if n = 0 then
list_merge_sorted_nodup compare (x1 :: res) xs1' xs2'
else if n < 0 then
list_merge_sorted_nodup compare (x1 :: res) xs1' xs2
else
list_merge_sorted_nodup compare (x2 :: res) xs1 xs2'
let list_intersect compare l1 l2 =
let l1_sorted = list_sort compare l1 in
let l2_sorted = list_sort compare l2 in
let rec f l1 l2 = match l1, l2 with
| ([], _) | (_,[]) -> false
| (x1:: l1', x2:: l2') ->
let x_comparison = compare x1 x2 in
if x_comparison = 0 then true
else if x_comparison < 0 then f l1' l2
else f l1 l2' in
f l1_sorted l2_sorted
exception Fail
(** Apply [f] to pairs of elements; raise [Fail] if the two lists have different lenghts. *)
let list_map2 f l1 l2 =
let rec go l1 l2 acc =
match l1, l2 with
| [],[] -> list_rev acc
| x1 :: l1', x2 :: l2' ->
let x' = f x1 x2 in
go l1' l2' (x':: acc)
| _ -> raise Fail in
go l1 l2 []
let list_to_string f l =
let rec aux l =
match l with
| [] -> ""
| s:: [] -> (f s)
| s:: rest -> (f s)^", "^(aux rest) in
"["^(aux l)^"]"
(** Like List.mem_assoc but without builtin equality *)
let list_mem_assoc equal a l =
list_exists (fun x -> equal a (fst x)) l
(** Like List.assoc but without builtin equality *)
let list_assoc equal a l =
snd (list_find (fun x -> equal a (fst x)) l)
(** {2 Useful Modules} *)
(** Set of integers *)
@ -614,7 +439,7 @@ let read_file fname =
with
| End_of_file ->
cleanup ();
Some (list_rev !res)
Some (IList.rev !res)
| Sys_error _ ->
cleanup ();
None
@ -663,7 +488,7 @@ struct
try Hashtbl.find include_loc_hash fname with Not_found ->
let loc = match read_file fname with
| None -> 0
| Some l -> list_length l in
| Some l -> IList.length l in
Hashtbl.add include_loc_hash fname loc;
loc
end
@ -708,7 +533,7 @@ module FileNormalize = struct
(* split a file name into a list of strings representing it as a path *)
let fname_to_list fname =
list_rev (fname_to_list_rev fname)
IList.rev (fname_to_list_rev fname)
(* concatenate a list of strings representing a path into a filename *)
let rec list_to_fname base path = match path with
@ -725,12 +550,12 @@ module FileNormalize = struct
| x :: dl, y :: tl when y = Filename.parent_dir_name -> (* path/x/.. --> path *)
normalize dl tl
| _, y :: tl -> normalize (y :: done_l) tl
| _, [] -> list_rev done_l
| _, [] -> IList.rev done_l
(* check if the filename contains "." or ".." *)
let fname_contains_current_parent fname =
let l = fname_to_list fname in
list_exists (fun x -> x = Filename.current_dir_name || x = Filename.parent_dir_name) l
IList.exists (fun x -> x = Filename.current_dir_name || x = Filename.parent_dir_name) l
(* convert a filename to absolute path, if necessary, and normalize "." and ".." *)
let fname_to_absolute_normalize fname =
@ -791,7 +616,7 @@ let filename_to_relative root fname =
type arg_list = (string * Arg.spec * string option * string) list
let arg_desc_filter options_to_keep =
list_filter (function (option_name, _, _, _) -> list_mem string_equal option_name options_to_keep)
IList.filter (function (option_name, _, _, _) -> IList.mem string_equal option_name options_to_keep)
let base_arg_desc =
[
@ -883,7 +708,7 @@ module Arg2 = struct
let make_symlist prefix sep suffix l =
match l with
| [] -> "<none>"
| h:: t -> (list_fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix
| h:: t -> (IList.fold_left (fun x y -> x ^ sep ^ y) (prefix ^ h) t) ^ suffix
let print_spec buf (key, spec, doc) =
match spec with
@ -909,7 +734,7 @@ module Arg2 = struct
let usage_b buf speclist errmsg =
bprintf buf "%s\n" errmsg;
list_iter (print_spec buf) (add_help speclist)
IList.iter (print_spec buf) (add_help speclist)
let usage speclist errmsg =
let b = Buffer.create 200 in
@ -966,7 +791,7 @@ module Arg2 = struct
incr current;
| Arg.Symbol (symb, f) when !current + 1 < l ->
let arg = argv.(!current + 1) in
if list_mem string_equal arg symb then begin
if IList.mem string_equal arg symb then begin
f argv.(!current + 1);
incr current;
end else begin
@ -1005,7 +830,7 @@ module Arg2 = struct
end;
incr current;
| Arg.Tuple specs ->
list_iter treat_action specs;
IList.iter treat_action specs;
| Arg.Rest f ->
while !current < l - 1 do
f argv.(!current + 1);
@ -1044,7 +869,7 @@ module Arg2 = struct
let doc2 = String.sub doc first_space (len - first_space) in
if len = 0 then (key, spec, doc)
else (key, spec, doc1 ^ "\n " ^ doc2) in
list_map do_arg arg_desc
IList.map do_arg arg_desc
type aligned = (key * spec * doc)
@ -1060,10 +885,10 @@ module Arg2 = struct
| Some param ->
if double_minus then ("-"^opname, spec, "=" ^ param ^ " " ^ text)
else (opname, spec, param ^ " " ^ text) in
let unsorted_desc' = list_map handle_double_minus unsorted_desc in
let unsorted_desc' = IList.map handle_double_minus unsorted_desc in
let dlist =
("", Arg.Unit (fun () -> ()), " \n " ^ title ^ "\n") ::
list_sort (fun (x, _, _) (y, _, _) -> Pervasives.compare x y) unsorted_desc' in
IList.sort (fun (x, _, _) (y, _, _) -> Pervasives.compare x y) unsorted_desc' in
align dlist
end
(********** END OF MODULE Arg2 **********)
@ -1137,7 +962,7 @@ let proc_flags_find proc_flags key =
let join_strings sep = function
| [] -> ""
| hd:: tl ->
list_fold_left (fun str p -> str ^ sep ^ p) hd tl
IList.fold_left (fun str p -> str ^ sep ^ p) hd tl
let next compare =
fun x y n ->

95
infer/src/backend/utils.mli
Unescape View File

@ -12,6 +12,10 @@
(** {2 Generic Utility Functions} *)
(** List police: don't use the list module to avoid non-tail recursive
functions and builtin equality. Use IList instead. *)
module List : sig end
(** Compare police: generic compare disabled. *)
val compare : unit
@ -36,12 +40,6 @@ val pair_compare : ('a -> 'b -> int) -> ('c -> 'd -> int) -> ('a * 'c) -> ('b *
(** Generic comparison of pairs given a compare function for each element of the triple. *)
val triple_compare : ('a -> 'b -> int) -> ('c -> 'd -> int) -> ('e -> 'f -> int) -> ('a * 'c * 'e) -> ('b * 'd * 'f) -> int
(** Generic comparison of lists given a compare function for the elements of the list *)
val list_compare : ('a -> 'b -> int) -> 'a list -> 'b list -> int
(** Generic equality of lists given a compare function for the elements of the list *)
val list_equal : ('a -> 'b -> int) -> 'a list -> 'b list -> bool
(** Comparison for strings *)
val string_compare : string -> string -> int
@ -51,91 +49,6 @@ val string_equal : string -> string -> bool
(** Comparison for floats *)
val float_compare : float -> float -> int
(** tail-recursive variant of List.append *)
val list_append : 'a list -> 'a list -> 'a list
(** tail-recursive variant of List.combine *)
val list_combine : 'a list -> 'b list -> ('a * 'b) list
val list_exists : ('a -> bool) -> 'a list -> bool
val list_filter : ('a -> bool) -> 'a list -> 'a list
(** tail-recursive variant of List.flatten *)
val list_flatten : 'a list list -> 'a list
(** Remove all None elements from the list. *)
val list_flatten_options : ('a option) list -> 'a list
val list_find : ('a -> bool) -> 'a list -> 'a
val list_fold_left : ('a -> 'b -> 'a) -> 'a -> 'b list -> 'a
val list_fold_left2 : ('a -> 'b -> 'c -> 'a) -> 'a -> 'b list -> 'c list -> 'a
val list_for_all : ('a -> bool) -> 'a list -> bool
val list_for_all2 : ('a -> 'b -> bool) -> 'a list -> 'b list -> bool
val list_hd : 'a list -> 'a
val list_iter : ('a -> unit) -> 'a list -> unit
val list_iter2 : ('a -> 'b -> unit) -> 'a list -> 'b list -> unit
val list_length : 'a list -> int
(** tail-recursive variant of List.fold_right *)
val list_fold_right : ('a -> 'b -> 'b) -> 'a list -> 'b -> 'b
(** tail-recursive variant of List.map *)
val list_map : ('a -> 'b) -> 'a list -> 'b list
(** Like List.mem but without builtin equality *)
val list_mem : ('a -> 'b -> bool) -> 'a -> 'b list -> bool
val list_nth : 'a list -> int -> 'a
val list_partition : ('a -> bool) -> 'a list -> 'a list * 'a list
val list_rev : 'a list -> 'a list
val list_rev_append : 'a list -> 'a list -> 'a list
val list_rev_map : ('a -> 'b) -> 'a list -> 'b list
val list_sort : ('a -> 'a -> int) -> 'a list -> 'a list
(** tail-recursive variant of List.split *)
val list_split : ('a * 'b) list -> 'a list * 'b list
val list_stable_sort : ('a -> 'a -> int) -> 'a list -> 'a list
val list_tl : 'a list -> 'a list
(* Drops the first n elements from a list. *)
val list_drop_first : int -> 'a list -> 'a list
(* Drops the last n elements from a list. *)
val list_drop_last : int -> 'a list -> 'a list
(** List police: don't use the list module to avoid non-tail-recursive functions and builtin equality *)
module List : sig end
(** Returns (reverse input_list)[@]acc *)
val list_rev_with_acc : 'a list -> 'a list -> 'a list
(** Remove consecutive equal elements from a list (according to the given comparison functions) *)
val list_remove_duplicates : ('a -> 'a -> int) -> 'a list -> 'a list
(** Remove consecutive equal irrelevant elements from a list (according to the given comparison and relevance functions) *)
val list_remove_irrelevant_duplicates : ('a -> 'a -> int) -> ('a -> bool) -> 'a list -> 'a list
(** The function works on sorted lists without duplicates *)
val list_merge_sorted_nodup : ('a -> 'a -> int) -> 'a list -> 'a list -> 'a list -> 'a list
(** Returns whether there is an intersection in the elements of the two lists.
The compare function is required to sort the lists. *)
val list_intersect : ('a -> 'a -> int) -> 'a list -> 'a list -> bool
(** Like List.mem_assoc but without builtin equality *)
val list_mem_assoc : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> bool
(** Like List.assoc but without builtin equality *)
val list_assoc : ('a -> 'a -> bool) -> 'a -> ('a * 'b) list -> 'b
exception Fail
(** Apply [f] to pairs of elements; raise [Fail] if the two lists have different lenghts. *)
val list_map2 : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list
val list_to_string : ('a -> string) -> 'a list -> string
(** {2 Useful Modules} *)
(** Set of integers *)

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

@ -28,7 +28,7 @@ let equal as1 as2 =
and ia2, t2 = as2.ret in
Sil.item_annotation_compare ia1 ia2 = 0 &&
Sil.typ_equal t1 t2 &&
list_for_all2 param_equal as1.params as2.params
IList.for_all2 param_equal as1.params as2.params
let visibleForTesting = "com.google.common.annotations.VisibleForTesting"
let javaxNullable = "javax.annotation.Nullable"
@ -40,17 +40,17 @@ let get_field_type_and_annotation fn = function
| Sil.Tptr (Sil.Tstruct (ftal, sftal, _, _, _, _, _), _)
| Sil.Tstruct (ftal, sftal, _, _, _, _, _) ->
(try
let (_, t, a) = list_find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in
let (_, t, a) = IList.find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in
Some (t, a)
with Not_found -> None)
| _ -> None
let ia_iter f =
let ann_iter (a, b) = f a in
list_iter ann_iter
IList.iter ann_iter
let ma_iter f ((ia, ial) : Sil.method_annotation) =
list_iter (ia_iter f) (ia:: ial)
IList.iter (ia_iter f) (ia:: ial)
let ma_has_annotation_with
(ma: Sil.method_annotation)
@ -92,7 +92,7 @@ let ia_get ia ann_name =
let ma_contains ma ann_names =
let found = ref false in
ma_iter (fun a -> if list_exists (string_equal a.Sil.class_name) ann_names then found := true) ma;
ma_iter (fun a -> if IList.exists (string_equal a.Sil.class_name) ann_names then found := true) ma;
!found
let initializer_ = "Initializer"
@ -117,7 +117,7 @@ let ia_is_present ia =
ia_ends_with ia present
let ia_is_nonnull ia =
list_exists
IList.exists
(ia_ends_with ia)
[nonnull; notnull; camel_nonnull]
@ -131,7 +131,7 @@ let ia_is_initializer ia =
ia_ends_with ia initializer_
let ia_is_inject ia =
list_exists
IList.exists
(ia_ends_with ia)
[inject; inject_view; bind]
@ -172,7 +172,7 @@ let get_annotated_signature proc_attributes : annotated_signature =
[]
| _ :: _, [] ->
assert false in
list_rev (extract (list_rev ial0) (list_rev formals)) in
IList.rev (extract (IList.rev ial0) (IList.rev formals)) in
let annotated_signature = { ret = (ia, ret_type); params = natl } in
annotated_signature
@ -204,13 +204,13 @@ let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
PatternMatch.type_is_object t in
Procname.java_is_anonymous_inner_class proc_name
&& check_ret ann_sig.ret
&& list_for_all check_param ann_sig.params
&& IList.for_all check_param ann_sig.params
&& !x_param_found
(** Check if the given parameter has a Nullable annotation in the given signature *)
let param_is_nullable pvar ann_sig =
let pvar_str = Mangled.to_string (Sil.pvar_get_name pvar) in
list_exists
IList.exists
(fun (param_str, annot, _) -> param_str = pvar_str && ia_is_nullable annot)
ann_sig.params

10
infer/src/checkers/callbackChecker.ml
Unescape View File

@ -43,7 +43,7 @@ let android_lifecycle_typs = ref []
(** resolve the list of android lifecycle type strings in [tenv] *)
let get_or_create_lifecycle_typs tenv = match !android_lifecycle_typs with
| [] ->
let lifecycle_typs = list_fold_left (fun typs (pkg, clazz, methods) ->
let lifecycle_typs = IList.fold_left (fun typs (pkg, clazz, methods) ->
let qualified_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt
qualified_name methods tenv with
@ -83,7 +83,7 @@ let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc
match Sil.get_typ (Mangled.from_string (Procname.java_get_class proc_name)) None tenv with
| Some (Sil.Tstruct(_, _, csu, Some class_name, _, methods, _) as typ) ->
let lifecycle_typs = get_or_create_lifecycle_typs tenv in
let proc_belongs_to_lifecycle_typ = list_exists
let proc_belongs_to_lifecycle_typ = IList.exists
(fun lifecycle_typ -> AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv)
lifecycle_typs in
if proc_belongs_to_lifecycle_typ then
@ -91,11 +91,11 @@ let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc
let registered_callback_typs =
AndroidFramework.get_callbacks_registered_by_proc proc_desc tenv in
(* find the callbacks registered by this procedure and update the list *)
let registered_callback_procs' = list_fold_left
let registered_callback_procs' = IList.fold_left
(fun callback_procs callback_typ ->
match callback_typ with
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) ->
list_fold_left
IList.fold_left
(fun callback_procs callback_proc ->
if Procname.is_constructor callback_proc then callback_procs
else Procname.Set.add callback_proc callback_procs)
@ -109,6 +109,6 @@ let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc
(* compute the set of fields nullified by this procedure *)
(* TODO (t4959422): get fields that are nullified in callees of the destroy method *)
fields_nullified := FldSet.union (get_fields_nullified proc_desc) !fields_nullified in
if done_checking (list_length methods) then
if done_checking (IList.length methods) then
do_eradicate_check all_procs get_procdesc idenv tenv
| _ -> ()

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

@ -68,13 +68,13 @@ let report_error description pn pd loc =
(** Check the final state at the end of the analysis. *)
let check_final_state proc_name proc_desc exit_node final_s =
let proc_nodes = Cfg.Procdesc.get_nodes proc_desc in
let tot_nodes = list_length proc_nodes in
let tot_nodes = IList.length proc_nodes in
let tot_visited = State.num_visited final_s in
if verbose then L.stderr "TOT nodes: %d (visited: %n)@." tot_nodes tot_visited;
if tot_nodes <> tot_visited then
begin
let not_visited =
list_filter (fun n -> not (Cfg.NodeSet.mem n (State.get_visited final_s))) proc_nodes in
IList.filter (fun n -> not (Cfg.NodeSet.mem n (State.get_visited final_s))) proc_nodes in
let do_node n =
let loc = Cfg.Node.get_loc n in
let description = Format.sprintf "Node not visited: %d" (Cfg.Node.get_id n) in
@ -84,7 +84,7 @@ let check_final_state proc_name proc_desc exit_node final_s =
| _ -> true in
if report
then report_error description proc_name proc_desc loc in
list_iter do_node not_visited
IList.iter do_node not_visited
end
(** Simple check for dead code. *)

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

@ -96,8 +96,8 @@ module ST = struct
string_equal (normalize s1) (normalize s2) in
let is_parameter_suppressed =
list_mem string_equal a.Sil.class_name [Annotations.suppressLint] &&
list_mem normalized_equal kind a.Sil.parameters in
IList.mem string_equal a.Sil.class_name [Annotations.suppressLint] &&
IList.mem normalized_equal kind a.Sil.parameters in
let is_annotation_suppressed =
string_is_suffix (normalize (drop_prefix kind)) (normalize a.Sil.class_name) in
@ -186,9 +186,9 @@ let callback_check_access all_procs get_proc_desc idenv tenv proc_name proc_desc
(** Report all field accesses and method calls of a class. *)
let callback_check_cluster_access all_procs get_proc_desc proc_definitions =
list_iter
IList.iter
(Option.may (fun d -> Cfg.Procdesc.iter_instrs (report_calls_and_accesses "CLUSTER") d))
(list_map get_proc_desc all_procs)
(IList.map get_proc_desc all_procs)
(** Looks for writeToParcel methods and checks whether read is in reverse *)
let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name proc_desc =
@ -206,7 +206,7 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name
let parcel_constructors = function
| Sil.Tptr (Sil.Tstruct (_, _, _, _, _, methods, _), _) ->
list_filter is_parcel_constructor methods
IList.filter is_parcel_constructor methods
| _ -> [] in
let check r_name r_desc w_name w_desc =
@ -235,8 +235,8 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name
| [desc] -> desc
| _ -> assert false in
let r_call_descs = list_map node_to_call_desc (list_filter is_serialization_node (Cfg.Procdesc.get_sliced_slope r_desc is_serialization_node)) in
let w_call_descs = list_map node_to_call_desc (list_filter is_serialization_node (Cfg.Procdesc.get_sliced_slope w_desc is_serialization_node)) in
let r_call_descs = IList.map node_to_call_desc (IList.filter is_serialization_node (Cfg.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 (Cfg.Procdesc.get_sliced_slope w_desc is_serialization_node)) in
let rec check_match = function
| rc:: rcs, wc:: wcs ->
@ -282,8 +282,8 @@ let callback_monitor_nullcheck all_procs get_proc_desc idenv tenv proc_name proc
| _, Sil.Tstruct _ -> true
| _, Sil.Tptr (Sil.Tstruct _, _) -> true
| _ -> false in
list_filter is_class_type formals in
list_map (fun (s, _) -> Mangled.from_string s) class_formals) in
IList.filter is_class_type formals in
IList.map (fun (s, _) -> Mangled.from_string s) class_formals) in
let equal_formal_param exp formal_name = match exp with
| Sil.Lvar pvar ->
let name = Sil.pvar_get_name pvar in
@ -291,7 +291,7 @@ let callback_monitor_nullcheck all_procs get_proc_desc idenv tenv proc_name proc
| _ -> false in
let is_formal_param exp =
list_exists (equal_formal_param exp) (Lazy.force class_formal_names) in
IList.exists (equal_formal_param exp) (Lazy.force class_formal_names) in
let is_nullcheck pn =
PatternMatch.java_proc_name_with_class_method
@ -310,12 +310,12 @@ let callback_monitor_nullcheck all_procs get_proc_desc idenv tenv proc_name proc
let summary_checks_of_formals () =
let formal_names = Lazy.force class_formal_names in
let nchecks = Sil.ExpSet.cardinal !checks_to_formals in
let nformals = list_length formal_names in
let nformals = IList.length formal_names in
if (nchecks > 0 && nchecks < nformals) then
begin
let was_not_found formal_name =
not (Sil.ExpSet.exists (fun exp -> equal_formal_param exp formal_name) !checks_to_formals) in
let missing = list_filter was_not_found formal_names in
let missing = IList.filter was_not_found formal_names in
let loc = Cfg.Procdesc.get_loc proc_desc in
let pp_file_loc fmt () =
F.fprintf fmt "%s:%d" (DB.source_file_to_string loc.Location.file) loc.Location.line in
@ -359,12 +359,12 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name 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(list_find f (Cfg.Node.get_instrs node)); true
try ignore(IList.find f (Cfg.Node.get_instrs node)); true
with Not_found -> false in
let preds = Cfg.Node.get_generated_slope node (fun n -> Cfg.Node.get_sliced_preds n has_instr) in
let instrs = list_flatten (list_map (fun n -> list_rev (Cfg.Node.get_instrs n)) preds) in
let instrs = IList.flatten (IList.map (fun n -> IList.rev (Cfg.Node.get_instrs n)) preds) in
try
Some (list_find f instrs)
Some (IList.find f instrs)
with Not_found -> None in
let get_return_const proc_name' =
@ -403,7 +403,7 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name p
| _ -> "?")
| _ -> "?" in
let arg_name (exp, typ) = find_const exp typ in
Some (list_map arg_name args)
Some (IList.map arg_name args)
with _ -> None)
| _ -> None in
@ -472,7 +472,7 @@ let callback_check_field_access all_procs get_proc_desc idenv tenv proc_name pro
do_read_exp e
| Sil.Call (_, e, etl, _, _) ->
do_read_exp e;
list_iter (fun (e, _) -> do_read_exp e) etl
IList.iter (fun (e, _) -> do_read_exp e) etl
| Sil.Nullify _
| Sil.Abstract _
| Sil.Remove_temps _

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

@ -38,7 +38,7 @@ module Err = struct
(** Update the summary with stats from the checker. *)
let update_summary proc_name proc_desc =
let old_summ = Specs.get_summary_unsafe "codeQuery" proc_name in
let nodes = list_map (fun n -> Cfg.Node.get_id n) (Cfg.Procdesc.get_nodes proc_desc) in
let nodes = IList.map (fun n -> Cfg.Node.get_id n) (Cfg.Procdesc.get_nodes proc_desc) in
let specs =
let spec =
{ Specs.pre = Specs.Jprop.Prop (1, Prop.prop_emp);
@ -134,7 +134,7 @@ module Match = struct
match Cfg.Node.get_succs node with
| [node'] ->
let instrs = Cfg.Node.get_instrs node in
list_iter (fun instr -> iter (node', instr)) instrs;
IList.iter (fun instr -> iter (node', instr)) instrs;
iter_succ_nodes node' iter
| [] -> ()
| _:: _ -> ()
@ -167,7 +167,7 @@ module Match = struct
| CodeQueryAst.Call _, _ -> false
| CodeQueryAst.MethodCall (ae1, ae2, ael_opt), Sil.Call (_, Sil.Const (Sil.Cfun pn), (_e1, t1):: params, loc, { Sil.cf_virtual = true }) ->
let e1 = Idenv.expand_expr idenv _e1 in
let vl = list_map (function _e, t -> Vval (Idenv.expand_expr idenv _e)) params in
let vl = IList.map (function _e, t -> Vval (Idenv.expand_expr idenv _e)) params in
if exp_match env ae1 (Vval e1) && exp_match env ae2 (Vfun pn) && opt_match exp_list_match env ael_opt vl then
begin
if show then print_action env action proc_name node loc;

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

@ -105,12 +105,12 @@ module ConstantFlow = Dataflow.MakeDF(struct
begin
L.stdout "Node %i:" (Cfg.Node.get_id node);
L.stdout "%a" pp constants;
list_iter
IList.iter
(fun instr -> L.stdout "%a@." (Sil.pp_instr pe_text) instr)
(Cfg.Node.get_instrs node)
end;
let constants =
list_fold_left
IList.fold_left
do_instr
constants
(Cfg.Node.get_instrs node) in

14
infer/src/checkers/dataflow.ml
Unescape View File

@ -70,7 +70,7 @@ let node_throws node (proc_throws : Procname.t -> throws) : throws =
| t, DoesNotThrow -> res := t in
let do_instr instr = update_res (instr_throws instr) in
list_iter do_instr (Cfg.Node.get_instrs node);
IList.iter do_instr (Cfg.Node.get_instrs node);
!res
(** Create an instance of the dataflow algorithm given a state parameter. *)
@ -95,7 +95,7 @@ module MakeDF(St: DFStateType) : DF with type state = St.t = struct
| Transition of state * state list * state list
let join states initial_state =
list_fold_left
IList.fold_left
St.join
initial_state
states
@ -116,12 +116,12 @@ module MakeDF(St: DFStateType) : DF with type state = St.t = struct
let succ_nodes = Cfg.Node.get_succs node in
let exn_nodes = Cfg.Node.get_exn node in
if throws <> Throws then
list_iter
(fun s -> list_iter (propagate_to_dest s) succ_nodes)
IList.iter
(fun s -> IList.iter (propagate_to_dest s) succ_nodes)
states_succ;
if throws <> DoesNotThrow then
list_iter
(fun s -> list_iter (propagate_to_dest s) exn_nodes)
IList.iter
(fun s -> IList.iter (propagate_to_dest s) exn_nodes)
states_exn;
H.replace t.post_states node states_succ;
@ -182,4 +182,4 @@ let callback_test_dataflow all_procs get_proc_desc idenv tenv proc_name proc_des
match transitions node with
| DFCount.Transition (pre_state, _, _) -> ()
| DFCount.Dead_state -> () in
list_iter do_node (Cfg.Procdesc.get_nodes proc_desc)
IList.iter do_node (Cfg.Procdesc.get_nodes proc_desc)

24
infer/src/checkers/eradicate.ml
Unescape View File

@ -53,7 +53,7 @@ struct
let update_summary proc_name proc_desc final_typestate_opt =
match Specs.get_summary proc_name with
| Some old_summ ->
let nodes = list_map (fun n -> Cfg.Node.get_id n) (Cfg.Procdesc.get_nodes proc_desc) in
let nodes = IList.map (fun n -> Cfg.Node.get_id n) (Cfg.Procdesc.get_nodes proc_desc) in
let method_annotation =
(Specs.pdesc_resolve_attributes proc_desc).ProcAttributes.method_annotation in
let new_summ =
@ -84,7 +84,7 @@ struct
TypeState.add_pvar pvar (typ, ta, []) typestate in
let get_initial_typestate () =
let typestate_empty = TypeState.empty Extension.ext in
list_fold_left add_formal typestate_empty annotated_signature.Annotations.params in
IList.fold_left add_formal typestate_empty annotated_signature.Annotations.params in
(** Check the nullable flag computed for the return value and report inconsistencies. *)
let check_return find_canonical_duplicate exit_node final_typestate ret_ia ret_type loc : unit =
@ -98,7 +98,7 @@ struct
State.set_node exit_node;
if checks.TypeCheck.check_ret_type <> [] then
list_iter
IList.iter
(fun f -> f curr_pname curr_pdesc ret_type typ_found_opt loc)
checks.TypeCheck.check_ret_type;
if checks.TypeCheck.eradicate then
@ -128,7 +128,7 @@ struct
Extension.ext calls_this checks idenv get_proc_desc curr_pname curr_pdesc
find_canonical_duplicate annotated_signature typestate node linereader in
if trace then
list_iter (fun typestate_succ ->
IList.iter (fun typestate_succ ->
L.stdout
"Typestate After Node %a@\n%a@."
Cfg.Node.pp node
@ -203,8 +203,8 @@ struct
| Some callee_pd ->
res := (callee_pn, callee_pd) :: !res
| None -> () in
list_iter do_called private_called in
list_iter do_proc initializers;
IList.iter do_called private_called in
IList.iter do_proc initializers;
!res in
(** Get the initializers recursively called by computing a fixpoint.
@ -215,13 +215,13 @@ struct
let res = ref [] in
let seen = ref Procname.Set.empty in
let mark_seen (initializers : init list) : unit =
list_iter (fun (pn, _) -> seen := Procname.Set.add pn !seen) initializers;
IList.iter (fun (pn, _) -> seen := Procname.Set.add pn !seen) initializers;
res := !res @ initializers in
let rec fixpoint initializers_old =
let initializers_new = get_private_called initializers_old in
let initializers_new' =
list_filter (fun (pn, _) -> not (Procname.Set.mem pn !seen)) initializers_new in
IList.filter (fun (pn, _) -> not (Procname.Set.mem pn !seen)) initializers_new in
mark_seen initializers_new';
if initializers_new' <> [] then fixpoint initializers_new' in
@ -236,8 +236,8 @@ struct
| _, Some final_typestate ->
final_typestates := (pname, final_typestate) :: !final_typestates
| _, None -> () in
list_iter get_final_typestate initializers_recursive;
list_rev !final_typestates
IList.iter get_final_typestate initializers_recursive;
IList.rev !final_typestates
let pname_and_pdescs_with f =
let res = ref [] in
@ -250,8 +250,8 @@ struct
| Some pdesc ->
res := (pname, pdesc) :: !res
| None -> () in
list_iter do_proc all_procs;
list_rev !res
IList.iter do_proc all_procs;
IList.rev !res
(** Typestates after the current procedure and all initializer procedures. *)
let final_initializer_typestates_lazy = lazy

16
infer/src/checkers/eradicateChecks.ml
Unescape View File

@ -140,7 +140,7 @@ let check_condition case_zero find_canonical_duplicate get_proc_desc curr_pname
| _ -> () in
let do_node n =
if Location.equal loc (Cfg.Node.get_loc n)
then list_iter do_instr (Cfg.Node.get_instrs n) in
then IList.iter do_instr (Cfg.Node.get_instrs n) in
Cfg.Procdesc.iter_nodes do_node (Cfg.Node.get_proc_desc node);
!throwable_found in
@ -262,7 +262,7 @@ let check_constructor_initialization
let filter_range_opt = function
| Some (_, ta, _) -> f ta
| None -> unknown in
list_exists
IList.exists
(function pname, typestate ->
let pvar = Sil.mk_pvar
(Mangled.from_string (Ident.fieldname_to_string fn))
@ -321,7 +321,7 @@ let check_constructor_initialization
curr_pname;
end in
list_iter do_fta ftal
IList.iter do_fta ftal
| _ -> ()
end
@ -428,7 +428,7 @@ let check_call_parameters
instr_ref typecheck_expr print_current_state : unit =
let callee_pname = callee_attributes.ProcAttributes.proc_name in
let has_this = is_virtual sig_params in
let tot_param_num = list_length sig_params - (if has_this then 1 else 0) in
let tot_param_num = IList.length sig_params - (if has_this then 1 else 0) in
let rec check sparams cparams = match sparams, cparams with
| (s1, ia1, t1) :: sparams', ((orig_e2, e2), t2) :: cparams' ->
let param_is_this = s1 = "this" in
@ -460,7 +460,7 @@ let check_call_parameters
| None -> "formal parameter " ^ s1 in
let origin_descr = TypeAnnotation.descr_origin ta2 in
let param_num = list_length sparams' + (if has_this then 0 else 1) in
let param_num = IList.length sparams' + (if has_this then 0 else 1) in
let callee_loc = callee_attributes.ProcAttributes.loc in
report_error
find_canonical_duplicate
@ -487,7 +487,7 @@ let check_call_parameters
Specs.get_summary callee_pname <> None in
if should_check_parameters then
(* left to right to avoid guessing the different lengths *)
check (list_rev sig_params) (list_rev call_params)
check (IList.rev sig_params) (IList.rev call_params)
(** Checks if the annotations are consistent with the inherited class or with the
implemented interfaces *)
@ -532,8 +532,8 @@ let check_overridden_annotations
let current_params = annotated_signature.Annotations.params
and overridden_params = overriden_signature.Annotations.params in
let initial_pos = if is_virtual current_params then 0 else 1 in
if (list_length current_params) = (list_length overridden_params) then
ignore (list_fold_left2 compare initial_pos current_params overridden_params) in
if (IList.length current_params) = (IList.length overridden_params) then
ignore (IList.fold_left2 compare initial_pos current_params overridden_params) in
let check overriden_proc_name =
match Specs.proc_resolve_attributes overriden_proc_name with

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

@ -23,7 +23,7 @@ let check_immutable_cast curr_pname curr_pdesc typ_expected typ_found_opt loc :
"java.util.Set", "com.google.common.collect.ImmutableSet"
] in
let in_casts expected given =
list_exists (fun (x, y) -> Mangled.from_string x = expected && Mangled.from_string y = given) casts in
IList.exists (fun (x, y) -> Mangled.from_string x = expected && Mangled.from_string y = given) casts in
match PatternMatch.type_get_class_name typ_expected,
PatternMatch.type_get_class_name typ_found with
| Some name_expected, Some name_given ->

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

@ -50,7 +50,7 @@ let check_not_null_parameter_list, check_not_null_list =
1, (o, [n]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object):java.lang.Object";
1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object";
] in
list_map (fun (x, y, z) -> (x, z)) list, list_map (fun (x, y, z) -> (y, z)) list
IList.map (fun (x, y, z) -> (x, z)) list, IList.map (fun (x, y, z) -> (y, z)) list
let check_state_list =
[
@ -223,7 +223,7 @@ type model_table_t = (string, bool * bool list) Hashtbl.t
let mk_table list =
let map = Hashtbl.create 1 in
list_iter (function (v, pn_id) -> Hashtbl.replace map pn_id v) list;
IList.iter (function (v, pn_id) -> Hashtbl.replace map pn_id v) list;
map
let annotated_table_nullable = mk_table annotated_list_nullable

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

@ -89,7 +89,7 @@ module Inference = struct
| Some buf ->
let boolvec = ref [] in
String.iter (fun c -> boolvec := (c = '1') :: !boolvec) buf;
Some (list_rev !boolvec)
Some (IList.rev !boolvec)
end (* Inference *)

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

@ -28,7 +28,7 @@ let java_proc_name_with_class_method pn class_with_path method_name =
let is_direct_subtype_of this_type super_type_name =
match this_type with
| Sil.Tptr (Sil.Tstruct (_, _, _, _, supertypes, _, _), _) ->
list_exists (fun (x, y) -> super_type_name = Mangled.to_string y) supertypes
IList.exists (fun (x, y) -> super_type_name = Mangled.to_string y) supertypes
| _ -> false
(** The type the method is invoked on *)
@ -39,7 +39,7 @@ let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals
let type_get_direct_supertypes = function
| Sil.Tptr (Sil.Tstruct (_, _, _, _, supertypes, _, _), _)
| Sil.Tstruct (_, _, _, _, supertypes, _, _) ->
list_map (fun (_, m) -> m) supertypes
IList.map (fun (_, m) -> m) supertypes
| _ -> []
let type_get_class_name t = match t with
@ -60,7 +60,7 @@ let type_has_class_name t name =
type_get_class_name t = Some name
let type_has_direct_supertype (t : Sil.typ) (s : Mangled.t) =
list_exists (fun c -> c = s) (type_get_direct_supertypes t)
IList.exists (fun c -> c = s) (type_get_direct_supertypes t)
let type_find_supertype
(tenv: Sil.tenv)
@ -86,7 +86,7 @@ let type_find_supertype
| None -> false in
(match_csu () && match_name () (* only and always visit name with expected csu *))
|| has_indirect_supertype () in
list_exists match_supertype supertypes
IList.exists match_supertype supertypes
| _ -> false
end in
has_supertype typ Sil.TypSet.empty
@ -108,7 +108,7 @@ let type_get_supertypes
res := m :: !res;
false in
let _ = type_find_supertype tenv typ csu_option filter in
list_rev !res
IList.rev !res
let type_is_nested_in_type t n = match t with
| Sil.Tptr (Sil.Tstruct (_, _, _, Some m, _, _, _), _) ->
@ -117,11 +117,11 @@ let type_is_nested_in_type t n = match t with
let type_is_nested_in_direct_supertype t n =
let is_nested_in m2 m1 = string_is_prefix (Mangled.to_string m2 ^ "$") (Mangled.to_string m1) in
list_exists (is_nested_in n) (type_get_direct_supertypes t)
IList.exists (is_nested_in n) (type_get_direct_supertypes t)
let type_is_nested_in_supertype tenv t csu_option n =
let is_nested_in m2 m1 = string_is_prefix (Mangled.to_string m2 ^ "$") (Mangled.to_string m1) in
list_exists (is_nested_in n) (type_get_supertypes tenv t csu_option)
IList.exists (is_nested_in n) (type_get_supertypes tenv t csu_option)
let rec get_type_name = function
| Sil.Tstruct (_, _, _, Some mangled, _, _, _) -> Mangled.to_string mangled
@ -136,7 +136,7 @@ let get_field_type_name
| Sil.Tstruct (fields, _, _, _, _, _, _)
| Sil.Tptr (Sil.Tstruct (fields, _, _, _, _, _, _), _) -> (
try
let _, ft, _ = list_find
let _, ft, _ = IList.find
(function | (fn, _, _) -> Ident.fieldname_equal fn fieldname)
fields in
Some (get_type_name ft)
@ -204,7 +204,7 @@ let get_vararg_type_names
| None -> type_names n)
| _ -> raise Not_found in
list_rev (type_names call_node)
IList.rev (type_names call_node)
let has_type_name typ type_name =
get_type_name typ = type_name
@ -212,8 +212,8 @@ let has_type_name typ type_name =
let has_formal_proc_argument_type_names proc_desc proc_name argument_type_names =
let formals = Cfg.Procdesc.get_formals proc_desc in
let equal_formal_arg (_, typ) arg_type_name = get_type_name typ = arg_type_name in
list_length formals = list_length argument_type_names
&& list_for_all2 equal_formal_arg formals argument_type_names
IList.length formals = IList.length argument_type_names
&& IList.for_all2 equal_formal_arg formals argument_type_names
let has_formal_method_argument_type_names cfg proc_name argument_type_names =
has_formal_proc_argument_type_names
@ -236,7 +236,7 @@ let get_java_field_access_signature = function
let get_java_method_call_formal_signature = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) ->
(try
let arg_names = list_map (function | e, t -> get_type_name t) args in
let arg_names = IList.map (function | e, t -> get_type_name t) args in
let rt_name = Procname.java_get_return_type pn in
let m_name = Procname.java_get_method pn in
Some (get_type_name tt, m_name, arg_names, rt_name)
@ -251,7 +251,7 @@ let type_is_class = function
| Sil.Tstruct _ -> true
| _ -> false
let initializer_classes = list_map Mangled.from_string [
let initializer_classes = IList.map Mangled.from_string [
"android.app.Activity";
"android.app.Application";
"android.app.Fragment";
@ -270,7 +270,7 @@ let type_has_initializer
(tenv: Sil.tenv)
(t: Sil.typ): bool =
let check_candidate cname = type_has_supertype tenv t (Some Sil.Class) cname in
list_exists check_candidate initializer_classes
IList.exists check_candidate initializer_classes
(** Check if the method is one of the known initializer methods. *)
let method_is_initializer
@ -280,7 +280,7 @@ let method_is_initializer
| Some this_type ->
if type_has_initializer tenv this_type then
let mname = Procname.java_get_method (proc_attributes.ProcAttributes.proc_name) in
list_exists (string_equal mname) initializer_methods
IList.exists (string_equal mname) initializer_methods
else
false
| None -> false
@ -295,7 +295,7 @@ let java_get_vararg_values node pvar idenv pdesc =
values := content_exp :: !values
| _ -> () in
let do_node n =
list_iter do_instr (Cfg.Node.get_instrs n) in
IList.iter do_instr (Cfg.Node.get_instrs n) in
let () = match Errdesc.find_program_variable_assignment node pvar with
| Some (node', _) ->
Cfg.Procdesc.iter_slope_range do_node pdesc node' node
@ -316,10 +316,10 @@ let proc_calls resolve_attributes pname pdesc filter : (Procname.t * ProcAttribu
| _ -> () in
let do_node node =
let instrs = Cfg.Node.get_instrs node in
list_iter (do_instruction node) instrs in
IList.iter (do_instruction node) instrs in
let nodes = Cfg.Procdesc.get_nodes pdesc in
list_iter do_node nodes;
list_rev !res
IList.iter do_node nodes;
IList.rev !res
(** Iterate over all the methods overridden by the procedure.
@ -334,7 +334,7 @@ let proc_iter_overridden_methods f tenv proc_name =
let is_override pname =
Procname.equal pname super_proc_name &&
not (Procname.is_constructor pname) in
list_iter
IList.iter
(fun pname ->
if is_override pname
then f pname)
@ -347,5 +347,5 @@ let proc_iter_overridden_methods f tenv proc_name =
Sil.TN_csu (Sil.Class, Mangled.from_string class_name) in
match Sil.tenv_lookup tenv type_name with
| Some curr_type ->
list_iter (do_super_type tenv) (type_get_direct_supertypes curr_type)
IList.iter (do_super_type tenv) (type_get_direct_supertypes curr_type)
| None -> ()

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

@ -24,7 +24,7 @@ let printf_signature_to_string
"{%s; %d [%s] %s}"
printf.unique_id
printf.format_pos
(String.concat "," (list_map string_of_int printf.fixed_pos))
(String.concat "," (IList.map string_of_int printf.fixed_pos))
(match printf.vararg_pos with | Some i -> string_of_int i | _ -> "-")
let printf_like_functions =
@ -56,7 +56,7 @@ let printf_like_function
(proc_name: Procname.t): printf_signature option =
try
Some (
list_find
IList.find
(fun printf -> string_equal printf.unique_id (Procname.to_unique_id proc_name))
!printf_like_functions)
with Not_found -> None
@ -77,12 +77,12 @@ let format_type_matches_given_type
(given_type: string): bool =
match format_type with
| "d" | "i" | "u" | "x" | "X" | "o" ->
list_mem
IList.mem
string_equal
given_type
["java.lang.Integer"; "java.lang.Long"; "java.lang.Short"; "java.lang.Byte"]
| "a" | "A" | "f" | "F" | "g" | "G" | "e" | "E" ->
list_mem
IList.mem
string_equal
given_type
["java.lang.Double"; "java.lang.Float"]
@ -95,15 +95,15 @@ let format_arguments
(printf: printf_signature)
(args: (Sil.exp * Sil.typ) list): (string option * (Sil.exp list) * (Sil.exp option)) =
let format_string = match list_nth args printf.format_pos with
let format_string = match IList.nth args printf.format_pos with
| Sil.Const (Sil.Cstr fmt), _ -> Some fmt
| _ -> None in
let fixed_nvars = list_map
(fun i -> fst (list_nth args i))
let fixed_nvars = IList.map
(fun i -> fst (IList.nth args i))
printf.fixed_pos in
let varargs_nvar = match printf.vararg_pos with
| Some pos -> Some (fst (list_nth args pos))
| Some pos -> Some (fst (IList.nth args pos))
| None -> None in
format_string, fixed_nvars, varargs_nvar
@ -194,7 +194,7 @@ let callback_printf_args
try
let fmt, fixed_nvars, array_nvar = format_arguments printf args in
let instrs = Cfg.Node.get_instrs node in
let fixed_nvar_type_names = list_map (fixed_nvar_type_name instrs) fixed_nvars in
let fixed_nvar_type_names = IList.map (fixed_nvar_type_name instrs) fixed_nvars in
let vararg_ivar_type_names = match array_nvar with
| Some nvar -> (
let ivar = array_ivar instrs nvar in

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

@ -36,14 +36,14 @@ let active_procedure_checkers () =
RepeatedCallsChecker.callback_check_repeated_calls, checkers_enabled;
PrintfArgs.callback_printf_args, checkers_enabled;
] in
list_map (fun (x, y) -> (x, y, Some Config.Java)) l in
IList.map (fun (x, y) -> (x, y, Some Config.Java)) l in
let c_cpp_checkers =
let l =
[
Checkers.callback_print_c_method_calls, false;
CheckDeadCode.callback_check_dead_code, checkers_enabled;
] in
list_map (fun (x, y) -> (x, y, Some Config.C_CPP)) l in
IList.map (fun (x, y) -> (x, y, Some Config.C_CPP)) l in
java_checkers @ c_cpp_checkers
@ -53,5 +53,5 @@ let active_cluster_checkers () =
let register () =
let register registry (callback, active, language_opt) =
if active then registry language_opt callback in
list_iter (register Callbacks.register_procedure_callback) (active_procedure_checkers ());
list_iter (register Callbacks.register_cluster_callback) (active_cluster_checkers ())
IList.iter (register Callbacks.register_procedure_callback) (active_procedure_checkers ());
IList.iter (register Callbacks.register_cluster_callback) (active_cluster_checkers ())

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

@ -27,7 +27,7 @@ struct
| Sil.Call (ret1, e1, etl1, loc1, cf1), Sil.Call (ret2, e2, etl2, loc2, cf2) ->
(* ignore return ids and call flags *)
let n = Sil.exp_compare e1 e2 in
if n <> 0 then n else let n = list_compare Sil.exp_typ_compare etl1 etl2 in
if n <> 0 then n else let n = IList.compare Sil.exp_typ_compare etl1 etl2 in
if n <> 0 then n else Sil.call_flags_compare cf1 cf2
| _ -> Sil.instr_compare i1 i2
end)
@ -75,7 +75,7 @@ struct
| Sil.Call (_, Sil.Const (Sil.Cfun pn), _, loc, _) when proc_is_new pn ->
found := Some loc
| _ -> () in
list_iter do_instr (Cfg.Node.get_instrs node);
IList.iter do_instr (Cfg.Node.get_instrs node);
!found in
let module DFAllocCheck = Dataflow.MakeDF(struct
@ -114,7 +114,7 @@ struct
(* same temporary variable does not imply same value *)
not (Errdesc.pvar_is_frontend_tmp pvar)
| _ -> true in
list_for_all filter_arg args in
IList.for_all filter_arg args in
match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _, loc, call_flags)

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

@ -24,7 +24,7 @@ let callback_sql all_procs get_proc_desc idenv tenv proc_name proc_desc =
"update .* set.*";
"delete .* from.*";
] in
list_map Str.regexp_case_fold _sql_start in
IList.map Str.regexp_case_fold _sql_start in
(* Check for SQL string concatenations *)
let do_instr const_map node = function
@ -37,7 +37,7 @@ let callback_sql all_procs get_proc_desc idenv tenv proc_name proc_desc =
let matches s r = Str.string_match r s 0 in
match const_map node rvar1, const_map node rvar2 with
| Some (Sil.Cstr ""), Some (Sil.Cstr s2) ->
if list_exists (matches s2) sql_start then
if IList.exists (matches s2) sql_start then
begin
L.stdout
"%s%s@."

26
infer/src/checkers/typeCheck.ml
Unescape View File

@ -347,7 +347,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let is_parameter_field pvar = (* parameter.field *)
let name = Sil.pvar_to_string pvar in
let filter (s, ia, typ) = string_equal s name in
list_exists filter annotated_signature.Annotations.params in
IList.exists filter annotated_signature.Annotations.params in
let is_static_field pvar = (* static field *)
Sil.pvar_is_global pvar in
@ -405,11 +405,11 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| fp:: tail when is_hidden_parameter fp -> 1 + drop_n_args tail
| _ -> 0 in
let n = drop_n_args proc_attributes.ProcAttributes.formals in
let visible_params = list_drop_first n params in
let visible_params = IList.drop_first n params in
(* Drop the trailing hidden parameter if the constructor is synthetic. *)
if proc_attributes.ProcAttributes.is_synthetic_method then
list_drop_last 1 visible_params
IList.drop_last 1 visible_params
else
visible_params
end
@ -421,7 +421,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let drop_unchecked_signature_params proc_attributes annotated_signature =
if Procname.is_constructor (proc_attributes.ProcAttributes.proc_name) &&
proc_attributes.ProcAttributes.is_synthetic_method then
list_drop_last 1 annotated_signature.Annotations.params
IList.drop_last 1 annotated_signature.Annotations.params
else
annotated_signature.Annotations.params in
@ -465,7 +465,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
match instr with
| Sil.Remove_temps (idl, loc) ->
if remove_temps then list_fold_right TypeState.remove_id idl typestate
if remove_temps then IList.fold_right TypeState.remove_id idl typestate
else typestate
| Sil.Declare_locals _
| Sil.Abstract _
@ -571,7 +571,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
typecheck_expr_for_errors typestate e1 loc;
let e2, typestate2 = convert_complex_exp_to_pvar node false e1 typestate1 loc in
(((e1, e2), t1) :: etl1), typestate2 in
list_fold_right handle_et etl ([], typestate) in
IList.fold_right handle_et etl ([], typestate) in
let annotated_signature =
Models.get_modelled_annotated_signature callee_attributes in
@ -640,7 +640,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
pvar_apply loc clear_nullable_flag ts pvar1
| _ -> ts in
let vararg_values = PatternMatch.java_get_vararg_values node pvar idenv curr_pdesc in
Utils.list_fold_right do_vararg_value vararg_values typestate'
IList.fold_right do_vararg_value vararg_values typestate'
else
pvar_apply loc clear_nullable_flag typestate' pvar
| None -> typestate' in
@ -676,7 +676,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> ()
end
| _ -> () in
list_iter do_instr (Cfg.Node.get_instrs cond_node) in
IList.iter do_instr (Cfg.Node.get_instrs cond_node) in
let handle_optional_isPresent node' e =
match convert_complex_exp_to_pvar node' false e typestate' loc with
| Sil.Lvar pvar', _ ->
@ -692,7 +692,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(* In foo(cond1 && cond2), the node that sets the result to false
has all the negated conditions as parents. *)
| Some boolean_assignment_node ->
list_iter handle_negated_condition (Cfg.Node.get_preds boolean_assignment_node);
IList.iter handle_negated_condition (Cfg.Node.get_preds boolean_assignment_node);
!res_typestate
| None ->
begin
@ -751,7 +751,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
print_current_state;
let typestate2 =
if checks.check_extension then
let etl' = list_map (fun ((_, e), t) -> (e, t)) call_params in
let etl' = IList.map (fun ((_, e), t) -> (e, t)) call_params in
let extension = TypeState.get_extension typestate1 in
let extension' =
ext.TypeState.check_instr
@ -768,7 +768,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
if Procname.java_get_method callee_pname = "checkNotNull"
&& Procname.java_is_vararg callee_pname
then
let last_parameter = list_length call_params in
let last_parameter = IList.length call_params in
do_preconditions_check_not_null
last_parameter
true (* is_vararg *)
@ -956,7 +956,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv e') ->
found := Some e
| _ -> () in
list_iter do_instr (Cfg.Node.get_instrs prev_node);
IList.iter do_instr (Cfg.Node.get_instrs prev_node);
!found
| _ -> None in
@ -1031,7 +1031,7 @@ let typecheck_node
(* This is used to track if it is set to true for all visit to the node. *)
TypeErr.node_reset_forall canonical_node;
let typestate_succ = list_fold_left (do_instruction ext) typestate instrs in
let typestate_succ = IList.fold_left (do_instruction ext) typestate instrs in
if Cfg.Node.get_kind node = Cfg.Node.exn_sink_kind
then [], [] (* don't propagate exceptions to exit node *)
else [typestate_succ], !typestates_exn

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

@ -49,7 +49,7 @@ let empty ext =
extension = ext.empty;
}
let locs_compare = list_compare Location.compare
let locs_compare = IList.compare Location.compare
let locs_equal locs1 locs2 = locs_compare locs1 locs2 = 0
let range_equal (typ1, ta1, locs1) (typ2, ta2, locs2) =
@ -78,7 +78,7 @@ exception JoinFail
let type_join typ1 typ2 =
if PatternMatch.type_is_object typ1 then typ2 else typ1
let locs_join locs1 locs2 =
list_merge_sorted_nodup Location.compare [] locs1 locs2
IList.merge_sorted_nodup Location.compare [] locs1 locs2
(** Add a list of locations to a range. *)
let range_add_locs (typ, ta, locs1) locs2 =

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

@ -372,7 +372,7 @@ let make_next_object_exp stmt_info item items =
(* void (^block_var)()=block_def; block_var() *)
let translate_dispatch_function block_name stmt_info stmt_list ei n =
let block_expr =
try Utils.list_nth stmt_list (n + 1)
try IList.nth stmt_list (n + 1)
with Not_found -> assert false in
let block_name_info = {
Clang_ast_t.ni_name = block_name;

26
infer/src/clang/cAstProcessor.ml
Unescape View File

@ -98,8 +98,8 @@ let pp_ast_decl fmt ast_decl =
prefix
stmt_str
pp_source_range stmt_info.Clang_ast_t.si_source_range;
list_iter (dump_stmt prefix1) stmt_list;
list_iter (dump_decl prefix1) decl_list
IList.iter (dump_stmt prefix1) stmt_list;
IList.iter (dump_decl prefix1) decl_list
and dump_decl prefix decl =
let prefix1 = prefix ^ " " in
let open Clang_ast_t in
@ -109,8 +109,8 @@ let pp_ast_decl fmt ast_decl =
prefix
name.Clang_ast_t.ni_name
pp_source_range decl_info.di_source_range;
list_iter (dump_decl prefix1) fdecl_info.fdi_decls_in_prototype_scope;
list_iter (dump_decl prefix1) fdecl_info.fdi_parameters;
IList.iter (dump_decl prefix1) fdecl_info.fdi_decls_in_prototype_scope;
IList.iter (dump_decl prefix1) fdecl_info.fdi_parameters;
Option.may (dump_stmt prefix1) fdecl_info.fdi_body
| ObjCMethodDecl (decl_info, name, obj_c_method_decl_info) ->
F.fprintf fmt "%sObjCMethodDecl %s %a@\n"
@ -131,13 +131,13 @@ let pp_ast_decl fmt ast_decl =
prefix
decl_kind_str
pp_source_range decl_info.di_source_range;
list_iter (dump_decl prefix1) decl_list in
IList.iter (dump_decl prefix1) decl_list in
let decl_str = Clang_ast_proj.get_decl_kind_string ast_decl in
match ast_decl with
| Clang_ast_t.TranslationUnitDecl (_, decl_list, _, _) ->
F.fprintf fmt "%s (%d declarations)@\n" decl_str (list_length decl_list);
list_iter (dump_decl "") decl_list
F.fprintf fmt "%s (%d declarations)@\n" decl_str (IList.length decl_list);
IList.iter (dump_decl "") decl_list
| _ ->
assert false
@ -229,12 +229,12 @@ let rec stmt_process_locs loc_composer stmt =
let stmt_info' =
{ stmt_info with
Clang_ast_t.si_source_range = range' } in
let stmt_list' = list_map (stmt_process_locs loc_composer) stmt_list in
let stmt_list' = IList.map (stmt_process_locs loc_composer) stmt_list in
(stmt_info', stmt_list') in
let open Clang_ast_t in
match Clang_ast_proj.update_stmt_tuple update stmt with
| DeclStmt (stmt_info, stmt_list, decl_list) ->
let decl_list' = list_map (decl_process_locs loc_composer) decl_list in
let decl_list' = IList.map (decl_process_locs loc_composer) decl_list in
DeclStmt (stmt_info, stmt_list, decl_list')
| stmt' ->
stmt'
@ -248,14 +248,14 @@ and decl_process_locs loc_composer decl =
Clang_ast_t.di_source_range = range' } in
let decl_list = decl_get_sub_decls decl in
let decl1 = Clang_ast_proj.update_decl_tuple update decl in
let decl_list' = list_map (decl_process_locs loc_composer) decl_list in
let decl_list' = IList.map (decl_process_locs loc_composer) decl_list in
decl_set_sub_decls decl1 decl_list' in
let open Clang_ast_t in
let get_updated_fun_decl (decl_info', name, tp, fdecl_info) =
let fdi_decls_in_prototype_scope' =
list_map (decl_process_locs loc_composer) fdecl_info.fdi_decls_in_prototype_scope in
IList.map (decl_process_locs loc_composer) fdecl_info.fdi_decls_in_prototype_scope in
let fdi_parameters' =
list_map (decl_process_locs loc_composer) fdecl_info.fdi_parameters in
IList.map (decl_process_locs loc_composer) fdecl_info.fdi_parameters in
let body' = Option.map (stmt_process_locs loc_composer) fdecl_info.fdi_body in
let fdecl_info' =
{ fdecl_info with
@ -297,7 +297,7 @@ let ast_decl_process_locs loc_composer ast_decl =
match ast_decl with
| Clang_ast_t.TranslationUnitDecl (decl_info, decl_list, decl_context_info, type_list) ->
let decl_list' = list_map toplevel_decl_process_locs decl_list in
let decl_list' = IList.map toplevel_decl_process_locs decl_list in
Clang_ast_t.TranslationUnitDecl (decl_info, decl_list', decl_context_info, type_list)
| _ ->
assert false

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

@ -86,7 +86,7 @@ let curr_class_to_string curr_class =
match curr_class with
| ContextCls (name, superclass, protocols) ->
("class " ^ name ^ ", superclass: " ^ (Option.default "" superclass) ^
", protocols: " ^ (Utils.list_to_string (fun x -> x) protocols))
", protocols: " ^ (IList.to_string (fun x -> x) protocols))
| ContextCategory (name, cls) -> ("category " ^ name ^ " of class " ^ cls)
| ContextProtocol name -> ("protocol " ^ name)
| ContextNoCls -> "no class"
@ -121,7 +121,7 @@ let create_curr_class tenv class_name =
let class_tn_name = Sil.TN_csu (Sil.Class, (Mangled.from_string class_name)) in
match Sil.tenv_lookup tenv class_tn_name with
| Some Sil.Tstruct(intf_fields, _, _, _, superclasses, methods, annotation) ->
(let superclasses_names = list_map (fun (_, name) -> Mangled.to_string name) superclasses in
(let superclasses_names = IList.map (fun (_, name) -> Mangled.to_string name) superclasses in
match superclasses_names with
| superclass:: protocols ->
ContextCls (class_name, Some superclass, protocols)

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

@ -83,7 +83,7 @@ let build_sil_field_property curr_class tenv field_name type_ptr prop_attributes
match prop_attributes_opt with
| Some prop_attributes -> prop_attributes
| None -> ivar_property curr_class field_name in
let atts_str = list_map Clang_ast_j.string_of_property_attribute prop_attributes in
let atts_str = IList.map Clang_ast_j.string_of_property_attribute prop_attributes in
build_sil_field tenv field_name type_ptr atts_str
(* Given a list of declarations in an interface returns a list of fields *)
@ -98,8 +98,8 @@ let rec get_fields tenv curr_class decl_list =
Printing.log_out " ...Adding Instance Variable '%s' @." name_info.Clang_ast_t.ni_name;
let (fname, typ, ia) = build_sil_field_property curr_class tenv name_info type_ptr None in
Printing.log_out " ...Resulting sil field: (%s) with attributes:@." ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ));
list_iter (fun (ia', _) ->
list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia;
IList.iter (fun (ia', _) ->
IList.iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia;
(fname, typ, ia):: fields
| ObjCPropertyImplDecl (decl_info, property_impl_decl_info):: decl_list' ->
let property_fields_decl =

8
infer/src/clang/cFrontend.ml
Unescape View File

@ -42,7 +42,7 @@ let rec translate_one_declaration tenv cg cfg namespace parent_dec dec =
let method_decls = CTypes_decl.get_method_decls dec decl_list in
let tranlate_method (parent, decl) =
translate_one_declaration tenv cg cfg namespace parent decl in
list_iter tranlate_method method_decls
IList.iter tranlate_method method_decls
| VarDecl(decl_info, name_info, t, _) ->
Printing.log_out "Nothing to do for global variable %s " name_info.Clang_ast_t.ni_name
@ -97,10 +97,10 @@ let rec translate_one_declaration tenv cg cfg namespace parent_dec dec =
| LinkageSpecDecl(decl_info, decl_list, decl_context_info) ->
Printing.log_out "ADDING: LinkageSpecDecl decl list\n";
list_iter (translate_one_declaration tenv cg cfg namespace dec) decl_list
IList.iter (translate_one_declaration tenv cg cfg namespace dec) decl_list
| NamespaceDecl(decl_info, name_info, decl_list, decl_context_info, _) ->
let name = ns_suffix^name_info.Clang_ast_t.ni_name in
list_iter (translate_one_declaration tenv cg cfg (Some name) dec) decl_list
IList.iter (translate_one_declaration tenv cg cfg (Some name) dec) decl_list
| EmptyDecl _ ->
Printing.log_out "Passing from EmptyDecl. Treated as skip\n";
| dec ->
@ -114,7 +114,7 @@ let compute_icfg tenv source_file ast =
Printing.log_out "\n Start creating icfg\n";
let cg = Cg.create () in
let cfg = Cfg.Node.create_cfg () in
list_iter (translate_one_declaration tenv cg cfg None ast) decl_list;
IList.iter (translate_one_declaration tenv cg cfg None ast) decl_list;
Printing.log_out "\n Finished creating icfg\n";
(cg, cfg)
| _ -> assert false (* NOTE: Assumes that an AST alsways starts with a TranslationUnitDecl *)

22
infer/src/clang/cFrontend_utils.ml
Unescape View File

@ -38,14 +38,14 @@ struct
(match typ with (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline (
(Sil.typename_to_string typname)^"\n"^
"---> superclass and protocols "^(list_to_string (fun (csu, x) ->
"---> superclass and protocols "^(IList.to_string (fun (csu, x) ->
let nsu = Sil.TN_csu (csu, x) in
"\t"^(Sil.typename_to_string nsu)^"\n") super_classes)^
"---> methods "^(list_to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^
"\t---> static fields "^(list_to_string (fun (fieldname, typ, _) ->
"---> methods "^(IList.to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^
"\t---> static fields "^(IList.to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") static_fields)^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t---> fields "^(IList.to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") fields
)
@ -63,7 +63,7 @@ struct
| (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline (
(Sil.typename_to_string typname)^"\n"^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t---> fields "^(IList.to_string (fun (fieldname, typ, _) ->
match typ with
| Sil.Tvar tname -> "tvar"^(Sil.typename_to_string tname)
| Sil.Tstruct (_, _, _, _, _, _, _) | _ ->
@ -81,7 +81,7 @@ struct
let print_procedures cfg =
let procs = Cfg.get_all_procs cfg in
print_endline
(list_to_string (fun pdesc ->
(IList.to_string (fun pdesc ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
"name> "^
(Procname.to_string pname) ^
@ -92,7 +92,7 @@ struct
L.err "AST Element> %s IN FILE> %s @.@." pointer !CFrontend_config.json
let print_nodes nodes =
list_iter (fun node -> print_endline (Cfg.Node.get_description Utils.pe_text node)) nodes
IList.iter (fun node -> print_endline (Cfg.Node.get_description Utils.pe_text node)) nodes
let instrs_to_string instrs =
let pp fmt () = Format.fprintf fmt "%a" (Sil.pp_instr_list Utils.pe_text) instrs in
@ -151,7 +151,7 @@ struct
match name_info.Clang_ast_t.ni_qual_name with
| [] -> ""
| name :: qualifiers ->
list_fold_right (fun el res -> res ^ el ^ "::") qualifiers ""
IList.fold_right (fun el res -> res ^ el ^ "::") qualifiers ""
let make_name_decl name = {
Clang_ast_t.ni_name = name;
@ -364,7 +364,7 @@ struct
let rec append_no_duplicates eq list1 list2 =
match list2 with
| el:: rest2 ->
if (list_mem eq el list1) then
if (IList.mem eq el list1) then
(append_no_duplicates eq list1 rest2)
else (append_no_duplicates eq list1 rest2)@[el]
| [] -> list1
@ -393,7 +393,7 @@ struct
let sort_fields fields =
let compare (name1, _, _) (name2, _, _) =
Ident.fieldname_compare name1 name2 in
list_sort compare fields
IList.sort compare fields
let rec collect_list_tuples l (a, a1, b, c, d) =
match l with
@ -447,7 +447,7 @@ struct
if n < i then acc else aux (n -1) (n :: acc)
in aux j [] ;;
let replicate n el = list_map (fun i -> el) (list_range 0 (n -1))
let replicate n el = IList.map (fun i -> el) (list_range 0 (n -1))
let mk_class_field_name field_qual_name =
let field_name = field_qual_name.Clang_ast_t.ni_name in

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

@ -125,9 +125,9 @@ let get_line stmt_info line_number =
let check_source_file source_file =
let extensions_allowed = [".m"; ".mm"; ".c"; ".cc"; ".cpp"; ".h"] in
let allowed = list_exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in
let allowed = IList.exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in
if not allowed then
(Printing.log_stats "%s"
("\nThe source file "^source_file^
" should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n");
" should end with "^(IList.to_string (fun x -> x) extensions_allowed)^"\n\n");
assert false)

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

@ -112,7 +112,7 @@ struct
Printing.log_out "ADDING: ObjCPropertyImplDecl for property '%s' "
pname.Clang_ast_t.ni_name;
let getter_setter = ObjcProperty_decl.make_getter_setter curr_class decl_info pname in
list_iter (process_one_method_decl tenv cg cfg curr_class namespace) getter_setter
IList.iter (process_one_method_decl tenv cg cfg curr_class namespace) getter_setter
| EmptyDecl _ | ObjCIvarDecl _ | ObjCPropertyDecl _ -> ()
| _ ->
Printing.log_stats
@ -120,7 +120,7 @@ struct
()
let process_methods tenv cg cfg curr_class namespace decl_list =
list_iter (process_one_method_decl tenv cg cfg curr_class namespace) decl_list
IList.iter (process_one_method_decl tenv cg cfg curr_class namespace) decl_list
let process_getter_setter context procname =
(*If there is already a spec for the method we want to generate (in incremental analysis) *)
@ -142,7 +142,7 @@ struct
if is_getter then
ObjcProperty_decl.make_getter cls property_name property_type
else ObjcProperty_decl.make_setter cls property_name property_type in
list_iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor;
IList.iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor;
true)
| _ -> false

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

@ -64,7 +64,7 @@ let replace_name_ms ms name =
let ms_to_string ms =
let gen = if ms._is_generated then " (generated)" else "" in
"Method " ^ (Procname.to_string ms._name) ^ gen ^ " " ^
Utils.list_to_string
IList.to_string
(fun (s1, s2, _) -> s1 ^ ", " ^ (Clang_ast_j.string_of_type_ptr s2))
ms._args
^ "->" ^ (Clang_ast_j.string_of_type_ptr ms._ret_type) ^ " " ^

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

@ -74,7 +74,7 @@ let get_parameters function_method_decl_info =
(name, type_ptr, var_decl_info.Clang_ast_t.vdi_init_expr)
| _ -> assert false in
let pars = list_map par_to_ms_par (get_param_decls function_method_decl_info) in
let pars = IList.map par_to_ms_par (get_param_decls function_method_decl_info) in
get_class_param function_method_decl_info @ pars
let get_return_type function_method_decl_info =
@ -102,7 +102,7 @@ let get_assume_not_null_calls ms param_decls =
let assume_call = Ast_expressions.create_assume_not_null_call decl_info name tp in
[(`ClangStmt assume_call)]
| _ -> [] in
list_flatten (list_map do_one_param param_decls)
IList.flatten (IList.map do_one_param param_decls)
let method_signature_of_decl class_name_opt meth_decl block_data_opt =
let open Clang_ast_t in
@ -214,7 +214,7 @@ let get_return_type tenv ms =
let sil_func_attributes_of_attributes attrs =
let rec do_translation acc al = match al with
| [] -> list_rev acc
| [] -> IList.rev acc
| Clang_ast_t.SentinelAttr attribute_info:: tl ->
let (sentinel, null_pos) = match attribute_info.Clang_ast_t.ai_parameters with
| a:: b::[] -> (int_of_string a, int_of_string b)
@ -239,14 +239,14 @@ let should_create_procdesc cfg procname defined generated =
(** Creates a procedure description. *)
let create_local_procdesc cfg tenv ms fbody captured is_objc_inst_method =
let defined = not ((list_length fbody) == 0) in
let defined = not ((IList.length fbody) == 0) in
let proc_name = CMethod_signature.ms_get_name ms in
let pname = Procname.to_string proc_name in
let attributes = sil_func_attributes_of_attributes (CMethod_signature.ms_get_attributes ms) in
let is_generated = CMethod_signature.ms_is_generated ms in
let create_new_procdesc () =
let formals = get_formal_parameters tenv ms in
let captured_str = list_map (fun (s, t, _) -> (Mangled.to_string s, t)) captured in
let captured_str = IList.map (fun (s, t, _) -> (Mangled.to_string s, t)) captured in
(* Captured variables for blocks are treated as parameters *)
let formals = captured_str @formals in
let source_range = CMethod_signature.ms_get_loc ms in
@ -254,7 +254,7 @@ let create_local_procdesc cfg tenv ms fbody captured is_objc_inst_method =
let loc_start = CLocation.get_sil_location_from_range source_range true in
let loc_exit = CLocation.get_sil_location_from_range source_range false in
let ret_type = get_return_type tenv ms in
let captured' = list_map (fun (s, t, _) -> (s, t)) captured in
let captured' = IList.map (fun (s, t, _) -> (s, t)) captured in
let procdesc =
let proc_attributes =
{ (ProcAttributes.default proc_name Config.C_CPP) with
@ -293,7 +293,7 @@ let create_external_procdesc cfg proc_name is_objc_inst_method type_opt =
let ret_type, formals =
(match type_opt with
| Some (ret_type, arg_types) ->
ret_type, list_map (fun typ -> ("x", typ)) arg_types
ret_type, IList.map (fun typ -> ("x", typ)) arg_types
| None -> Sil.Tvoid, []) in
let loc = Location.dummy in
let _ =

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

@ -103,10 +103,10 @@ struct
let fname = General_utils.mk_class_field_name qual_name in
let item_annot = Sil.item_annotation_empty in
fname, typ, item_annot in
let fields = list_map mk_field_from_captured_var captured_vars in
let fields = IList.map mk_field_from_captured_var captured_vars in
let fields = CFrontend_utils.General_utils.sort_fields fields in
Printing.log_out "Block %s field:\n" block_name;
list_iter (fun (fn, ft, _) ->
IList.iter (fun (fn, ft, _) ->
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
let mblock = Mangled.from_string block_name in
let block_type = Sil.Tstruct(fields, [], Sil.Class, Some mblock, [], [], []) in
@ -124,16 +124,16 @@ struct
let block_nullify_instr =
if pred_exit = [] then
[Sil.Nullify(block_var, loc, true)]
else (list_iter (fun n -> let loc = Cfg.Node.get_loc n in
else (IList.iter (fun n -> let loc = Cfg.Node.get_loc n in
Cfg.Node.append_instrs_temps n [Sil.Nullify(block_var, loc, true)] []) pred_exit;
[]) in
let set_instr = Sil.Set(Sil.Lvar block_var, block_type, Sil.Var id_block, loc) in
let ids, captured_instrs = list_split (list_map (fun (vname, typ, _) ->
let ids, captured_instrs = IList.split (IList.map (fun (vname, typ, _) ->
let id = Ident.create_fresh Ident.knormal in
id, Sil.Letderef(id, Sil.Lvar (Sil.mk_pvar vname procname), typ, loc)
) captured_vars) in
let fields_ids = list_combine fields ids in
let set_fields = list_map (fun ((f, t, _), id) ->
let fields_ids = IList.combine fields ids in
let set_fields = IList.map (fun ((f, t, _), id) ->
Sil.Set(Sil.Lfield(Sil.Var id_block, f, block_type), t, Sil.Var id, loc)) fields_ids in
(declare_block_local :: trans_res.instrs) @ [set_instr] @ captured_instrs @ set_fields @ block_nullify_instr,
id_block :: ids
@ -154,7 +154,7 @@ struct
insts := Sil.Letderef (id, block, t, loc) :: !insts;
[(Sil.Var id, t)]
| _ -> [(e, t)] in
let get_function_name t el = list_flatten(list_map (is_function_name t) el) in
let get_function_name t el = IList.flatten(IList.map (is_function_name t) el) in
let rec f es =
match es with
| [] -> []
@ -436,7 +436,7 @@ struct
if res_trans_idx.root_nodes <> []
then
list_iter
IList.iter
(fun n -> Cfg.Node.set_succs_exn n res_trans_idx.root_nodes [])
res_trans_a.leaf_nodes;
@ -491,7 +491,7 @@ struct
(* Create a node if the priority if free and there are instructions *)
let creating_node =
(PriorityNode.own_priority_node trans_state_pri.priority stmt_info) &&
(list_length instrs >0) in
(IList.length instrs >0) in
let instrs_after_assign, assign_ids, exp_to_parent =
if (is_binary_assign_op binary_operator_info)
@ -524,7 +524,7 @@ struct
(* if we are translating a condition or not *)
let ids_parent = ids_to_parent trans_state.continuation assign_ids in
let ids_node = ids_to_node trans_state.continuation assign_ids in
list_iter (fun n -> Cfg.Node.append_instrs_temps n instrs_after_assign ids_node) succ_nodes'';
IList.iter (fun n -> Cfg.Node.append_instrs_temps n instrs_after_assign ids_node) succ_nodes'';
[], ids_parent, succ_nodes''
) else (
instrs_after_assign, assign_ids, succ_nodes) in
@ -534,8 +534,8 @@ struct
let e1_succ_nodes =
if e2_has_nodes then res_trans_e2.root_nodes else succ_nodes' in
list_iter (fun n -> Cfg.Node.set_succs_exn n e1_succ_nodes []) res_trans_e1.leaf_nodes;
list_iter (fun n -> Cfg.Node.set_succs_exn n succ_nodes' []) res_trans_e2.leaf_nodes;
IList.iter (fun n -> Cfg.Node.set_succs_exn n e1_succ_nodes []) res_trans_e1.leaf_nodes;
IList.iter (fun n -> Cfg.Node.set_succs_exn n succ_nodes' []) res_trans_e2.leaf_nodes;
let root_nodes_to_ancestor = match e1_has_nodes, e2_has_nodes with
| false, false -> succ_nodes'
@ -549,12 +549,12 @@ struct
Printing.log_out "....BinaryOperator '%s' " bok;
Printing.log_out "has ids_to_ancestor |ids_to_ancestor|=%s "
(string_of_int (list_length ids_to_ancestor));
(string_of_int (IList.length ids_to_ancestor));
Printing.log_out " |nodes_e1|=%s .\n"
(string_of_int (list_length res_trans_e1.root_nodes));
(string_of_int (IList.length res_trans_e1.root_nodes));
Printing.log_out " |nodes_e2|=%s .\n"
(string_of_int (list_length res_trans_e2.root_nodes));
list_iter (fun id -> Printing.log_out " ... '%s'\n"
(string_of_int (IList.length res_trans_e2.root_nodes));
IList.iter (fun id -> Printing.log_out " ... '%s'\n"
(Ident.to_string id)) ids_to_ancestor;
{ root_nodes = root_nodes_to_ancestor;
leaf_nodes = leaf_nodes_to_ancestor;
@ -604,9 +604,9 @@ struct
else [] in
let res_trans_par =
let instruction' = exec_with_self_exception (exec_with_lvalue_as_reference instruction) in
let l = list_map (instruction' trans_state_param) params_stmt in
let l = IList.map (instruction' trans_state_param) params_stmt in
let rt = collect_res_trans (res_trans_callee :: l) in
{ rt with exps = list_tl rt.exps } in
{ rt with exps = IList.tl rt.exps } in
let sil_fe, is_cf_retain_release = CTrans_models.builtin_predefined_model fun_exp_stmt sil_fe in
if CTrans_models.is_assert_log sil_fe then
if Config.report_assertion_failure then
@ -614,7 +614,7 @@ struct
else
CTrans_utils.trans_assume_false sil_loc context trans_state.succ_nodes
else
let act_params = if list_length res_trans_par.exps = list_length params_stmt then
let act_params = if IList.length res_trans_par.exps = IList.length params_stmt then
res_trans_par.exps
else (Printing.log_err
"WARNING: stmt_list and res_trans_par.exps must have same size. NEED TO BE FIXED\n\n";
@ -673,8 +673,8 @@ struct
let result_trans_callee = instruction trans_state_callee fun_exp_stmt in
(* first for method address, second for 'this' expression *)
assert ((list_length result_trans_callee.exps) = 2);
let (sil_method, typ_method) = list_hd result_trans_callee.exps in
assert ((IList.length result_trans_callee.exps) = 2);
let (sil_method, typ_method) = IList.hd result_trans_callee.exps in
let callee_pname = match sil_method with
| Sil.Const (Sil.Cfun pn) -> pn
| _ -> assert false (* method pointer not implemented, this shouldn't happen *) in
@ -687,10 +687,10 @@ struct
{ trans_state_pri with parent_line_number = line_number; succ_nodes = [] } in
let result_trans_params =
let instruction' = exec_with_lvalue_as_reference instruction in
let l = list_map (exec_with_self_exception instruction' trans_state_param) params_stmt in
let l = IList.map (exec_with_self_exception instruction' trans_state_param) params_stmt in
(* this function will automatically merge 'this' argument with rest of arguments in 'l'*)
let rt = collect_res_trans (result_trans_callee :: l) in
{ rt with exps = list_tl rt.exps } in
{ rt with exps = IList.tl rt.exps } in
let actual_params = result_trans_params.exps in
let ret_id = if (Sil.typ_equal function_type Sil.Tvoid) then []
@ -743,7 +743,7 @@ struct
obj_c_message_expr_info, empty_res_trans) in
let instruction' =
exec_with_self_exception (exec_with_lvalue_as_reference instruction) in
let l = list_map (instruction' trans_state_param) rest in
let l = IList.map (instruction' trans_state_param) rest in
obj_c_message_expr_info, collect_res_trans (fst_res_trans :: l)
| [] -> obj_c_message_expr_info, empty_res_trans) in
let (class_type, _, _, _) = CMethod_trans.get_class_selector_instance context obj_c_message_expr_info res_trans_par.exps in
@ -790,36 +790,36 @@ struct
let loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number trans_state.context in
let res_state = instruction trans_state transformed_stmt in
(* Add declare locals to the first node *)
list_iter (fun n -> Cfg.Node.prepend_instrs_temps n [Sil.Declare_locals([(pvar, typ)], loc)] []) res_state.root_nodes;
let preds = list_flatten (list_map (fun n -> Cfg.Node.get_preds n) trans_state.succ_nodes) in
IList.iter (fun n -> Cfg.Node.prepend_instrs_temps n [Sil.Declare_locals([(pvar, typ)], loc)] []) res_state.root_nodes;
let preds = IList.flatten (IList.map (fun n -> Cfg.Node.get_preds n) trans_state.succ_nodes) in
(* Add nullify of the temp block var to the last node (predecessor or the successor nodes)*)
list_iter (fun n -> Cfg.Node.append_instrs_temps n [Sil.Nullify(pvar, loc, true)] []) preds;
IList.iter (fun n -> Cfg.Node.append_instrs_temps n [Sil.Nullify(pvar, loc, true)] []) preds;
res_state
and block_enumeration_trans trans_state stmt_info stmt_list ei =
let declare_nullify_vars loc res_state roots preds (pvar, typ) =
(* Add nullify of the temp block var to the last node (predecessor or the successor nodes)*)
list_iter (fun n -> Cfg.Node.append_instrs_temps n [Sil.Nullify(pvar, loc, true)] []) preds in
IList.iter (fun n -> Cfg.Node.append_instrs_temps n [Sil.Nullify(pvar, loc, true)] []) preds in
Printing.log_out "\n Call to a block enumeration function treated as special case...\n@.";
let procname = Cfg.Procdesc.get_proc_name trans_state.context.CContext.procdesc in
let pvar = CFrontend_utils.General_utils.get_next_block_pvar procname in
let transformed_stmt, vars_to_register =
Ast_expressions.translate_block_enumerate (Sil.pvar_to_string pvar) stmt_info stmt_list ei in
let pvars_types = list_map (fun (v, pointer, tp) ->
let pvars_types = IList.map (fun (v, pointer, tp) ->
let pvar = Sil.mk_pvar (Mangled.from_string v) procname in
let typ = CTypes_decl.type_ptr_to_sil_type trans_state.context.CContext.tenv tp in
(pvar, typ)) vars_to_register in
let loc = CLocation.get_sil_location stmt_info trans_state.parent_line_number trans_state.context in
let res_state = instruction trans_state transformed_stmt in
let preds = list_flatten (list_map (fun n -> Cfg.Node.get_preds n) trans_state.succ_nodes) in
list_iter (declare_nullify_vars loc res_state res_state.root_nodes preds) pvars_types;
let preds = IList.flatten (IList.map (fun n -> Cfg.Node.get_preds n) trans_state.succ_nodes) in
IList.iter (declare_nullify_vars loc res_state res_state.root_nodes preds) pvars_types;
res_state
and compoundStmt_trans trans_state stmt_info stmt_list =
let line_number = CLocation.get_line stmt_info trans_state.parent_line_number in
let trans_state' = { trans_state with parent_line_number = line_number } in
instructions trans_state' (list_rev stmt_list)
instructions trans_state' (IList.rev stmt_list)
and conditionalOperator_trans trans_state stmt_info stmt_list expr_info =
let context = trans_state.context in
@ -870,7 +870,7 @@ struct
Cfg.Node.set_succs_exn n [join_node] [];
[n]
| _, true ->
list_iter
IList.iter
(fun n' ->
(* If there is a node with instructions we need to only *)
(* add the set of the temp variable *)
@ -881,9 +881,9 @@ struct
) node_b;
node_b
| _, false -> node_b) in
let prune_nodes_t, prune_nodes_f = list_partition is_true_prune_node prune_nodes in
let prune_nodes_t, prune_nodes_f = IList.partition is_true_prune_node prune_nodes in
let prune_nodes' = if branch then prune_nodes_t else prune_nodes_f in
list_iter (fun n -> Cfg.Node.set_succs_exn n nodes_branch []) prune_nodes' in
IList.iter (fun n -> Cfg.Node.set_succs_exn n nodes_branch []) prune_nodes' in
(match stmt_list with
| [cond; exp1; exp2] ->
let typ =
@ -932,8 +932,8 @@ struct
let e', instrs' = define_condition_side_effects context res_trans_cond.exps res_trans_cond.instrs sil_loc in
let prune_t = mk_prune_node true e' res_trans_cond.ids instrs' in
let prune_f = mk_prune_node false e' res_trans_cond.ids instrs' in
list_iter (fun n' -> Cfg.Node.set_succs_exn n' [prune_t; prune_f] []) res_trans_cond.leaf_nodes;
let rnodes = if (list_length res_trans_cond.root_nodes) = 0 then
IList.iter (fun n' -> Cfg.Node.set_succs_exn n' [prune_t; prune_f] []) res_trans_cond.leaf_nodes;
let rnodes = if (IList.length res_trans_cond.root_nodes) = 0 then
[prune_t; prune_f]
else res_trans_cond.root_nodes in
{ root_nodes = rnodes; leaf_nodes =[prune_t; prune_f]; ids = res_trans_cond.ids; instrs = instrs'; exps = e' } in
@ -947,7 +947,7 @@ struct
(* the condition to decide its truth value). *)
let short_circuit binop s1 s2 =
let res_trans_s1 = cond_trans trans_state s1 in
let prune_nodes_t, prune_nodes_f = list_partition is_true_prune_node res_trans_s1.leaf_nodes in
let prune_nodes_t, prune_nodes_f = IList.partition is_true_prune_node res_trans_s1.leaf_nodes in
let res_trans_s2 = cond_trans trans_state s2 in
(* prune_to_s2 is the prune node that is connected with the root node of the *)
(* translation of s2.*)
@ -957,9 +957,9 @@ struct
| Sil.LAnd -> prune_nodes_t, prune_nodes_f
| Sil.LOr -> prune_nodes_f, prune_nodes_t
| _ -> assert false) in
list_iter (fun n -> Cfg.Node.set_succs_exn n res_trans_s2.root_nodes []) prune_to_s2;
IList.iter (fun n -> Cfg.Node.set_succs_exn n res_trans_s2.root_nodes []) prune_to_s2;
let root_nodes_to_parent =
if (list_length res_trans_s1.root_nodes) = 0 then res_trans_s1.leaf_nodes else res_trans_s1.root_nodes in
if (IList.length res_trans_s1.root_nodes) = 0 then res_trans_s1.leaf_nodes else res_trans_s1.root_nodes in
let (exp1, typ1) = extract_exp res_trans_s1.exps in
let (exp2, typ2) = extract_exp res_trans_s2.exps in
let e_cond = Sil.BinOp (binop, exp1, exp2) in
@ -995,9 +995,9 @@ struct
let nodes_branch = (match res_trans_b.root_nodes with
| [] -> [create_node (Cfg.Node.Stmt_node "IfStmt Branch" ) res_trans_b.ids res_trans_b.instrs sil_loc context]
| _ -> res_trans_b.root_nodes) in
let prune_nodes_t, prune_nodes_f = list_partition is_true_prune_node prune_nodes in
let prune_nodes_t, prune_nodes_f = IList.partition is_true_prune_node prune_nodes in
let prune_nodes' = if branch then prune_nodes_t else prune_nodes_f in
list_iter (fun n -> Cfg.Node.set_succs_exn n nodes_branch []) prune_nodes';
IList.iter (fun n -> Cfg.Node.set_succs_exn n nodes_branch []) prune_nodes';
res_trans_b.ids in
(match stmt_list with
| [null_stmt; cond; stmt1; stmt2] -> (* Note: for the moment we don't do anything with the null_stmt/decl*)
@ -1065,7 +1065,7 @@ struct
aux rest (x :: acc) cases
| [] ->
cases, acc) in
aux (list_rev stmt_list) [] [] in
aux (IList.rev stmt_list) [] [] in
let list_of_cases, pre_case_stmts = merge_into_cases stmt_list in
let rec connected_instruction rev_instr_list successor_nodes =
(* returns the entry point of the translated set of instr *)
@ -1104,7 +1104,7 @@ struct
| [] -> next_nodes, next_prune_nodes
| CaseStmt(stmt_info, _ :: _ :: case_content) as case :: rest ->
let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in
let case_entry_point = connected_instruction (list_rev case_content) last_nodes in
let case_entry_point = connected_instruction (IList.rev case_content) last_nodes in
(* connects between cases, then continuation has priority about breaks *)
let prune_node_t, prune_node_f = create_prune_nodes_for_case case in
Cfg.Node.set_succs_exn prune_node_t case_entry_point [];
@ -1115,21 +1115,21 @@ struct
let placeholder_entry_point =
create_node (Cfg.Node.Stmt_node "DefaultStmt_placeholder") [] [] sil_loc context in
let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes [placeholder_entry_point] in
let default_entry_point = connected_instruction (list_rev default_content) last_nodes in
let default_entry_point = connected_instruction (IList.rev default_content) last_nodes in
Cfg.Node.set_succs_exn placeholder_entry_point default_entry_point [];
default_entry_point, last_prune_nodes
| _ -> assert false in
let top_entry_point, top_prune_nodes = translate_and_connect_cases list_of_cases succ_nodes succ_nodes in
let _ = connected_instruction (list_rev pre_case_stmts) top_entry_point in
let _ = connected_instruction (IList.rev pre_case_stmts) top_entry_point in
Cfg.Node.set_succs_exn switch_special_cond_node top_prune_nodes [];
let top_nodes =
match res_trans_cond.root_nodes with
| [] -> (* here if no root or if the translation of cond needed priority *)
[switch_special_cond_node]
| _ ->
list_iter (fun n' -> Cfg.Node.set_succs_exn n' [switch_special_cond_node] []) res_trans_cond.leaf_nodes;
IList.iter (fun n' -> Cfg.Node.set_succs_exn n' [switch_special_cond_node] []) res_trans_cond.leaf_nodes;
res_trans_cond.root_nodes in
list_iter (fun n' -> Cfg.Node.append_instrs_temps n' [] res_trans_cond.ids) succ_nodes; (* succ_nodes will remove the temps *)
IList.iter (fun n' -> Cfg.Node.append_instrs_temps n' [] res_trans_cond.ids) succ_nodes; (* succ_nodes will remove the temps *)
{ root_nodes = top_nodes; leaf_nodes = succ_nodes; ids = []; instrs = []; exps =[]}
| _ -> assert false
@ -1138,7 +1138,7 @@ struct
let stmt = extract_stmt_from_singleton stmt_list "ERROR: StmtExpr should have only one statement.\n" in
let res_trans_stmt = instruction trans_state stmt in
let idl = res_trans_stmt.ids in
let exps' = list_rev res_trans_stmt.exps in
let exps' = IList.rev res_trans_stmt.exps in
match exps' with
| (last, typ) :: _ ->
(* The StmtExpr contains a single CompoundStmt node, which it evaluates and *)
@ -1210,14 +1210,14 @@ struct
| Loops.For _ | Loops.While _ -> res_trans_cond.root_nodes
| Loops.DoWhile _ -> res_trans_body.root_nodes in
(* Note: prune nodes are by contruction the res_trans_cond.leaf_nodes *)
let prune_nodes_t, prune_nodes_f = list_partition is_true_prune_node res_trans_cond.leaf_nodes in
let prune_nodes_t, prune_nodes_f = IList.partition is_true_prune_node res_trans_cond.leaf_nodes in
let prune_t_succ_nodes =
match loop_kind with
| Loops.For _ | Loops.While _ -> res_trans_body.root_nodes
| Loops.DoWhile _ -> [join_node] in
Cfg.Node.set_succs_exn join_node join_succ_nodes [];
list_iter (fun n -> Cfg.Node.set_succs_exn n prune_t_succ_nodes []) prune_nodes_t;
list_iter (fun n -> Cfg.Node.set_succs_exn n succ_nodes []) prune_nodes_f;
IList.iter (fun n -> Cfg.Node.set_succs_exn n prune_t_succ_nodes []) prune_nodes_t;
IList.iter (fun n -> Cfg.Node.set_succs_exn n succ_nodes []) prune_nodes_f;
let root_nodes =
match loop_kind with
| Loops.For _ ->
@ -1282,7 +1282,7 @@ struct
if res_trans_to_parent.root_nodes <> []
then res_trans_to_parent.root_nodes
else trans_state_pri.succ_nodes in
list_iter
IList.iter
(fun n -> Cfg.Node.set_succs_exn n trans_s1_succs [])
res_trans_s1.leaf_nodes;
@ -1306,7 +1306,7 @@ struct
let succ_nodes = trans_state.succ_nodes in
let rec collect_right_hand_exprs ts stmt = match stmt with
| Clang_ast_t.InitListExpr (_ , stmts , _) ->
list_flatten (list_map (collect_right_hand_exprs ts) stmts)
IList.flatten (IList.map (collect_right_hand_exprs ts) stmts)
| _ ->
let trans_state' = { ts with succ_nodes = []} in
let res_trans_stmt = instruction trans_state' stmt in
@ -1326,35 +1326,35 @@ struct
else (collect_left_hand_exprs e tvar (StringSet.add (Sil.typename_to_string typename) tns));
| _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*))
| Sil.Tstruct (struct_fields, _, _, _, _, _, _) as type_struct ->
let lh_exprs = list_map ( fun (fieldname, fieldtype, _) ->
let lh_exprs = IList.map ( fun (fieldname, fieldtype, _) ->
Sil.Lfield (e, fieldname, type_struct) )
struct_fields in
let lh_types = list_map ( fun (fieldname, fieldtype, _) -> fieldtype)
let lh_types = IList.map ( fun (fieldname, fieldtype, _) -> fieldtype)
struct_fields in
list_map (fun (e, t) -> list_flatten (collect_left_hand_exprs e t tns)) (zip lh_exprs lh_types)
IList.map (fun (e, t) -> IList.flatten (collect_left_hand_exprs e t tns)) (zip lh_exprs lh_types)
| Sil.Tarray (arrtyp, Sil.Const(Sil.Cint(n))) ->
let size = Sil.Int.to_int n in
let indices = list_range 0 (size - 1) in
let index_constants = list_map
let index_constants = IList.map
(fun i -> (Sil.Const (Sil.Cint (Sil.Int.of_int i))))
indices in
let lh_exprs = list_map
let lh_exprs = IList.map
(fun index_expr -> Sil.Lindex (e, index_expr))
index_constants in
let lh_types = replicate size arrtyp in
list_map (fun (e, t) -> list_flatten (collect_left_hand_exprs e t tns)) (zip lh_exprs lh_types)
IList.map (fun (e, t) -> IList.flatten (collect_left_hand_exprs e t tns)) (zip lh_exprs lh_types)
| _ -> [ [(e, typ)] ] in
let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in
let var_type = CTypes_decl.type_ptr_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_type_ptr in
let lh = list_flatten (collect_left_hand_exprs (Sil.Lvar pvar) var_type Utils.StringSet.empty) in
let rh = list_flatten (list_map (collect_right_hand_exprs trans_state_pri) stmts ) in
if (list_length rh != list_length lh) then (
let lh = IList.flatten (collect_left_hand_exprs (Sil.Lvar pvar) var_type Utils.StringSet.empty) in
let rh = IList.flatten (IList.map (collect_right_hand_exprs trans_state_pri) stmts ) in
if (IList.length rh != IList.length lh) then (
(* If the right hand expressions are not as many as the left hand expressions something's wrong *)
{ empty_res_trans with root_nodes = succ_nodes }
) else (
(* Creating new instructions by assigning right hand side to left hand side expressions *)
let sil_loc = CLocation.get_sil_location stmt_info trans_state_pri.parent_line_number context in
let big_zip = list_map
let big_zip = IList.map
(fun ( (lh_exp, lh_t), (_, _, rh_exp, is_method_call, rhs_owning_method, rh_t) ) ->
let is_pointer_object = ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv rh_t in
if !Config.arc_mode && (is_method_call || is_pointer_object) then
@ -1366,12 +1366,12 @@ struct
else
([], [Sil.Set (lh_exp, lh_t, rh_exp, sil_loc)], []))
(General_utils.zip lh rh) in
let rh_instrs = list_flatten ( list_map (fun (_, instrs, _, _, _, _) -> instrs) rh) in
let assign_instrs = list_flatten(list_map (fun (_, instrs, _) -> instrs) big_zip) in
let assign_ids = list_flatten(list_map (fun (_, _, ids) -> ids) big_zip) in
let instructions = list_append (rh_instrs) assign_instrs in
let rh_ids = list_flatten ( list_map (fun (ids, _, _, _, _, _) -> ids) rh) in
let ids = list_append (rh_ids) assign_ids in
let rh_instrs = IList.flatten ( IList.map (fun (_, instrs, _, _, _, _) -> instrs) rh) in
let assign_instrs = IList.flatten(IList.map (fun (_, instrs, _) -> instrs) big_zip) in
let assign_ids = IList.flatten(IList.map (fun (_, _, ids) -> ids) big_zip) in
let instructions = IList.append (rh_instrs) assign_instrs in
let rh_ids = IList.flatten ( IList.map (fun (ids, _, _, _, _, _) -> ids) rh) in
let ids = IList.append (rh_ids) assign_ids in
if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then (
let node_kind = Cfg.Node.Stmt_node "InitListExp" in
let node = create_node node_kind (ids) (instructions) sil_loc context in
@ -1449,10 +1449,10 @@ struct
let ids = res_trans_ie.ids@ids_assign in
let instrs = res_trans_ie.instrs@instrs_assign in
if PriorityNode.own_priority_node trans_state_pri.priority stmt_info then (
let node = list_hd next_node in
let node = IList.hd next_node in
Cfg.Node.append_instrs_temps node instrs ids;
list_iter (fun n -> Cfg.Node.set_succs_exn n [node] []) leaf_nodes;
let root_nodes = if (list_length root_nodes) = 0 then next_node else root_nodes in
IList.iter (fun n -> Cfg.Node.set_succs_exn n [node] []) leaf_nodes;
let root_nodes = if (IList.length root_nodes) = 0 then next_node else root_nodes in
{
root_nodes = root_nodes;
leaf_nodes = [];
@ -1639,7 +1639,7 @@ struct
let node = create_node node_kind ids_node instrs sil_loc context in
Cfg.Node.set_succs_exn node trans_state_pri.succ_nodes [];
list_iter (fun n -> Cfg.Node.set_succs_exn n [node] []) res_trans_stmt.leaf_nodes;
IList.iter (fun n -> Cfg.Node.set_succs_exn n [node] []) res_trans_stmt.leaf_nodes;
let root_nodes =
if res_trans_stmt.root_nodes <> [] then res_trans_stmt.root_nodes
@ -1678,9 +1678,9 @@ struct
let instrs = res_trans_stmt.instrs @ [ret_instr] @ autorelease_instrs in
let ids = res_trans_stmt.ids@autorelease_ids in
Cfg.Node.append_instrs_temps ret_node instrs ids;
list_iter (fun n -> Cfg.Node.set_succs_exn n [ret_node] []) res_trans_stmt.leaf_nodes;
IList.iter (fun n -> Cfg.Node.set_succs_exn n [ret_node] []) res_trans_stmt.leaf_nodes;
let root_nodes_to_parent =
if list_length res_trans_stmt.root_nodes >0 then res_trans_stmt.root_nodes else [ret_node] in
if IList.length res_trans_stmt.root_nodes >0 then res_trans_stmt.root_nodes else [ret_node] in
{ root_nodes = root_nodes_to_parent; leaf_nodes =[ret_node]; ids = ids; instrs = instrs; exps =[]}
| [] -> (* return; *)
{ empty_res_trans with root_nodes =[ret_node]; leaf_nodes =[ret_node]}
@ -1779,7 +1779,7 @@ struct
(* otherwise it's a static variable defined among the locals *)
(* and therefore we need the full mangled name *)
let cvar''=
if (list_exists(fun (s, t) -> Mangled.from_string s = cvar') formals) then cvar'
if (IList.exists(fun (s, t) -> Mangled.from_string s = cvar') formals) then cvar'
else cvar in
(cvar'', typ)) in
let id = Ident.create_fresh Ident.knormal in
@ -1796,13 +1796,13 @@ struct
Cg.add_edge context.cg procname block_pname;
let captured_block_vars = block_decl_info.Clang_ast_t.bdi_captured_variables in
let captured_vars = CVar_decl.captured_vars_from_block_info context captured_block_vars in
let ids_instrs = list_map assign_captured_var captured_vars in
let ids, instrs = list_split ids_instrs in
let ids_instrs = IList.map assign_captured_var captured_vars in
let ids, instrs = IList.split ids_instrs in
let block_data = (context, type_ptr, block_pname, captured_vars) in
CContext.add_block context block_pname;
M.function_decl context.tenv context.cfg context.cg context.namespace decl (Some block_data);
Cfg.set_procname_priority context.cfg block_pname;
let captured_exps = list_map (fun id -> Sil.Var id) ids in
let captured_exps = IList.map (fun id -> Sil.Var id) ids in
let tu = Sil.Ctuple ((Sil.Const (Sil.Cfun block_pname)) :: captured_exps) in
let block_name = Procname.to_string block_pname in
let alloc_block_instr, ids_block =
@ -2073,12 +2073,12 @@ struct
and get_clang_stmt_trans stmt_list =
let instruction' = fun stmt -> fun trans_state -> instruction trans_state stmt in
list_map instruction' stmt_list
IList.map instruction' stmt_list
and get_custom_stmt_trans custom_stmts =
let do_one_stmt stmt = match stmt with
| `ClangStmt stmt -> get_clang_stmt_trans [stmt] in
list_flatten (list_map do_one_stmt custom_stmts)
IList.flatten (IList.map do_one_stmt custom_stmts)
(** Given a translation state, this function translates a list of clang statements. *)
and instructions trans_state stmt_list =

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

@ -164,7 +164,7 @@ let collect_res_trans l =
if rt'.leaf_nodes <> [] then rt'.leaf_nodes
else rt.leaf_nodes in
if rt'.root_nodes <> [] then
list_iter (fun n -> Cfg.Node.set_succs_exn n rt'.root_nodes []) rt.leaf_nodes;
IList.iter (fun n -> Cfg.Node.set_succs_exn n rt'.root_nodes []) rt.leaf_nodes;
collect l'
{ root_nodes = root_nodes;
leaf_nodes = leaf_nodes;
@ -237,7 +237,7 @@ struct
let node' = mk_node () in
Cfg.Node.set_succs_exn node' trans_state.succ_nodes [];
let ids_parent = ids_to_parent trans_state.continuation res_state_param.ids in
list_iter (fun n' -> Cfg.Node.set_succs_exn n' [node'] []) res_state_param.leaf_nodes;
IList.iter (fun n' -> Cfg.Node.set_succs_exn n' [node'] []) res_state_param.leaf_nodes;
{ root_nodes = res_state_param.root_nodes;
leaf_nodes = [node'];
ids = ids_parent;
@ -455,7 +455,7 @@ let compute_instr_ids_exp_to_parent stmt_info instr ids e lhs typ loc pri =
instr@res_instr, ids @ [id], [(Sil.Var id, typ)])
let fix_param_exps_mismatch params_stmt exps_param =
let diff = list_length params_stmt - list_length exps_param in
let diff = IList.length params_stmt - IList.length exps_param in
let args = if diff >0 then Array.make diff dummy_exp
else assert false in
let exps'= exps_param @ (Array.to_list args) in
@ -497,7 +497,7 @@ let get_value_enum_constant tenv enum_type stmt =
| Some (Sil.Tenum enum_constants) ->
Printing.log_out ">>>Found enum with typename TN_typename('%s')\n" (Sil.typename_to_string typename);
let _, v = try
list_find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants
IList.find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants
with _ -> (Printing.log_err
"Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in
v
@ -687,7 +687,7 @@ let is_dispatch_function stmt_list =
| None -> None
| Some (dispatch_function, block_arg_pos) ->
try
(match list_nth stmts block_arg_pos with
(match IList.nth stmts block_arg_pos with
| BlockExpr _ -> Some block_arg_pos
| _ -> None)
with Not_found -> None
@ -722,10 +722,10 @@ let assign_default_params params_stmt class_name_opt stmt ~is_cxx_method =
default_instr
| instr, _ -> instr in
try
let params_args = list_combine params_stmt args in
list_map replace_default_arg params_args
let params_args = IList.combine params_stmt args in
IList.map replace_default_arg params_args
with Invalid_argument _ ->
(* list_combine failed because of different list lengths *)
(* IList.combine failed because of different list lengths *)
Printing.log_err "Param count doesn't match %s\n"
(Procname.to_string (CMethod_signature.ms_get_name callee_ms));
params_stmt)

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

@ -60,7 +60,7 @@ let search_enum_type_by_name tenv name =
let f tn typ =
match typ with
| Sil.Tenum enum_constants ->
list_iter (fun (c, v) -> if Mangled.equal c mname then found:= Some v else ()) enum_constants
IList.iter (fun (c, v) -> if Mangled.equal c mname then found:= Some v else ()) enum_constants
| _ -> () in
Sil.tenv_iter f tenv;
!found

10
infer/src/clang/cTypes_decl.ml
Unescape View File

@ -104,7 +104,7 @@ let get_method_decls parent decl_list =
| CXXRecordDecl (_, _, _, _, decl_list', _, _, _)
| RecordDecl (_, _, _, _, decl_list', _, _) -> traverse_decl_list decl decl_list'
| _ -> []
and traverse_decl_list parent decl_list = list_flatten (list_map (traverse_decl parent) decl_list) in
and traverse_decl_list parent decl_list = IList.flatten (IList.map (traverse_decl parent) decl_list) in
traverse_decl_list parent decl_list
let get_class_methods tenv class_name namespace decl_list =
@ -116,7 +116,7 @@ let get_class_methods tenv class_name namespace decl_list =
Some method_proc
| _ -> None in
(* poor mans list_filter_map *)
list_flatten_options (list_map process_method_decl decl_list)
IList.flatten_options (IList.map process_method_decl decl_list)
(** fetches list of superclasses for C++ classes *)
let get_superclass_list decl =
@ -124,10 +124,10 @@ let get_superclass_list decl =
| Clang_ast_t.CXXRecordDecl (_, _, _, _, _, _, _, cxx_rec_info) ->
(* there is no concept of virtual inheritance in the backend right now *)
let base_ptr = cxx_rec_info.Clang_ast_t.xrdi_bases @ cxx_rec_info.Clang_ast_t.xrdi_vbases in
let base_decls = list_map Ast_utils.get_decl_from_typ_ptr base_ptr in
let base_decls = IList.map Ast_utils.get_decl_from_typ_ptr base_ptr in
let decl_to_mangled_name decl = Mangled.from_string (get_record_name decl) in
let get_super_field super_decl = (Sil.Class, decl_to_mangled_name super_decl) in
list_map get_super_field base_decls
IList.map get_super_field base_decls
| _ -> []
let add_struct_to_tenv tenv typ =
@ -152,7 +152,7 @@ let rec get_struct_fields tenv record_name namespace decl_list =
if not decl_info.Clang_ast_t.di_is_implicit then
ignore (add_types_from_decl_to_tenv tenv namespace decl); []
| _ -> [] in
list_flatten (list_map do_one_decl decl_list)
IList.flatten (IList.map do_one_decl decl_list)
(* For a record declaration it returns/constructs the type *)
and get_declaration_type tenv namespace decl =

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

@ -100,4 +100,4 @@ let captured_vars_from_block_info context cvl =
(Sil.pvar_get_name pvar, typ, false) :: vars
| _ -> assert false)
| _ -> assert false in
list_fold_right sil_var_of_captured_var cvl []
IList.fold_right sil_var_of_captured_var cvl []

10
infer/src/clang/objcInterface_decl.ml
Unescape View File

@ -45,7 +45,7 @@ let get_super_interface_decl otdi_super =
| _ -> None
let get_protocols protocols =
let protocol_names = list_map (
let protocol_names = IList.map (
fun decl -> match decl.Clang_ast_t.dr_name with
| Some name -> name.Clang_ast_t.ni_name
| None -> assert false
@ -59,7 +59,7 @@ let get_interface_superclasses super_opt protocols =
match super_opt with
| None -> []
| Some super -> [(Sil.Class, Mangled.from_string super)] in
let protocol_names = list_map (
let protocol_names = IList.map (
fun name -> (Sil.Protocol, Mangled.from_string name)
) protocols in
let super_classes = super_class@protocol_names in
@ -74,7 +74,7 @@ let create_curr_class_and_superclasses_fields tenv decl_list class_name otdi_sup
curr_class, superclasses, fields
let update_curr_class curr_class superclasses =
let get_protocols protocols = list_fold_right (
let get_protocols protocols = IList.fold_right (
fun protocol converted_protocols ->
match protocol with
| (Sil.Protocol, name) -> (Mangled.to_string name):: converted_protocols
@ -99,7 +99,7 @@ let add_class_to_tenv tenv decl_info class_name decl_list obj_c_interface_decl_i
obj_c_interface_decl_info.Clang_ast_t.otdi_protocols in
let methods = ObjcProperty_decl.get_methods curr_class decl_list in
let fields_sc = CField_decl.fields_superclass tenv obj_c_interface_decl_info in
list_iter (fun (fn, ft, _) ->
IList.iter (fun (fn, ft, _) ->
Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn);
Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc;
(*In case we found categories, or partial definition of this class earlier and they are already in the tenv *)
@ -115,7 +115,7 @@ let add_class_to_tenv tenv decl_info class_name decl_list obj_c_interface_decl_i
let fields = General_utils.append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in
let fields = General_utils.sort_fields fields in
Printing.log_out "Class %s field:\n" class_name;
list_iter (fun (fn, ft, _) ->
IList.iter (fun (fn, ft, _) ->
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
let interface_type_info =
Sil.Tstruct(fields, [], Sil.Class, Some (Mangled.from_string class_name),

16
infer/src/clang/objcProperty_decl.ml
Unescape View File

@ -95,7 +95,7 @@ struct
with Not_found ->
match curr_class with
| ContextCls (name, _, protocols) ->
let res_opt = list_fold_right
let res_opt = IList.fold_right
(fun protocol found_procname_opt ->
match found_procname_opt with
| Some found_procname -> Some found_procname
@ -204,7 +204,7 @@ let check_for_property curr_class method_name meth_decl body =
(Property.property_key_to_string (curr_class, property_name));
upgrade_property_accessor
(curr_class, property_name) property_type meth_decl defined is_getter) in
list_iter method_is_getter properties_class in
IList.iter method_is_getter properties_class in
check_property_accessor curr_class method_name true;
check_property_accessor curr_class method_name false
@ -218,7 +218,7 @@ let method_is_property_accesor cls method_name =
if method_name = getter_name then Some (property_name, property_type, true)
else if method_name = setter_name then Some (property_name, property_type, false)
else None in
list_fold_right method_is_getter properties_class None
IList.fold_right method_is_getter properties_class None
let prepare_dynamic_property curr_class decl_info property_impl_decl_info =
let pname = Ast_utils.property_name property_impl_decl_info in
@ -249,12 +249,12 @@ let prepare_dynamic_property curr_class decl_info property_impl_decl_info =
[]
let is_property_read_only attributes =
list_mem (Ast_utils.property_attribute_eq) `Readonly attributes
IList.mem (Ast_utils.property_attribute_eq) `Readonly attributes
let get_memory_management_attribute attributes =
let memory_management_attributes = Ast_utils.get_memory_management_attributes () in
try Some (list_find (
fun att -> list_mem (Ast_utils.property_attribute_eq)
try Some (IList.find (
fun att -> IList.mem (Ast_utils.property_attribute_eq)
att memory_management_attributes) attributes)
with Not_found -> None
@ -365,7 +365,7 @@ let add_properties_to_table curr_class decl_list =
Property.add_property (curr_class, name_info) pdi.Clang_ast_t.opdi_type_ptr
pdi.Clang_ast_t.opdi_property_attributes decl_info;
| _ -> () in
list_iter add_property_to_table decl_list
IList.iter add_property_to_table decl_list
(* Given a list of declarations in an interface returns list of methods)*)
let get_methods curr_class decl_list =
@ -382,4 +382,4 @@ let get_methods curr_class decl_list =
let meth_name = General_utils.mk_procname_from_objc_method class_name method_name method_kind in
meth_name:: list_methods
| _ -> list_methods in
list_fold_right get_method decl_list []
IList.fold_right get_method decl_list []

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

@ -18,7 +18,7 @@ open Utils
(** work-in-progress list of known callback-registering method names *)
let callback_register_methods =
let method_list = ["addCallback"; "register"; "setOnClickListener"] in
list_fold_left (fun set str -> StringSet.add str set) StringSet.empty method_list
IList.fold_left (fun set str -> StringSet.add str set) StringSet.empty method_list
let is_known_callback_register_method proc_str = StringSet.mem proc_str callback_register_methods
@ -245,7 +245,7 @@ let android_callbacks =
("android.widget", "TimePicker$OnTimeChangedListener");
("android.widget", "ZoomButtonsController$OnZoomListener");
] in
list_fold_left (fun cbSet (pkg, clazz) ->
IList.fold_left (fun cbSet (pkg, clazz) ->
let qualified_name = Mangled.from_string (pkg ^ "." ^ clazz) in
Mangled.MangledSet.add qualified_name cbSet) Mangled.MangledSet.empty cb_strs
@ -260,7 +260,7 @@ let get_all_supertypes typ tenv =
| None -> typs
and get_supers_rec typ tenv all_supers =
let direct_supers = get_direct_supers typ in
list_fold_left (fun typs (_, name) -> add_typ name typs) all_supers direct_supers in
IList.fold_left (fun typs (_, name) -> add_typ name typs) all_supers direct_supers in
get_supers_rec typ tenv TypSet.empty
(** return true if [typ0] <: [typ1] *)
@ -303,7 +303,7 @@ let get_callback_registered_by procname args tenv =
(* for now, we assume a method is a callback registration method if it is a setter and has a
* callback class as a non - receiver argument *)
let is_callback_register_like =
let has_non_this_callback_arg args = list_length args > 1 in
let has_non_this_callback_arg args = IList.length args > 1 in
let has_registery_name procname =
Procname.is_java procname && (PatternMatch.is_setter procname ||
is_known_callback_register_method (Procname.java_get_method procname)) in
@ -314,9 +314,9 @@ let get_callback_registered_by procname args tenv =
if is_callback_register_like then
(* we don't want to check if the receiver is a callback class; it's one of the method arguments
* that's being registered as a callback *)
let get_non_this_args args = list_tl args in
let get_non_this_args args = IList.tl args in
try
Some (list_find (fun (_, typ) -> is_ptr_to_callback_class typ tenv) (get_non_this_args args))
Some (IList.find (fun (_, typ) -> is_ptr_to_callback_class typ tenv) (get_non_this_args args))
with Not_found -> None
else None
@ -345,12 +345,12 @@ let get_lifecycle_for_framework_typ_opt lifecycle_typ lifecycle_proc_strs tenv =
| Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) ->
(* TODO (t4645631): collect the procedures for which is_java is returning false *)
let lookup_proc lifecycle_proc =
list_find (fun decl_proc ->
IList.find (fun decl_proc ->
Procname.is_java decl_proc && lifecycle_proc = Procname.java_get_method decl_proc
) decl_procs in
(* convert each of the framework lifecycle proc strings to a lifecycle method procname *)
let lifecycle_procs =
list_fold_left (fun lifecycle_procs lifecycle_proc_str ->
IList.fold_left (fun lifecycle_procs lifecycle_proc_str ->
try (lookup_proc lifecycle_proc_str) :: lifecycle_procs
with Not_found -> lifecycle_procs)
[] lifecycle_proc_strs in
@ -380,4 +380,4 @@ let is_runtime_exception tenv exn =
let non_stub_android_jar () =
let root_dir = Filename.dirname (Filename.dirname Sys.executable_name) in
list_fold_left Filename.concat root_dir ["lib"; "java"; "android"; "android-19.jar"]
IList.fold_left Filename.concat root_dir ["lib"; "java"; "android"; "android-19.jar"]

18
infer/src/harness/harness.ml
Unescape View File

@ -22,7 +22,7 @@ let insert_after lst test to_insert =
| instr :: to_process ->
let processed' = instr :: processed in
if test instr then
list_append (list_rev processed') (list_append to_insert to_process)
IList.append (IList.rev processed') (IList.append to_insert to_process)
else
insert_rec to_process processed'
| [] -> lst in
@ -53,7 +53,7 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb
| l ->
(* choose to describe this anonymous inner class with one of the interfaces that it
* implements. translation always places interfaces at the end of the supertypes list *)
Mangled.get_mangled (list_hd (list_rev l))
Mangled.get_mangled (IList.hd (IList.rev l))
else typ_str in
Mangled.from_string (pretty_typ_str ^ "[line " ^ Location.to_string loc ^ "]") in
let create_instrumentation_fields created_flds node instr = match instr with
@ -98,7 +98,7 @@ let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv =
(* TODO (t4793988): do something more principled here *)
let harness_lvar = Sil.Lvar (Sil.mk_pvar_global harness_name) in
let lifecycle_cfg_files =
list_fold_left (fun lifecycle_files (lifecycle_proc, _) ->
IList.fold_left (fun lifecycle_files (lifecycle_proc, _) ->
try
let cfg_fname =
let source_dir = Inhabit.source_dir_from_name lifecycle_proc proc_file_map in
@ -109,7 +109,7 @@ let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv =
DB.FilenameSet.fold (fun cfg_file registered_callbacks ->
match Cfg.load_cfg_from_file cfg_file with
| Some cfg ->
list_fold_left (fun registered_callbacks procdesc ->
IList.fold_left (fun registered_callbacks procdesc ->
extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar registered_callbacks
) registered_callbacks (Cfg.get_all_procs cfg)
| None -> registered_callbacks
@ -122,7 +122,7 @@ let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map t
when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv &&
not (AndroidFramework.is_android_lib_class class_name) ->
let ptr_to_typ = Some (Sil.Tptr (typ, Sil.Pk_pointer)) in
list_fold_left (fun trace lifecycle_proc ->
IList.fold_left (fun trace lifecycle_proc ->
(* given a lifecycle subclass T, resolve the call T.lifecycle_proc() to the procname
* that will actually be called at runtime *)
let resolved_proc = SymExec.resolve_method tenv class_name lifecycle_proc in
@ -137,7 +137,7 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let harness_name = Mangled.from_string (Procname.to_string harness_procname) in
let registered_cbs =
find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv in
let fields = list_map (fun (fld, typ, _) -> (fld, typ, [])) registered_cbs in
let fields = IList.map (fun (fld, typ, _) -> (fld, typ, [])) registered_cbs in
(* create a new typ for the harness containing all of the cb extraction vars as static fields *)
let harness_typ =
Sil.Tstruct (fields, [], Sil.Class, Some harness_name, [], [harness_procname], []) in
@ -146,7 +146,7 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let harness_class = Sil.TN_csu (Sil.Class, harness_name) in
Sil.tenv_add tenv harness_class harness_typ;
let cfgs_to_save =
list_fold_left (fun cfgs_to_save (_, _, instrument_sil_f) ->
IList.fold_left (fun cfgs_to_save (_, _, instrument_sil_f) ->
(* instrument the cfg's with callback extraction code *)
let (cfg_file, cfg) = instrument_sil_f harness_typ in
DB.FilenameMap.add cfg_file cfg cfgs_to_save
@ -156,11 +156,11 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
(fun cfg_file cfg -> Cfg.store_cfg_to_file cfg_file false cfg) cfgs_to_save;
(* these are all the static fields holding callbacks that should be invoked by the harness *)
let harness_global = Sil.Lvar (Sil.mk_pvar_global harness_name) in
list_map (fun (fld, typ, _) -> (Sil.Lfield (harness_global, fld, harness_typ), typ)) fields
IList.map (fun (fld, typ, _) -> (Sil.Lfield (harness_global, fld, harness_typ), typ)) fields
(** generate a harness for each lifecycle type in an Android application *)
let create_android_harness proc_file_map tenv =
list_iter (fun (pkg, clazz, lifecycle_methods) ->
IList.iter (fun (pkg, clazz, lifecycle_methods) ->
let typ_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt typ_name lifecycle_methods tenv with
| Some (framework_typ, framework_procs) ->

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

@ -74,8 +74,8 @@ let create_fresh_local_name () =
incr local_name_cntr;
"dummy_local" ^ string_of_int !local_name_cntr
(** more forgiving variation of list_tl that won't raise an exception on the empty list *)
let tl_or_empty l = if l = [] then l else list_tl l
(** more forgiving variation of IList.tl that won't raise an exception on the empty list *)
let tl_or_empty l = if l = [] then l else IList.tl l
let get_non_receiver_formals formals = tl_or_empty formals
@ -113,9 +113,9 @@ let rec inhabit_typ typ proc_file_map env =
let try_get_non_receiver_formals p =
try get_non_receiver_formals (formals_from_name p proc_file_map)
with Not_found -> [] in
Procname.is_constructor p && list_for_all (fun (_, typ) ->
Procname.is_constructor p && IList.for_all (fun (_, typ) ->
not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in
list_filter (fun p -> is_suitable_constructor p) methods
IList.filter (fun p -> is_suitable_constructor p) methods
| _ -> [] in
let (env, typ_class_name) = match get_all_suitable_constructors typ with
| constructor :: _ ->
@ -155,7 +155,7 @@ and inhabit_args formals proc_file_map env =
let inhabit_arg (formal_name, formal_typ) (args, env) =
let (exp, env) = inhabit_typ formal_typ proc_file_map env in
((exp, formal_typ) :: args, env) in
list_fold_right inhabit_arg formals ([], env)
IList.fold_right inhabit_arg formals ([], env)
(** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the
* remaining arguments *)
@ -219,12 +219,12 @@ let inhabit_fld_trace flds proc_file_map env =
with Not_found ->
(* TODO (t4645631): investigate why this failure occurs *)
env in
list_fold_left (fun env procname ->
IList.fold_left (fun env procname ->
if not (Procname.is_constructor procname) &&
not (Procname.java_is_access_method procname) then inhabit_cb_call procname env
else env) env procs
| _ -> assert false in
list_fold_left (fun env fld -> invoke_cb fld env) env flds
IList.fold_left (fun env fld -> invoke_cb fld env) env flds
(** create a dummy file for the harness and associate them in the exe_env *)
let create_dummy_harness_file harness_name harness_cfg tenv =
@ -244,7 +244,7 @@ let write_harness_to_file harness_instrs harness_file =
let harness_file =
let harness_file_name = DB.source_file_to_string harness_file in
ref (create_outfile harness_file_name) in
let pp_harness fmt = list_iter (fun instr ->
let pp_harness fmt = IList.iter (fun instr ->
Format.fprintf fmt "%a\n" (Sil.pp_instr pe_text) instr) harness_instrs in
do_outf harness_file (fun outf ->
pp_harness outf.fmt;
@ -277,7 +277,7 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
let ret_type = lookup_typ (Procname.java_get_return_type proc_name) in
let formals =
let param_strs = Procname.java_get_parameters proc_name in
list_fold_right (fun typ_str params -> ("", lookup_typ typ_str) :: params) param_strs [] in
IList.fold_right (fun typ_str params -> ("", lookup_typ typ_str) :: params) param_strs [] in
let proc_attributes =
{ (ProcAttributes.default proc_name Config.Java) with
ProcAttributes.formals;
@ -288,7 +288,7 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
Cfg.Procdesc.cfg = harness_cfg;
proc_attributes = proc_attributes;
} in
list_iter (fun p ->
IList.iter (fun p ->
(* add harness -> callee edge to the call graph *)
Cg.add_edge cg harness_name p;
(* create dummy procdescs for callees not in the module. hopefully t4583729 will remove the
@ -323,7 +323,7 @@ let setup_harness_cfg harness_name harness_cfg env source_dir cg tenv =
} in
let harness_node =
(* important to reverse the list or there will be scoping issues! *)
let instrs = (list_rev env.instrs) in
let instrs = (IList.rev env.instrs) in
let nodekind = Cfg.Node.Stmt_node "method_body" in
Cfg.Node.create harness_cfg env.pc nodekind instrs procdesc env.tmp_vars in
let (start_node, exit_node) =
@ -346,7 +346,7 @@ let setup_harness_cfg harness_name harness_cfg env source_dir cg tenv =
(** create a procedure named harness_name that calls each of the methods in trace in the specified
* order with the specified receiver and add it to the execution environment *)
let inhabit_trace trace cb_flds harness_name proc_file_map tenv =
if list_length trace > 0 then
if IList.length trace > 0 then
(* pick an arbitrary cg and cfg to piggyback the harness code onto *)
let (source_dir, source_file, cg) =
let (proc_name, source_file) = Procname.Map.choose proc_file_map in
@ -368,10 +368,10 @@ let inhabit_trace trace cb_flds harness_name proc_file_map tenv =
let env'' =
(* invoke lifecycle methods *)
let env' =
list_fold_left (fun env to_call -> inhabit_call to_call proc_file_map env) empty_env trace in
IList.fold_left (fun env to_call -> inhabit_call to_call proc_file_map env) empty_env trace in
(* invoke callbacks *)
inhabit_fld_trace cb_flds proc_file_map env' in
try
setup_harness_cfg harness_name harness_cfg env'' source_dir cg tenv;
write_harness_to_file (list_rev env''.instrs) harness_file
write_harness_to_file (IList.rev env''.instrs) harness_file
with Not_found -> ()

12
infer/src/harness/stacktrace.ml
Unescape View File

@ -45,13 +45,13 @@ let try_resolve_frame str_frame exe_env tenv =
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, class_name)) with
| Some Sil.Tstruct (_, _, Sil.Class, _, _, decl_procs, _) ->
let possible_calls =
list_filter
IList.filter
(fun proc -> Procname.java_get_method proc = str_frame.method_str)
decl_procs in
if list_length possible_calls > 0 then
(* using list_hd here assumes that all of the possible calls are declared in the
if IList.length possible_calls > 0 then
(* using IList.hd here assumes that all of the possible calls are declared in the
* same file, which will be true in Java but not necessarily in other languages *)
let file_name = Exe_env.get_source exe_env (list_hd possible_calls) in
let file_name = Exe_env.get_source exe_env (IList.hd possible_calls) in
Resolved
{ possible_calls = possible_calls; file_name = file_name; line_num = str_frame.line_num; }
else Unresolved str_frame
@ -79,9 +79,9 @@ let parse_frame frame_str exe_env tenv =
(** create an Infer-readable representation of a stack trace given its raw text *)
let parse_stack_trace trace_str exe_env =
let tenv = Exe_env.get_tenv exe_env (list_hd (Cg.get_defined_nodes (Exe_env.get_cg exe_env))) in
let tenv = Exe_env.get_tenv exe_env (IList.hd (Cg.get_defined_nodes (Exe_env.get_cg exe_env))) in
let trace_list = Str.split (Str.regexp "\n") trace_str in
list_map (fun frame_str -> parse_frame frame_str exe_env tenv) trace_list
IList.map (fun frame_str -> parse_frame frame_str exe_env tenv) trace_list
let pp_str_frame fmt = function
| Resolved f ->

6
infer/src/java/jAnnotation.ml
Unescape View File

@ -23,7 +23,7 @@ let translate a : Sil.annotation =
| _ -> "?" in
let element_value_pairs = a.JBasics.element_value_pairs in
{ Sil.class_name = class_name;
Sil.parameters = list_map translate_value_pair element_value_pairs }
Sil.parameters = IList.map translate_value_pair element_value_pairs }
(** Translate an item annotation. *)
@ -32,7 +32,7 @@ let translate_item avlist : Sil.item_annotation =
| Javalib.RTVisible -> true
| Javalib.RTInvisible -> false in
let trans (a, v) = translate a, trans_vis v in
list_map trans avlist
IList.map trans avlist
(** Translate a method annotation. *)
@ -40,5 +40,5 @@ let translate_method ann : Sil.method_annotation =
let global_ann = ann.Javalib.ma_global in
let param_ann = ann.Javalib.ma_parameters in
let ret_item = translate_item global_ann in
let param_items = list_map translate_item param_ann in
let param_items = IList.map translate_item param_ann in
ret_item, param_items

20
infer/src/java/jClasspath.ml
Unescape View File

@ -39,7 +39,7 @@ let collect_specs_filenames jar_filename =
else
let proc_filename = (Filename.chop_extension (Filename.basename filename)) in
StringSet.add proc_filename set in
models_specs_filenames := list_fold_left collect !models_specs_filenames (Zip.entries file_in);
models_specs_filenames := IList.fold_left collect !models_specs_filenames (Zip.entries file_in);
Zip.close_in file_in
@ -102,7 +102,7 @@ let load_sources_and_classes () =
let cn, root_info = Javalib.extract_class_name_from_file fname in
let root_dir = if root_info = "" then Filename.current_dir_name else root_info in
let updated_roots =
if list_exists (fun p -> p = root_dir) roots then roots
if IList.exists (fun p -> p = root_dir) roots then roots
else root_dir:: roots in
loop paths updated_roots sources (JBasics.ClassSet.add cn classes)
| JVerbose.Classpath parsed_paths ->
@ -114,7 +114,7 @@ let load_sources_and_classes () =
| Failure "lexing: empty token" -> loop paths roots sources classes
| End_of_file ->
close_in file_in;
let classpath = list_fold_left append_path "" (roots @ (add_android_jar paths)) in
let classpath = IList.fold_left append_path "" (roots @ (add_android_jar paths)) in
(classpath, sources, classes) in
loop [] [] StringMap.empty JBasics.ClassSet.empty
@ -162,10 +162,10 @@ let lookup_node cn (program: program) =
let classname_of_class_filename class_filename =
let parts = Str.split (Str.regexp "/") class_filename in
let classname_str =
if list_length parts > 1 then
list_fold_left (fun s p -> s^"."^p) (list_hd parts) (list_tl parts)
if IList.length parts > 1 then
IList.fold_left (fun s p -> s^"."^p) (IList.hd parts) (IList.tl parts)
else
list_hd parts in
IList.hd parts in
JBasics.make_cn classname_str
@ -177,7 +177,7 @@ let extract_classnames classnames jar_filename =
let () = ignore (Str.search_forward (Str.regexp "class") class_filename 0) in
(classname_of_class_filename (Filename.chop_extension class_filename):: classes)
with Not_found -> classes in
let classnames_after = list_fold_left collect classnames (Zip.entries file_in) in
let classnames_after = IList.fold_left collect classnames (Zip.entries file_in) in
Zip.close_in file_in;
classnames_after
@ -186,13 +186,13 @@ let collect_classes classmap jar_filename =
let classpath = Javalib.class_path jar_filename in
let collect classmap cn =
JBasics.ClassMap.add cn (Javalib.get_class classpath cn) classmap in
list_fold_left collect classmap (extract_classnames [] jar_filename)
IList.fold_left collect classmap (extract_classnames [] jar_filename)
let classmap_of_classpath classpath =
let jar_filenames =
list_filter (fun p -> not (Sys.is_directory p)) (split_classpath classpath) in
list_fold_left collect_classes JBasics.ClassMap.empty jar_filenames
IList.filter (fun p -> not (Sys.is_directory p)) (split_classpath classpath) in
IList.fold_left collect_classes JBasics.ClassMap.empty jar_filenames
let load_program classpath classes arg_source_files =

4
infer/src/java/jFrontend.ml
Unescape View File

@ -121,7 +121,7 @@ let add_amethod program icfg node am is_static =
let path_of_cached_classname cn =
let root_path = Filename.concat !Config.results_dir "classnames" in
let package_path = list_fold_left Filename.concat root_path (JBasics.cn_package cn) in
let package_path = IList.fold_left Filename.concat root_path (JBasics.cn_package cn) in
Filename.concat package_path ((JBasics.cn_simple_name cn)^".java")
@ -186,7 +186,7 @@ let should_capture classes source_basename node =
let classname = Javalib.get_name node in
let temporary_skip =
(* TODO (#6341744): remove this *)
list_exists
IList.exists
(fun part -> part = "graphschema")
(JBasics.cn_package classname) in
if JBasics.ClassSet.mem classname classes && not temporary_skip then

2
infer/src/java/jMain.ml
Unescape View File

@ -87,7 +87,7 @@ let do_source_file
never_null_matcher linereader classes program tenv source_basename source_file in
store_icfg tenv call_graph cfg source_file;
if JConfig.create_harness then
list_fold_left
IList.fold_left
(fun proc_file_map pdesc ->
Procname.Map.add (Cfg.Procdesc.get_proc_name pdesc) source_file proc_file_map)
proc_file_map (Cfg.get_all_procs cfg)

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

@ -98,10 +98,10 @@ let get_undefined_method_call ovt =
let retrieve_fieldname fieldname =
try
let subs = Str.split (Str.regexp (Str.quote ".")) (Ident.fieldname_to_string fieldname) in
if list_length subs = 0 then
if IList.length subs = 0 then
assert false
else
list_hd (list_rev subs)
IList.hd (IList.rev subs)
with hd -> assert false
@ -110,7 +110,7 @@ let get_field_name program static tenv cn fs context =
| Sil.Tstruct (fields, sfields, Sil.Class, _, _, _, _) ->
let fieldname, _, _ =
try
list_find
IList.find
(fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs)
(if static then sfields else fields)
with Not_found ->
@ -135,14 +135,14 @@ let formals_from_signature program tenv cn ms kind =
let init_arg_list = match kind with
| Procname.Static -> []
| Procname.Non_Static -> [(JConfig.this, JTransType.get_class_type program tenv cn)] in
list_rev (list_fold_left collect init_arg_list (JBasics.ms_args ms))
IList.rev (IList.fold_left collect init_arg_list (JBasics.ms_args ms))
let formals program tenv cn impl =
let collect l (vt, var) =
let name = JBir.var_name_g var in
let typ = JTransType.param_type program tenv cn var vt in
(name, typ):: l in
list_rev (list_fold_left collect [] (JBir.params impl))
IList.rev (IList.fold_left collect [] (JBir.params impl))
(** Creates the local and formal variables from a procedure based on the
impl argument. If the meth_kind is Init, we add a parameter field to
@ -155,16 +155,16 @@ let locals_formals program tenv cn impl meth_kind =
else formals program tenv cn impl in
let is_formal v =
let v = Mangled.to_string v in
list_exists (fun (v', _) -> Utils.string_equal v v') form_list in
IList.exists (fun (v', _) -> Utils.string_equal v v') form_list in
let collect l var =
let vname = Mangled.from_string (JBir.var_name_g var) in
let names = (fst (list_split l)) in
if not (is_formal vname) && (not (list_mem Mangled.equal vname names)) then
let names = (fst (IList.split l)) in
if not (is_formal vname) && (not (IList.mem Mangled.equal vname names)) then
(vname, Sil.Tvoid):: l
else
l in
let vars = JBir.vars impl in
let loc_list = list_rev (Array.fold_left collect [] vars) in
let loc_list = IList.rev (Array.fold_left collect [] vars) in
(loc_list, form_list)
let get_constant (c : JBir.const) =
@ -289,7 +289,7 @@ let create_local_procdesc program linereader cfg tenv node m =
let proc_attributes =
{ (ProcAttributes.default proc_name Config.Java) with
ProcAttributes.access = trans_access am.Javalib.am_access;
exceptions = list_map JBasics.cn_name am.Javalib.am_exceptions;
exceptions = IList.map JBasics.cn_name am.Javalib.am_exceptions;
formals;
is_abstract = true;
is_bridge_method = am.Javalib.am_bridge;
@ -316,7 +316,7 @@ let create_local_procdesc program linereader cfg tenv node m =
let proc_attributes =
{ (ProcAttributes.default proc_name Config.Java) with
ProcAttributes.access = trans_access cm.Javalib.cm_access;
exceptions = list_map JBasics.cn_name cm.Javalib.cm_exceptions;
exceptions = IList.map JBasics.cn_name cm.Javalib.cm_exceptions;
formals;
is_bridge_method = cm.Javalib.cm_bridge;
is_synthetic_method = cm.Javalib.cm_synthetic;
@ -342,7 +342,7 @@ let create_local_procdesc program linereader cfg tenv node m =
let proc_attributes =
{ (ProcAttributes.default proc_name Config.Java) with
ProcAttributes.access = trans_access cm.Javalib.cm_access;
exceptions = list_map JBasics.cn_name cm.Javalib.cm_exceptions;
exceptions = IList.map JBasics.cn_name cm.Javalib.cm_exceptions;
formals;
is_bridge_method = cm.Javalib.cm_bridge;
is_defined = true;
@ -585,7 +585,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
| _ -> [], [] in
(ids, instrs, [(sil_obj_expr, sil_obj_type)]) in
let (idl, instrs, call_args) =
list_fold_left
IList.fold_left
(fun (idl_accu, instrs_accu, args_accu) expr ->
let (idl, instrs, sil_expr) = expression context pc expr in
let sil_expr_type = JTransType.expr_type context expr in
@ -645,10 +645,10 @@ let get_array_size context pc expr_list content_type =
match other_instrs with
| (other_idl, other_instrs, other_exprs) ->
(idl@other_idl, instrs@other_instrs, sil_size_expr:: other_exprs) in
let (idl, instrs, sil_size_exprs) = (list_fold_right get_expr_instr expr_list ([],[],[])) in
let (idl, instrs, sil_size_exprs) = (IList.fold_right get_expr_instr expr_list ([],[],[])) in
let get_array_type sil_size_expr content_type =
Sil.Tarray (content_type, sil_size_expr) in
let array_type = (list_fold_right get_array_type sil_size_exprs content_type) in
let array_type = (IList.fold_right get_array_type sil_size_exprs content_type) in
let array_size = Sil.Sizeof (array_type, Sil.Subtype.exact) in
(idl, instrs, array_size)
@ -722,7 +722,7 @@ let extends context node1 node2 =
let is_matching cn =
JBasics.cn_equal cn (Javalib.get_name node2) in
let rec check cn_list =
if list_exists is_matching cn_list then true
if IList.exists is_matching cn_list then true
else
iterate cn_list
and iterate cn_list =
@ -744,7 +744,7 @@ let extends context node1 node2 =
match super_cn_list with
| [] -> false
| l -> check l in
list_exists per_classname cn_list in
IList.exists per_classname cn_list in
check [Javalib.get_name node1]
let instruction_array_call ms obj_type obj args var_opt vt =
@ -808,7 +808,7 @@ let rec instruction context pc instr : translation =
cfg (get_location (JContext.get_impl context) pc meth_kind cn) node_kind sil_instrs (JContext.get_procdesc context) temps in
let return_not_null () =
(match_never_null loc.Location.file proc_name
|| list_exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in
|| IList.exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in
try
match instr with
| JBir.AffectVar (var, expr) ->
@ -934,7 +934,7 @@ let rec instruction context pc instr : translation =
| JBir.NewArray (var, vt, expr_list) ->
let builtin_new_array = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__new_array) in
let content_type = JTransType.value_type program tenv vt in
let array_type = JTransType.create_array_type content_type (list_length expr_list) in
let array_type = JTransType.create_array_type content_type (IList.length expr_list) in
let array_name = JContext.set_pvar context var array_type in
let (idl, instrs, array_size) = get_array_size context pc expr_list content_type in
let call_args = [(array_size, array_type)] in

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

@ -246,11 +246,11 @@ let get_all_fields program static cn =
| Some super_classname -> loop super_classname in
let current_fields =
Javalib.cf_fold (collect_class_field static classname) (Javalib.JClass jclass) [] in
(list_sort compare current_fields) @ super_fields
(IList.sort compare current_fields) @ super_fields
| Some (Javalib.JInterface jinterface) when static ->
let current_fields =
Javalib.if_fold (collect_interface_field classname) (Javalib.JInterface jinterface) [] in
list_sort compare current_fields
IList.sort compare current_fields
| _ -> [] in
loop cn
@ -279,7 +279,7 @@ let collect_models_class_fields classpath_field_map static cn cf l =
let add_model_fields program (static_fields, nonstatic_fields) cn =
let collect_fields =
list_fold_left (fun map (fn, ft, _) -> Ident.FieldMap.add fn ft map) Ident.FieldMap.empty in
IList.fold_left (fun map (fn, ft, _) -> Ident.FieldMap.add fn ft map) Ident.FieldMap.empty in
try
match JBasics.ClassMap.find cn (JClasspath.get_models program) with
| Javalib.JClass _ as jclass ->
@ -303,12 +303,12 @@ let rec create_sil_type program tenv cn =
| None -> dummy_type cn
| Some node ->
let create_super_list interface_names =
(list_map (fun i -> Mangled.from_string (JBasics.cn_name i)) interface_names) in
(IList.map (fun i -> Mangled.from_string (JBasics.cn_name i)) interface_names) in
let (super_list, nonstatic_fields, static_fields, item_annotation) =
match node with
| Javalib.JInterface jinterface ->
let static_fields = get_all_fields program true cn in
let sil_interface_list = list_map (fun c -> (Sil.Class, c)) (create_super_list jinterface.Javalib.i_interfaces) in
let sil_interface_list = IList.map (fun c -> (Sil.Class, c)) (create_super_list jinterface.Javalib.i_interfaces) in
let item_annotation = JAnnotation.translate_item jinterface.Javalib.i_annotations in
(sil_interface_list, [], static_fields, item_annotation)
| Javalib.JClass jclass ->
@ -329,7 +329,7 @@ let rec create_sil_type program tenv cn =
| _ -> assert false in
super_classname :: interface_list in
let super_sil_classname_list =
list_map (fun c -> (Sil.Class, c)) super_classname_list in
IList.map (fun c -> (Sil.Class, c)) super_classname_list in
(super_sil_classname_list, nonstatic_fields, static_fields, item_annotation) in
let classname = Mangled.from_string (JBasics.cn_name cn) in
let method_procnames = get_class_procnames cn node in
@ -400,7 +400,7 @@ let get_var_type_from_sig context var =
try
let tenv = JContext.get_tenv context in
let vt', var' =
list_find
IList.find
(fun (vt', var') -> JBir.var_equal var var')
(JBir.params (JContext.get_impl context)) in
Some (param_type program tenv (JContext.get_cn context) var' vt')
@ -498,4 +498,4 @@ let never_returning_null =
JBasics.make_ms
method_name arg_types (Some (JBasics.TObject (JBasics.TClass return_cn))) in
get_method_procname cn ms kind in
list_map make_procname never_null_method_sigs
IList.map make_procname never_null_method_sigs

6
infer/src/llvm/lParser.mly
Unescape View File

@ -158,9 +158,9 @@
program:
| targets func_defs = function_def* opt_mappings = metadata_def* EOF {
let mappings = list_flatten_options opt_mappings in
let mappings = IList.flatten_options opt_mappings in
let add_mapping map (metadata_id, aggregate) = MetadataMap.add metadata_id aggregate map in
let metadata_map = list_fold_left add_mapping MetadataMap.empty mappings in
let metadata_map = IList.fold_left add_mapping MetadataMap.empty mappings in
Program (func_defs, metadata_map) }
targets:
@ -254,7 +254,7 @@ ptr_typ:
| tp = typ STAR { tp }
block:
| LBRACE annotated_instrs = annotated_instruction* RBRACE { list_flatten_options annotated_instrs }
| LBRACE annotated_instrs = annotated_instruction* RBRACE { IList.flatten_options annotated_instrs }
annotated_instruction:
| instr = real_instruction anno = annotation? { Some (instr, anno) }

14
infer/src/llvm/lTrans.ml
Unescape View File

@ -94,7 +94,7 @@ let rec trans_annotated_instructions
let new_sil_instr = Sil.Call (
[ident_of_variable ret_var],
Sil.Const (Sil.Cfun (procname_of_function_variable func_var)),
list_map (fun (tp, arg) -> (trans_operand arg, trans_typ tp)) typed_args,
IList.map (fun (tp, arg) -> (trans_operand arg, trans_typ tp)) typed_args,
location, Sil.cf_default) in
(new_sil_instr :: sil_instrs, locals)
| _ -> raise (Unimplemented "Need to translate instruction to SIL.")
@ -106,8 +106,8 @@ let callees_of_function_def : LAst.function_def -> Procname.t list = function
| Call (_, func_var, _) -> Some (procname_of_function_variable func_var)
| _ -> None
end in
list_flatten_options (
list_map
IList.flatten_options (
IList.map
(fun annotated_instr -> callee_of_instruction (fst annotated_instr))
annotated_instrs)
@ -128,7 +128,7 @@ let trans_function_def (cfg : Cfg.cfg) (cg: Cg.t) (metadata : LAst.metadata_map)
let (proc_attrs : ProcAttributes.t) =
let open Sil in
{ (ProcAttributes.default proc_name Config.C_CPP) with
ProcAttributes.formals = list_map (fun (tp, name) -> (name, trans_typ tp)) params;
ProcAttributes.formals = IList.map (fun (tp, name) -> (name, trans_typ tp)) params;
is_defined = true; (** is defined and not just declared *)
loc = source_only_location ();
locals = []; (* TODO *)
@ -151,18 +151,18 @@ let trans_function_def (cfg : Cfg.cfg) (cg: Cg.t) (metadata : LAst.metadata_map)
| [] -> Cfg.Node.set_succs_exn start_node [exit_node] [exit_node]
| nd :: nds -> Cfg.Node.set_succs_exn start_node [nd] [exit_node]; link_nodes nd nds in
let (sil_instrs, locals) = trans_annotated_instructions cfg procdesc metadata annotated_instrs in
let nodes = list_map (node_of_sil_instr cfg procdesc) sil_instrs in
let nodes = IList.map (node_of_sil_instr cfg procdesc) sil_instrs in
Cfg.Procdesc.set_start_node procdesc start_node;
Cfg.Procdesc.set_exit_node procdesc exit_node;
link_nodes start_node nodes;
Cfg.Node.add_locals_ret_declaration start_node locals;
Cg.add_defined_node cg proc_name;
list_iter (Cg.add_edge cg proc_name) (callees_of_function_def func_def)
IList.iter (Cg.add_edge cg proc_name) (callees_of_function_def func_def)
let trans_program : LAst.program -> Cfg.cfg * Cg.t * Sil.tenv = function
Program (func_defs, metadata) ->
let cfg = Cfg.Node.create_cfg () in
let cg = Cg.create () in
let tenv = Sil.create_tenv () in
list_iter (trans_function_def cfg cg metadata) func_defs;
IList.iter (trans_function_def cfg cg metadata) func_defs;
(cfg, cg, tenv)

10
infer/src/scripts/checkCopyright.ml
Unescape View File

@ -56,14 +56,14 @@ let rec find_copyright_line lines n = match lines with
let find_comment_start_and_style lines_arr n =
(* are we in a line comment? *)
let cur_line_comment = try
Some (list_find (function
Some (IList.find (function
| Line (s) when string_is_prefix s lines_arr.(n) -> true
| _ -> false) comment_styles)
with Not_found -> None in
let is_start line = match cur_line_comment with
| Some (Line (s)) -> if string_is_prefix s line then None else Some (Line (s))
| _ -> try
Some (list_find (function
Some (IList.find (function
| Block(s, _, _) -> string_contains s line
| _ -> false) comment_styles)
with Not_found -> None in
@ -194,7 +194,7 @@ let com_style_of_lang = [
]
let file_should_have_copyright fname lines =
list_mem_assoc Filename.check_suffix fname com_style_of_lang
IList.mem_assoc Filename.check_suffix fname com_style_of_lang
let get_filename_extension fname =
try
@ -225,7 +225,7 @@ let check_copyright fname = match read_file fname with
begin
let year = 1900 + (Unix.localtime (Unix.time ())).Unix.tm_year in
let ext = get_filename_extension fname in
let com_style = list_assoc string_equal ext com_style_of_lang in
let com_style = IList.assoc string_equal ext com_style_of_lang in
let prefix = if com_style = comment_style_ocaml then " " else "" in
let start = default_start_line_of_com_style com_style in
output_diff fname (Array.of_list []) start (-1) (-1) 0 false year com_style prefix;
@ -270,5 +270,5 @@ let () =
let add_file_to_check fname =
to_check := fname :: !to_check in
Arg.parse speclist add_file_to_check usage_msg;
list_iter check_copyright (list_rev !to_check);
IList.iter check_copyright (IList.rev !to_check);
exit 0

Write Preview
Loading…
Cancel
Save