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

Warn on unused identifiers

Browse Source 
Summary:public
I have seen enough comments in this space by people during code review to switch on the analyses the compiler can already do.  This diff is an automated renaming of unused identifiers to _, with a few additional changes made when reading the diff of the results for things that stood out as particularly strange.  This base-lines all of the existing warnings.  I'm not sure this is a good idea, since it might be better for those familiar with each part of the code to look at these warnings and use them as pointers to suspicious code.

Reviewed By: jeremydubreil

Differential Revision: D2938376

fb-gh-sync-id: 6e67817
shipit-source-id: 6e67817
master
Josh Berdine 9 years ago committed by facebook-github-bot-1
parent 02056079cf
commit 77b22ded03
107 changed files with 1368 additions and 1377 deletions
Show Stats Download Patch File Download Diff File

6
infer/src/Makefile.in
Unescape View File

@ -92,14 +92,16 @@ OCAMLBUILD_OPTIONS = \
-cflags -w,@20 \ -cflags -w,@20 \
-cflags -w,@26 \ -cflags -w,@26 \
-cflags -w,@29 \ -cflags -w,@29 \
-cflags -w,+32 \ -cflags -w,@27 \
-cflags -w,@32 \
-cflags -w,@33 \ -cflags -w,@33 \
-cflags -w,@34 \ -cflags -w,@34 \
-cflags -w,@35 \ -cflags -w,@35 \
-cflags -w,@37 \ -cflags -w,@37 \
-cflags -w,@38 \ -cflags -w,@38 \
-cflags -w,@39 \ -cflags -w,@39 \
-tag-line "<*{clang/clang_ast_*,backend/jsonbug_*}>: warn(-32-35-39)" \ -cflags -w,-40..42 \
-tag-line "<*{clang/clang_ast_*,backend/jsonbug_*}>: warn(-27-32-35-39)" \
-tag-line "not <**/{config,iList,utils}.*>: open(Utils)" \ -tag-line "not <**/{config,iList,utils}.*>: open(Utils)" \
-lflags $(OCAML_INCLUDES) \ -lflags $(OCAML_INCLUDES) \
-cflags $(OCAML_INCLUDES) \ -cflags $(OCAML_INCLUDES) \

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

@ -51,7 +51,7 @@ let create_fresh_primeds_ls para =
let id_end = Ident.create_fresh Ident.kprimed in let id_end = Ident.create_fresh Ident.kprimed in
let ids_shared = let ids_shared =
let svars = para.Sil.svars in let svars = para.Sil.svars in
let f id = Ident.create_fresh Ident.kprimed in let f _ = Ident.create_fresh Ident.kprimed in
IList.map f svars in IList.map f svars in
let ids_tuple = (id_base, id_next, id_end, ids_shared) in let ids_tuple = (id_base, id_next, id_end, ids_shared) in
let exp_base = Sil.Var id_base in let exp_base = Sil.Var id_base in
@ -71,7 +71,7 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.subst) =
(insts_of_private_ids, insts_of_public_ids, inst_of_base) in (insts_of_private_ids, insts_of_public_ids, inst_of_base) in
let fav_insts_of_public_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_public_ids) in let fav_insts_of_public_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_public_ids) in
let fav_insts_of_private_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_private_ids) in let fav_insts_of_private_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_private_ids) in
let (fav_p_leftover, fav_in_pvars) = let (fav_p_leftover, _) =
let sigma = Prop.get_sigma p_leftover in let sigma = Prop.get_sigma p_leftover in
(sigma_fav_list sigma, sigma_fav_in_pvars_list sigma) in (sigma_fav_list sigma, sigma_fav_in_pvars_list sigma) in
let fpv_inst_of_base = Sil.exp_fpv inst_of_base in let fpv_inst_of_base = Sil.exp_fpv inst_of_base in
@ -108,7 +108,7 @@ let mk_rule_ptspts_ls impl_ok1 impl_ok2 (para: Sil.hpara) =
let para_body_hpats = IList.map mark_impl_flag para_body in let para_body_hpats = IList.map mark_impl_flag para_body in
(ids, para_body_hpats) in (ids, para_body_hpats) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared 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 let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition = let condition =
let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in
create_condition_ls ids_private id_base in create_condition_ls ids_private id_base in
@ -132,7 +132,7 @@ let mk_rule_ptsls_ls k2 impl_ok1 impl_ok2 para =
(allow_impl hpred, IList.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_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 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 let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition = let condition =
let ids_private = id_next :: ids_exist in let ids_private = id_next :: ids_exist in
create_condition_ls ids_private id_base in create_condition_ls ids_private id_base in
@ -154,7 +154,7 @@ let mk_rule_lspts_ls k1 impl_ok1 impl_ok2 para =
let para_body_pat = IList.map allow_impl para_body in let para_body_pat = IList.map allow_impl para_body in
(ids, para_body_pat) in (ids, para_body_pat) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared 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 let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition = let condition =
let ids_private = id_next :: ids_exist in let ids_private = id_next :: ids_exist in
create_condition_ls ids_private id_base in create_condition_ls ids_private id_base in
@ -179,7 +179,7 @@ let mk_rule_lsls_ls k1 k2 impl_ok1 impl_ok2 para =
{ Match.hpred = Prop.mk_lseg k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in { Match.hpred = Prop.mk_lseg k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in
let k_res = lseg_kind_add k1 k2 in let k_res = lseg_kind_add k1 k2 in
let lseg_res = Prop.mk_lseg k_res para exp_base exp_end exps_shared in let lseg_res = Prop.mk_lseg k_res para exp_base exp_end exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] let gen_pi_res _ _ (_: Sil.subst) = []
(* (*
let inst_base, inst_next, inst_end = let inst_base, inst_next, inst_end =
let find x = sub_find (equal x) inst in let find x = sub_find (equal x) inst in
@ -239,7 +239,7 @@ let mk_rule_ptspts_dll impl_ok1 impl_ok2 para =
let id_oF = Ident.create_fresh Ident.kprimed in let id_oF = Ident.create_fresh Ident.kprimed in
let ids_shared = let ids_shared =
let svars = para.Sil.svars_dll in let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in let f _ = Ident.create_fresh Ident.kprimed in
IList.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_iF' = Sil.Var id_iF' in let exp_iF' = Sil.Var id_iF' in
@ -261,7 +261,7 @@ let mk_rule_ptspts_dll impl_ok1 impl_ok2 para =
let para_body_hpats = IList.map mark_impl_flag para_body in let para_body_hpats = IList.map mark_impl_flag para_body in
(ids, para_body_hpats) 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 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 let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition = let condition =
(* for the case of ptspts since iF'=iB therefore iF' cannot be private*) (* for the case of ptspts since iF'=iB therefore iF' cannot be private*)
let ids_private = ids_exist_fst @ ids_exist_snd in let ids_private = ids_exist_fst @ ids_exist_snd in
@ -287,7 +287,7 @@ let mk_rule_ptsdll_dll k2 impl_ok1 impl_ok2 para =
let id_iB = Ident.create_fresh Ident.kprimed in let id_iB = Ident.create_fresh Ident.kprimed in
let ids_shared = let ids_shared =
let svars = para.Sil.svars_dll in let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in let f _ = Ident.create_fresh Ident.kprimed in
IList.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_iF' = Sil.Var id_iF' in let exp_iF' = Sil.Var id_iF' in
@ -304,7 +304,7 @@ let mk_rule_ptsdll_dll k2 impl_ok1 impl_ok2 para =
(allow_impl hpred, IList.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_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 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 let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition = let condition =
let ids_private = id_iF':: ids_exist in let ids_private = id_iF':: ids_exist in
create_condition_dll ids_private id_iF in create_condition_dll ids_private id_iF in
@ -323,7 +323,7 @@ let mk_rule_dllpts_dll k1 impl_ok1 impl_ok2 para =
let id_oF = Ident.create_fresh Ident.kprimed in let id_oF = Ident.create_fresh Ident.kprimed in
let ids_shared = let ids_shared =
let svars = para.Sil.svars_dll in let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in let f _ = Ident.create_fresh Ident.kprimed in
IList.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_iF' = Sil.Var id_iF' in let exp_iF' = Sil.Var id_iF' in
@ -337,7 +337,7 @@ let mk_rule_dllpts_dll k1 impl_ok1 impl_ok2 para =
IList.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_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 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 let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition = let condition =
let ids_private = id_oB':: ids_exist in let ids_private = id_oB':: ids_exist in
create_condition_dll ids_private id_iF in create_condition_dll ids_private id_iF in
@ -357,7 +357,7 @@ let mk_rule_dlldll_dll k1 k2 impl_ok1 impl_ok2 para =
let id_iB = Ident.create_fresh Ident.kprimed in let id_iB = Ident.create_fresh Ident.kprimed in
let ids_shared = let ids_shared =
let svars = para.Sil.svars_dll in let svars = para.Sil.svars_dll in
let f id = Ident.create_fresh Ident.kprimed in let f _ = Ident.create_fresh Ident.kprimed in
IList.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_iF' = Sil.Var id_iF' in let exp_iF' = Sil.Var id_iF' in
@ -370,7 +370,7 @@ let mk_rule_dlldll_dll k1 k2 impl_ok1 impl_ok2 para =
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 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 let k_res = lseg_kind_add k1 k2 in
let lseg_res = Prop.mk_dllseg k_res para exp_iF exp_oB exp_oF exp_iB exps_shared in let lseg_res = Prop.mk_dllseg k_res para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition = let condition =
let ids_private = [id_iF'; id_oB'] in let ids_private = [id_iF'; id_oB'] in
create_condition_dll ids_private id_iF in create_condition_dll ids_private id_iF in
@ -423,7 +423,7 @@ let typ_get_recursive_flds tenv typ_exp =
| Sil.Tvar _ -> assert false (* there should be no indirection *) | Sil.Tvar _ -> assert false (* there should be no indirection *)
| Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> [] | Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> []
| Sil.Tstruct { Sil.instance_fields } -> | Sil.Tstruct { Sil.instance_fields } ->
IList.map (fun (x, y, z) -> x) (IList.filter (filter typ) instance_fields) IList.map (fun (x, _, _) -> x) (IList.filter (filter typ) instance_fields)
| Sil.Tarray _ -> []) | Sil.Tarray _ -> [])
| Sil.Var _ -> [] (* type of |-> not known yet *) | Sil.Var _ -> [] (* type of |-> not known yet *)
| Sil.Const _ -> [] | Sil.Const _ -> []
@ -474,7 +474,7 @@ let discover_para_candidates tenv p =
let fsel' = IList.filter (fun (fld, _) -> is_rec_fld fld) fsel in let fsel' = IList.filter (fun (fld, _) -> is_rec_fld fld) fsel in
let process (_, nextse) = let process (_, nextse) =
match nextse with match nextse with
| Sil.Eexp (next, inst) -> add_edge (root, next) | Sil.Eexp (next, _) -> add_edge (root, next)
| _ -> assert false in | _ -> assert false in
IList.iter process fsel' in IList.iter process fsel' in
let rec get_edges_sigma = function let rec get_edges_sigma = function
@ -510,7 +510,7 @@ let discover_para_dll_candidates tenv p =
let fsel' = IList.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) = let convert_to_exp acc (_, se) =
match se with match se with
| Sil.Eexp (e, inst) -> e:: acc | Sil.Eexp (e, _) -> e:: acc
| _ -> assert false in | _ -> assert false in
let links = IList.rev (IList.fold_left convert_to_exp [] fsel') in let links = IList.rev (IList.fold_left convert_to_exp [] fsel') in
let rec iter_pairs = function let rec iter_pairs = function
@ -616,7 +616,7 @@ let sigma_special_cases_eqs sigma =
[(IList.rev ids_acc, IList.rev eqs_acc, IList.rev sigma_acc)] [(IList.rev ids_acc, IList.rev eqs_acc, IList.rev sigma_acc)]
| Sil.Hpointsto _ as hpred :: sigma_rest -> | Sil.Hpointsto _ as hpred :: sigma_rest ->
f ids_acc eqs_acc (hpred:: sigma_acc) sigma_rest f ids_acc eqs_acc (hpred:: sigma_acc) sigma_rest
| Sil.Hlseg(k, para, e1, e2, es) as hpred :: sigma_rest -> | Sil.Hlseg(_, para, e1, e2, es) as hpred :: sigma_rest ->
let empty_case = let empty_case =
f ids_acc ((e1, e2):: eqs_acc) sigma_acc sigma_rest in f ids_acc ((e1, e2):: eqs_acc) sigma_acc sigma_rest in
let pointsto_case = let pointsto_case =
@ -625,7 +625,7 @@ let sigma_special_cases_eqs sigma =
let general_case = let general_case =
f ids_acc eqs_acc (hpred:: sigma_acc) sigma_rest in f ids_acc eqs_acc (hpred:: sigma_acc) sigma_rest in
empty_case @ pointsto_case @ general_case empty_case @ pointsto_case @ general_case
| Sil.Hdllseg(k, para, e1, e2, e3, e4, es) as hpred :: sigma_rest -> | Sil.Hdllseg(_, para, e1, e2, e3, e4, es) as hpred :: sigma_rest ->
let empty_case = let empty_case =
f ids_acc ((e1, e3):: (e2, e4):: eqs_acc) sigma_acc sigma_rest in f ids_acc ((e1, e3):: (e2, e4):: eqs_acc) sigma_acc sigma_rest in
let pointsto_case = let pointsto_case =
@ -957,7 +957,7 @@ let abstract_pure_part p ~(from_abstract_footprint: bool) =
IList.fold_left IList.fold_left
(fun pi a -> (fun pi a ->
match a with match a with
| Sil.Aneq (Sil.Var name, _) -> a:: pi | Sil.Aneq (Sil.Var _, _) -> a:: pi
(* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *) (* we only use Lt and Le because Gt and Ge are inserted in terms of Lt and Le. *)
| Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Lt, _, _)) | Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Lt, _, _))
| Sil.Aeq (Sil.BinOp (Sil.Lt, _, _), Sil.Const (Sil.Cint i)) | Sil.Aeq (Sil.BinOp (Sil.Lt, _, _), Sil.Const (Sil.Cint i))
@ -1107,9 +1107,10 @@ let get_cycle root prop =
(* Check whether the hidden counter field of a struct representing an *) (* Check whether the hidden counter field of a struct representing an *)
(* objective-c object is positive, and whether the leak is part of the *) (* objective-c object is positive, and whether the leak is part of the *)
(* specified buckets. In the positive case, it returns the bucket *) (* specified buckets. In the positive case, it returns the bucket *)
let should_raise_objc_leak prop hpred = let should_raise_objc_leak hpred =
match hpred with match hpred with
| Sil.Hpointsto(e, Sil.Estruct((fn, Sil.Eexp( (Sil.Const (Sil.Cint i)), _)):: _, _), Sil.Sizeof (typ, _)) | Sil.Hpointsto(_, Sil.Estruct((fn, Sil.Eexp( (Sil.Const (Sil.Cint i)), _)):: _, _),
Sil.Sizeof (typ, _))
when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) -> when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) ->
Mleak_buckets.should_raise_objc_leak typ Mleak_buckets.should_raise_objc_leak typ
| _ -> None | _ -> None
@ -1125,7 +1126,7 @@ let get_var_retain_cycle _prop =
let sigma = Prop.get_sigma _prop in let sigma = Prop.get_sigma _prop in
let is_pvar v h = let is_pvar v h =
match h with match h with
| Sil.Hpointsto (Sil.Lvar pv, v', _) when Sil.strexp_equal v v' -> true | Sil.Hpointsto (Sil.Lvar _, v', _) when Sil.strexp_equal v v' -> true
| _ -> false in | _ -> false in
let is_hpred_block v h = let is_hpred_block v h =
match h, v with match h, v with
@ -1176,7 +1177,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
match t with match t with
| Sil.Tstruct { Sil.instance_fields; static_fields } -> | Sil.Tstruct { Sil.instance_fields; static_fields } ->
let ia = ref [] in let ia = ref [] in
IList.iter (fun (fn', t', ia') -> IList.iter (fun (fn', _, ia') ->
if Ident.fieldname_equal fn fn' then ia := ia') if Ident.fieldname_equal fn fn' then ia := ia')
(instance_fields @ static_fields); (instance_fields @ static_fields);
!ia !ia
@ -1192,7 +1193,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
let rec do_cycle c = let rec do_cycle c =
match c with match c with
| [] -> false | [] -> false
| ((e, t), fn, _):: c' -> | ((_, t), fn, _):: c' ->
let ia = get_item_annotation t fn in let ia = get_item_annotation t fn in
if (IList.exists do_annotation ia) then true if (IList.exists do_annotation ia) then true
else do_cycle c' in else do_cycle c' in
@ -1270,7 +1271,7 @@ let check_junk ?original_prop pname tenv prop =
| None -> Sil.Rmemory Sil.Mmalloc in | None -> Sil.Rmemory Sil.Mmalloc in
let ml_bucket_opt = let ml_bucket_opt =
match resource with match resource with
| Sil.Rmemory Sil.Mobjc -> should_raise_objc_leak prop hpred | Sil.Rmemory Sil.Mobjc -> should_raise_objc_leak hpred
| Sil.Rmemory Sil.Mnew when !Config.curr_language = Config.C_CPP -> | Sil.Rmemory Sil.Mnew when !Config.curr_language = Config.C_CPP ->
Mleak_buckets.should_raise_cpp_leak () Mleak_buckets.should_raise_cpp_leak ()
| _ -> None in | _ -> None in

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

@ -36,7 +36,7 @@ module StrexpMatch : sig
val find_path : sigma -> path -> t val find_path : sigma -> path -> t
(** Find a strexp with the given property. *) (** Find a strexp with the given property. *)
val find : sigma -> (sigma -> strexp_data -> bool) -> t list val find : sigma -> (strexp_data -> bool) -> t list
(** Get the array *) (** Get the array *)
val get_data : t -> strexp_data val get_data : t -> strexp_data
@ -66,13 +66,13 @@ end = struct
match se, t, syn_offs with match se, t, syn_offs with
| _, _, [] -> (se, t) | _, _, [] -> (se, t)
| Sil.Estruct (fsel, _), Sil.Tstruct { Sil.instance_fields }, Field (fld, _) :: syn_offs' -> | Sil.Estruct (fsel, _), Sil.Tstruct { Sil.instance_fields }, Field (fld, _) :: syn_offs' ->
let se' = snd (IList.find (fun (f', se') -> Sil.fld_equal f' fld) fsel) in let se' = snd (IList.find (fun (f', _) -> Sil.fld_equal f' fld) fsel) in
let t' = (fun (x,y,z) -> y) let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', t', a') -> (IList.find (fun (f', _, _) ->
Sil.fld_equal f' fld) instance_fields) in Sil.fld_equal f' fld) instance_fields) in
get_strexp_at_syn_offsets se' t' syn_offs' get_strexp_at_syn_offsets se' t' syn_offs'
| Sil.Earray (size, esel, _), Sil.Tarray(t', _), Index ind :: syn_offs' -> | Sil.Earray (_, esel, _), Sil.Tarray(t', _), Index ind :: syn_offs' ->
let se' = snd (IList.find (fun (i', se') -> Sil.exp_equal i' ind) esel) in let se' = snd (IList.find (fun (i', _) -> Sil.exp_equal i' ind) esel) in
get_strexp_at_syn_offsets se' t' syn_offs' get_strexp_at_syn_offsets se' t' syn_offs'
| _ -> | _ ->
L.d_strln "Failure of get_strexp_at_syn_offsets"; L.d_strln "Failure of get_strexp_at_syn_offsets";
@ -84,10 +84,10 @@ end = struct
let rec replace_strexp_at_syn_offsets se t syn_offs update = let rec replace_strexp_at_syn_offsets se t syn_offs update =
match se, t, syn_offs with match se, t, syn_offs with
| _, _, [] -> | _, _, [] ->
update se t update se
| Sil.Estruct (fsel, inst), Sil.Tstruct { Sil.instance_fields }, Field (fld, _) :: syn_offs' -> | Sil.Estruct (fsel, inst), Sil.Tstruct { Sil.instance_fields }, Field (fld, _) :: syn_offs' ->
let se' = snd (IList.find (fun (f', _) -> Sil.fld_equal f' fld) fsel) in let se' = snd (IList.find (fun (f', _) -> Sil.fld_equal f' fld) fsel) in
let t' = (fun (x,y,z) -> y) let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) -> (IList.find (fun (f', _, _) ->
Sil.fld_equal f' fld) instance_fields) in Sil.fld_equal f' fld) instance_fields) in
let se_mod = replace_strexp_at_syn_offsets se' t' syn_offs' update in let se_mod = replace_strexp_at_syn_offsets se' t' syn_offs' update in
@ -137,17 +137,17 @@ end = struct
(sigma, hpred, syn_offs) (sigma, hpred, syn_offs)
(** Find a sub strexp with the given property. Can raise [Not_found] *) (** Find a sub strexp with the given property. Can raise [Not_found] *)
let find (sigma : sigma) (pred : sigma -> strexp_data -> bool) : t list = let find (sigma : sigma) (pred : strexp_data -> bool) : t list =
let found = ref [] in let found = ref [] in
let rec find_offset_sexp sigma_other hpred root offs se typ = let rec find_offset_sexp sigma_other hpred root offs se typ =
let offs' = IList.rev offs in let offs' = IList.rev offs in
let path = (root, offs') in let path = (root, offs') in
if pred sigma_other (path, se, typ) then found := (sigma, hpred, offs') :: !found if pred (path, se, typ) then found := (sigma, hpred, offs') :: !found
else begin else begin
match se, typ with match se, typ with
| Sil.Estruct (fsel, _), Sil.Tstruct { Sil.instance_fields } -> | Sil.Estruct (fsel, _), Sil.Tstruct { Sil.instance_fields } ->
find_offset_fsel sigma_other hpred root offs fsel instance_fields typ find_offset_fsel sigma_other hpred root offs fsel instance_fields typ
| Sil.Earray (size, esel, _), Sil.Tarray (t, _) -> | Sil.Earray (_, esel, _), Sil.Tarray (t, _) ->
find_offset_esel sigma_other hpred root offs esel t find_offset_esel sigma_other hpred root offs esel t
| _ -> () | _ -> ()
end end
@ -156,7 +156,7 @@ end = struct
| (f, se) :: fsel' -> | (f, se) :: fsel' ->
begin begin
try try
let t = (fun (x,y,z) -> y) (IList.find (fun (f', t, a) -> Sil.fld_equal f' f) ftal) in let t = (fun (_,y,_) -> y) (IList.find (fun (f', _, _) -> Sil.fld_equal f' f) ftal) in
find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t
with Not_found -> with Not_found ->
L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find") L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find")
@ -195,15 +195,15 @@ end = struct
| _ -> assert false | _ -> assert false
(** Replace the current hpred *) (** Replace the current hpred *)
let replace_hpred ((sigma, hpred, syn_offs) : t) hpred' = let replace_hpred ((sigma, hpred, _) : t) hpred' =
IList.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 *) (** Replace the strexp at the given offset in the given hpred *)
let hpred_replace_strexp footprint_part hpred syn_offs update = let hpred_replace_strexp footprint_part hpred syn_offs update =
let update se' t' = let update se' =
let se_in = update se' t' in let se_in = update se' in
match se', se_in with match se', se_in with
| Sil.Earray (size, esel, inst1), Sil.Earray (_, esel_in, inst2) -> | Sil.Earray (size, esel, _), Sil.Earray (_, esel_in, inst2) ->
let orig_indices = IList.map fst esel 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 index_is_not_new idx = IList.exists (Sil.exp_equal idx) orig_indices in
let process_index idx = let process_index idx =
@ -222,13 +222,13 @@ end = struct
(** Replace the strexp at a given position by a new strexp *) (** Replace the strexp at a given position by a new strexp *)
let replace_strexp footprint_part ((sigma, hpred, syn_offs) : t) se_in = let replace_strexp footprint_part ((sigma, hpred, syn_offs) : t) se_in =
let update se' t' = se_in in let update _ = se_in in
let hpred' = hpred_replace_strexp footprint_part hpred syn_offs update in let hpred' = hpred_replace_strexp footprint_part hpred syn_offs update in
replace_hpred (sigma, hpred, syn_offs) hpred' replace_hpred (sigma, hpred, syn_offs) hpred'
(** Replace the index in the array at a given position with the new index *) (** 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 replace_index footprint_part ((sigma, hpred, syn_offs) : t) (index: Sil.exp) (index': Sil.exp) =
let update se' t' = let update se' =
match se' with match se' with
| Sil.Earray (size, esel, inst) -> | Sil.Earray (size, esel, inst) ->
let esel' = IList.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
@ -297,12 +297,12 @@ let array_abstraction_performed = ref false
let generic_strexp_abstract let generic_strexp_abstract
(abstraction_name : string) (abstraction_name : string)
(p_in : Prop.normal Prop.t) (p_in : Prop.normal Prop.t)
(_can_abstract : sigma -> StrexpMatch.strexp_data -> bool) (can_abstract_ : StrexpMatch.strexp_data -> bool)
(do_abstract : bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool) (do_abstract : bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool)
: Prop.normal Prop.t : Prop.normal Prop.t
= =
let can_abstract s data = let can_abstract data =
let r = _can_abstract s data in let r = can_abstract_ data in
if r then array_abstraction_performed := true; if r then array_abstraction_performed := true;
r in r in
let find_strexp_to_abstract p0 = let find_strexp_to_abstract p0 =
@ -352,14 +352,13 @@ let index_is_pointed_to (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index:
fun i -> IList.map (add_index i) elist_path in fun i -> IList.map (add_index i) elist_path in
let pointers = IList.flatten (IList.map add_index_to_paths indices) in let pointers = IList.flatten (IList.map add_index_to_paths indices) in
let filter = function let filter = function
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) -> IList.exists (Sil.exp_equal e) pointers | Sil.Hpointsto (_, Sil.Eexp (e, _), _) -> IList.exists (Sil.exp_equal e) pointers
| _ -> false in | _ -> false in
IList.exists filter (Prop.get_sigma p) IList.exists filter (Prop.get_sigma p)
(** Given [p] containing an array at [path], blur [index] in it *) (** Given [p] containing an array at [path], blur [index] in it *)
let blur_array_index let blur_array_index
(footprint_part: bool)
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(index: Sil.exp) : Prop.normal Prop.t (index: Sil.exp) : Prop.normal Prop.t
@ -392,18 +391,16 @@ let blur_array_index
(** Given [p] containing an array at [root], blur [indices] in it *) (** Given [p] containing an array at [root], blur [indices] in it *)
let blur_array_indices let blur_array_indices
(footprint_part : bool)
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(root: StrexpMatch.path) (root: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool (indices: Sil.exp list) : Prop.normal Prop.t * bool
= =
let f prop index = blur_array_index footprint_part prop root index in let f prop index = blur_array_index prop root index in
(IList.fold_left f p indices, IList.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 *) (** Given [p] containing an array at [root], only keep [indices] in it *)
let keep_only_indices let keep_only_indices
(footprint_part : bool)
(p: Prop.normal Prop.t) (p: Prop.normal Prop.t)
(path: StrexpMatch.path) (path: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool (indices: Sil.exp list) : Prop.normal Prop.t * bool
@ -432,9 +429,9 @@ let array_typ_can_abstract = function
| _ -> true | _ -> true
(** This function checks whether we can apply an abstraction to a strexp *) (** This function checks whether we can apply an abstraction to a strexp *)
let strexp_can_abstract sigma_rest ((_, se, typ) : StrexpMatch.strexp_data) : bool = let strexp_can_abstract ((_, se, typ) : StrexpMatch.strexp_data) : bool =
let can_abstract_se = match se with let can_abstract_se = match se with
| Sil.Earray (size, esel, _) -> | Sil.Earray (_, esel, _) ->
let len = IList.length esel in let len = IList.length esel in
len > 1 len > 1
| _ -> false in | _ -> false in
@ -442,7 +439,8 @@ let strexp_can_abstract sigma_rest ((_, se, typ) : StrexpMatch.strexp_data) : bo
(** This function abstracts a strexp *) (** This function abstracts a strexp *)
let strexp_do_abstract footprint_part p ((path, se_in, typ_in) : StrexpMatch.strexp_data) : Prop.normal Prop.t * bool = let strexp_do_abstract
footprint_part p ((path, se_in, _) : StrexpMatch.strexp_data) : Prop.normal Prop.t * bool =
if !Config.trace_absarray && footprint_part then (L.d_str "strexp_do_abstract (footprint)"; L.d_ln ()); if !Config.trace_absarray && footprint_part then (L.d_str "strexp_do_abstract (footprint)"; L.d_ln ());
if !Config.trace_absarray && not footprint_part then (L.d_str "strexp_do_abstract (nonfootprint)"; L.d_ln ()); if !Config.trace_absarray && not footprint_part then (L.d_str "strexp_do_abstract (nonfootprint)"; L.d_ln ());
let prune_and_blur d_keys keep blur path keep_keys blur_keys = let prune_and_blur d_keys keep blur path keep_keys blur_keys =
@ -458,13 +456,11 @@ let strexp_do_abstract footprint_part p ((path, se_in, typ_in) : StrexpMatch.str
if !Config.trace_absarray then (L.d_strln "Returns"; Prop.d_prop p3; L.d_ln (); L.d_ln ()); if !Config.trace_absarray then (L.d_strln "Returns"; Prop.d_prop p3; L.d_ln (); L.d_ln ());
(p3, changed2 || changed3) in (p3, changed2 || changed3) in
let prune_and_blur_indices = let prune_and_blur_indices =
prune_and_blur Sil.d_exp_list prune_and_blur Sil.d_exp_list keep_only_indices blur_array_indices in
(keep_only_indices footprint_part)
(blur_array_indices footprint_part) in
let partition_abstract should_keep abstract ksel default_keys = let partition_abstract should_keep abstract ksel default_keys =
let keep_ksel, remove_ksel = IList.partition should_keep ksel in let keep_ksel, remove_ksel = IList.partition should_keep ksel in
let keep_keys, remove_keys, keys = let keep_keys, _, _ =
IList.map fst keep_ksel, IList.map fst remove_ksel, IList.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 let keep_keys' = if keep_keys == [] then default_keys else keep_keys in
abstract keep_keys' keep_keys' in abstract keep_keys' keep_keys' in

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

@ -294,18 +294,18 @@ let create_idmap sigma : idmap =
| Sil.BinOp (Sil.PlusPI, e1, e2), _ -> | Sil.BinOp (Sil.PlusPI, e1, e2), _ ->
do_exp e1 typ; do_exp e1 typ;
do_exp e2 (Sil.Tint Sil.IULong) do_exp e2 (Sil.Tint Sil.IULong)
| Sil.Lfield (e1, f, t), _ -> | Sil.Lfield (e1, _, _), _ ->
do_exp e1 typ do_exp e1 typ
| Sil.Sizeof _, _ -> () | Sil.Sizeof _, _ -> ()
| _ -> | _ ->
L.err "Unmatched exp: %a : %a@." (Sil.pp_exp pe) e (Sil.pp_typ_full pe) typ; L.err "Unmatched exp: %a : %a@." (Sil.pp_exp pe) e (Sil.pp_typ_full pe) typ;
assert false in assert false in
let rec do_se se typ = match se, typ with let rec do_se se typ = match se, typ with
| Sil.Eexp (e, inst), _ -> | Sil.Eexp (e, _), _ ->
do_exp e typ do_exp e typ
| Sil.Estruct (fsel, _), Sil.Tstruct { Sil.instance_fields } -> | Sil.Estruct (fsel, _), Sil.Tstruct { Sil.instance_fields } ->
do_struct fsel instance_fields do_struct fsel instance_fields
| Sil.Earray (size, esel, _), Sil.Tarray (typ, size') -> | Sil.Earray (size, esel, _), Sil.Tarray (typ, _) ->
do_se (Sil.Eexp (size, Sil.inst_none)) (Sil.Tint Sil.IULong); do_se (Sil.Eexp (size, Sil.inst_none)) (Sil.Tint Sil.IULong);
do_array esel typ do_array esel typ
| _ -> | _ ->
@ -313,10 +313,10 @@ let create_idmap sigma : idmap =
assert false assert false
and do_struct fsel ftal = match fsel, ftal with and do_struct fsel ftal = match fsel, ftal with
| [], _ -> () | [], _ -> ()
| (f1, se) :: fsel', (f2, typ, a2) :: ftl' when Ident.fieldname_equal f1 f2 -> | (f1, se) :: fsel', (f2, typ, _) :: ftl' when Ident.fieldname_equal f1 f2 ->
do_se se typ; do_se se typ;
do_struct fsel' ftl' do_struct fsel' ftl'
| (f1, se) :: fsel', (f2, typ, a2) :: ftal' -> | _ :: _, _ :: ftal' ->
do_struct fsel ftal' do_struct fsel ftal'
| _:: _, [] -> assert false | _:: _, [] -> assert false
and do_array esel typ = match esel with and do_array esel typ = match esel with
@ -333,7 +333,7 @@ let create_idmap sigma : idmap =
| Sil.Hpointsto (e, se, Sil.Sizeof (typ, _)) -> | Sil.Hpointsto (e, se, Sil.Sizeof (typ, _)) ->
do_lhs_e e (Sil.Tptr (typ, Sil.Pk_pointer)); do_lhs_e e (Sil.Tptr (typ, Sil.Pk_pointer));
do_se se typ do_se se typ
| Sil.Hlseg (k, hpar, e, f, el) -> | Sil.Hlseg (_, _, e, f, el) ->
do_lhs_e e (Sil.Tptr (Sil.Tvoid, Sil.Pk_pointer)); 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)); do_se (Sil.Eexp (f, Sil.inst_none)) (Sil.Tptr (Sil.Tvoid, Sil.Pk_pointer));
IList.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
@ -377,7 +377,7 @@ type code = Code.t
let pp_code = Code.pp let pp_code = Code.pp
(** pretty print an ident in C *) (** pretty print an ident in C *)
let pp_id_c pe fmt id = let pp_id_c fmt id =
let name = Ident.get_name id in let name = Ident.get_name id in
let stamp = Ident.get_stamp id in let stamp = Ident.get_stamp id in
let varname = Ident.name_to_string name in let varname = Ident.name_to_string name in
@ -385,16 +385,16 @@ let pp_id_c pe fmt id =
(** pretty print an expression in C *) (** pretty print an expression in C *)
let rec pp_exp_c pe fmt = function let rec pp_exp_c pe fmt = function
| Sil.Lfield (e, f, t) -> | Sil.Lfield (e, f, _) ->
F.fprintf fmt "&(%a->%a)" (pp_exp_c pe) e Ident.pp_fieldname f F.fprintf fmt "&(%a->%a)" (pp_exp_c pe) e Ident.pp_fieldname f
| Sil.Var id -> | Sil.Var id ->
pp_id_c pe fmt id pp_id_c fmt id
| e -> | e ->
Sil.pp_exp pe fmt e Sil.pp_exp pe fmt e
(** pretty print a type in C *) (** pretty print a type in C *)
let pp_typ_c pe typ = let pp_typ_c pe typ =
let pp_nil fmt () = () in let pp_nil _ () = () in
Sil.pp_type_decl pe pp_nil pp_exp_c typ Sil.pp_type_decl pe pp_nil pp_exp_c typ
(** Convert a pvar to a string by just extracting the name *) (** Convert a pvar to a string by just extracting the name *)
@ -431,17 +431,17 @@ let pp_texp_for_malloc fmt =
| e -> pp_exp_c pe fmt e | e -> pp_exp_c pe fmt e
(* generate code for sigma *) (* generate code for sigma *)
let gen_sigma code proc_name spec_num env idmap sigma = let gen_sigma code proc_name spec_num env sigma =
let post_code = Code.empty () in let post_code = Code.empty () in
let rec do_strexp code' base need_deref = function let rec do_strexp code' base need_deref = function
| Sil.Eexp (e, inst) -> | Sil.Eexp (e, _) ->
let lhs = if need_deref then "(*"^base^")" else base in let lhs = if need_deref then "(*"^base^")" else base in
let pp f () = F.fprintf f "%s = %a;" lhs (pp_exp_c pe) e in let pp f () = F.fprintf f "%s = %a;" lhs (pp_exp_c pe) e in
Code.add_from_pp code' pp Code.add_from_pp code' pp
| Sil.Estruct (fsel, _) -> | Sil.Estruct (fsel, _) ->
let accessor = if need_deref then "->" else "." in let accessor = if need_deref then "->" else "." in
IList.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, _) -> | Sil.Earray (_, esel, _) ->
IList.iter (fun (e, se) -> IList.iter (fun (e, se) ->
let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in
let index = pp_to_string pp () in let index = pp_to_string pp () in
@ -453,15 +453,15 @@ let gen_sigma code proc_name spec_num env idmap sigma =
do_strexp post_code base false se do_strexp post_code base false se
| Sil.Hpointsto (Sil.Var id, se, te) -> | Sil.Hpointsto (Sil.Var id, se, te) ->
let pp1 f () = let pp1 f () =
F.fprintf f "%a = malloc(%a);" (pp_id_c pe) id pp_texp_for_malloc te in F.fprintf f "%a = malloc(%a);" pp_id_c id pp_texp_for_malloc te in
let pp2 f () = let pp2 f () =
F.fprintf f "if(%a == NULL) exit(12);" (pp_id_c pe) id in F.fprintf f "if(%a == NULL) exit(12);" pp_id_c id in
Code.add_from_pp code pp1; Code.add_from_pp code pp1;
Code.add_from_pp code pp2; Code.add_from_pp code pp2;
let pp3 f () = F.fprintf f "%a" (pp_id_c pe) id in let pp3 f () = F.fprintf f "%a" pp_id_c id in
let base = pp_to_string pp3 () in let base = pp_to_string pp3 () in
do_strexp post_code base true se do_strexp post_code base true se
| Sil.Hlseg (k, hpar, Sil.Var id, f, el) -> | Sil.Hlseg (_, hpar, Sil.Var id, f, el) ->
let hpara_id = Sil.Predicates.get_hpara_id env hpar in let hpara_id = Sil.Predicates.get_hpara_id env hpar in
let size_var = mk_size_name hpara_id in let size_var = mk_size_name hpara_id in
let mk_name = mk_lseg_name hpara_id proc_name spec_num in let mk_name = mk_lseg_name hpara_id proc_name spec_num in
@ -470,7 +470,7 @@ let gen_sigma code proc_name spec_num env idmap sigma =
let pp1 fmt () = let pp1 fmt () =
F.fprintf fmt "int %s = 42;" size_var in F.fprintf fmt "int %s = 42;" size_var in
let pp2 fmt () = let pp2 fmt () =
F.fprintf fmt "%a = %s(%s, %a%a);" (pp_id_c pe) id mk_name size_var (pp_exp_c pe) f pp_el el in F.fprintf fmt "%a = %s(%s, %a%a);" pp_id_c id mk_name size_var (pp_exp_c pe) f pp_el el in
Code.add_from_pp code pp1; Code.add_from_pp code pp1;
Code.add_from_pp code pp2 Code.add_from_pp code pp2
| hpred -> | hpred ->
@ -482,7 +482,7 @@ let gen_sigma code proc_name spec_num env idmap sigma =
let gen_init_equalities code pure = let gen_init_equalities code pure =
let do_atom = function let do_atom = function
| Sil.Aeq (Sil.Var id, e) -> | Sil.Aeq (Sil.Var id, e) ->
let pp f () = F.fprintf f "%a = %a;" (pp_id_c pe) id (pp_exp_c pe) e in let pp f () = F.fprintf f "%a = %a;" pp_id_c id (pp_exp_c pe) e in
Code.add_from_pp code pp Code.add_from_pp code pp
| _ -> () in | _ -> () in
IList.iter do_atom pure IList.iter do_atom pure
@ -493,8 +493,8 @@ let gen_var_decl code idmap parameters =
let pp_name f () = Mangled.pp f name in let pp_name f () = Mangled.pp f name in
let pp f () = F.fprintf f "%a;" (Sil.pp_type_decl pe pp_name pp_exp_c) typ in let pp f () = F.fprintf f "%a;" (Sil.pp_type_decl pe pp_name pp_exp_c) typ in
Code.add_from_pp code pp in Code.add_from_pp code pp in
let do_vinfo id { typ = typ; alloc = alloc } = let do_vinfo id { typ } =
let pp_var f () = pp_id_c pe f id in let pp_var f () = pp_id_c f id in
let pp f () = F.fprintf f "%a;" (Sil.pp_type_decl pe pp_var pp_exp_c) typ 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 Code.add_from_pp code pp in
IList.iter do_parameter parameters; IList.iter do_parameter parameters;
@ -520,7 +520,8 @@ let gen_init_vars code solutions idmap =
L.err "do_vinfo type undefined: %a@." (Sil.pp_typ_full pe) typ; L.err "do_vinfo type undefined: %a@." (Sil.pp_typ_full pe) typ;
assert false in assert false in
let pp fmt () = let pp fmt () =
F.fprintf fmt "%a = (%a) %a;" (pp_id_c pe) id (Sil.pp_typ_full pe) typ (Sil.pp_exp pe) (Sil.Const const) in F.fprintf fmt "%a = (%a) %a;"
pp_id_c id (Sil.pp_typ_full pe) typ (Sil.pp_exp pe) (Sil.Const const) in
Code.add_from_pp code pp in Code.add_from_pp code pp in
IdMap.iter do_vinfo idmap IdMap.iter do_vinfo idmap
@ -531,16 +532,18 @@ let filter_idmap filter idmap =
!idmap' !idmap'
let pp_svars fmt svars = let pp_svars fmt svars =
if svars != [] then F.fprintf fmt "%a" (pp_comma_seq (pp_id_c pe)) svars if svars != [] then F.fprintf fmt "%a" (pp_comma_seq pp_id_c) svars
let gen_hpara code proc_name spec_num env id hpara = let gen_hpara code proc_name spec_num env id hpara =
let mk_name = mk_lseg_name id proc_name spec_num in let mk_name = mk_lseg_name id proc_name spec_num in
let size_name = mk_size_name id in let size_name = mk_size_name id in
let pp1 f () = let pp1 f () =
F.fprintf f "void* %s(int %s, void* %a%a) {" mk_name size_name (pp_id_c pe) hpara.Sil.next pp_svars hpara.Sil.svars in F.fprintf f "void* %s(int %s, void* %a%a) {"
mk_name size_name pp_id_c hpara.Sil.next pp_svars hpara.Sil.svars in
let pp2 f () = let pp2 f () =
F.fprintf f "%a= %s(%s -1 , %a%a);" (pp_id_c pe) hpara.Sil.next mk_name size_name (pp_id_c pe) hpara.Sil.next pp_svars hpara.Sil.svars in F.fprintf f "%a= %s(%s -1 , %a%a);"
pp_id_c hpara.Sil.next mk_name size_name pp_id_c hpara.Sil.next pp_svars hpara.Sil.svars in
let line1 = pp_to_string pp1 () in let line1 = pp_to_string pp1 () in
let idmap = create_idmap hpara.Sil.body in let idmap = create_idmap hpara.Sil.body in
let idmap_ex = let idmap_ex =
@ -552,10 +555,10 @@ let gen_hpara code proc_name spec_num env id hpara =
not (Ident.equal i hpara.Sil.next) in not (Ident.equal i hpara.Sil.next) in
filter_idmap filter idmap in filter_idmap filter idmap in
let line11 = "if ("^size_name^" == 0) {" in let line11 = "if ("^size_name^" == 0) {" in
let line12 = "return " ^ (pp_to_string (pp_id_c pe) hpara.Sil.next) ^ ";" in let line12 = "return " ^ (pp_to_string pp_id_c hpara.Sil.next) ^ ";" in
let line13 ="} else {" in let line13 ="} else {" in
let line14 = pp_to_string pp2 () in let line14 = pp_to_string pp2 () in
let line2 = "return " ^ (pp_to_string (pp_id_c pe) hpara.Sil.root) ^ ";" in let line2 = "return " ^ (pp_to_string pp_id_c hpara.Sil.root) ^ ";" in
let line3 = "}" in let line3 = "}" in
Code.add_line code line1; Code.add_line code line1;
Code.set_indent " "; Code.set_indent " ";
@ -568,7 +571,7 @@ let gen_hpara code proc_name spec_num env id hpara =
Code.set_indent " "; Code.set_indent " ";
Code.add_line code line14; Code.add_line code line14;
gen_init_vars code IdMap.empty idmap_ex; gen_init_vars code IdMap.empty idmap_ex;
gen_sigma code proc_name spec_num env idmap hpara.Sil.body; gen_sigma code proc_name spec_num env hpara.Sil.body;
Code.add_line code line2; Code.add_line code line2;
Code.set_indent " "; Code.set_indent " ";
Code.add_line code line3; Code.add_line code line3;
@ -576,7 +579,7 @@ let gen_hpara code proc_name spec_num env id hpara =
Code.add_line code line3; Code.add_line code line3;
Code.add_line code "" Code.add_line code ""
let gen_hpara_dll code proc_name spec_num env id hpara_dll = assert false let gen_hpara_dll _ _ _ _ _ _ = assert false
(** Generate epilog for the test case *) (** Generate epilog for the test case *)
let gen_epilog code proc_name (parameters : (Mangled.t * Sil.typ) list) = let gen_epilog code proc_name (parameters : (Mangled.t * Sil.typ) list) =
@ -603,7 +606,7 @@ let gen_prolog code fname proc_name spec_num =
let solve_constraints pure idmap = let solve_constraints pure idmap =
let vars = ref [] in let vars = ref [] in
let do_vinfo id { typ = typ; alloc = alloc } = let do_vinfo id { alloc } =
if not alloc then vars := !vars @ [id] in if not alloc then vars := !vars @ [id] in
IdMap.iter do_vinfo idmap; IdMap.iter do_vinfo idmap;
Constraint.solve_from_pure pure !vars Constraint.solve_from_pure pure !vars
@ -623,7 +626,7 @@ let genunit fname proc_name spec_num parameters spec =
gen_var_decl code idmap parameters; gen_var_decl code idmap parameters;
gen_init_vars code (solve_constraints pure idmap) idmap; gen_init_vars code (solve_constraints pure idmap) idmap;
gen_init_equalities code pure; gen_init_equalities code pure;
gen_sigma code proc_name spec_num env idmap sigma; gen_sigma code proc_name spec_num env sigma;
gen_epilog code proc_name parameters; gen_epilog code proc_name parameters;
code code

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

@ -30,11 +30,13 @@ let check_nested_loop path pos_opt =
(* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *) (* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *)
loop_visits_log := b :: !loop_visits_log loop_visits_log := b :: !loop_visits_log
| _ -> () in | _ -> () in
let do_any_node level node = let do_any_node _level _node =
incr trace_length; incr trace_length;
(* L.d_strln ("level " ^ string_of_int level ^ " (Cfg.Node.get_id node) " ^ string_of_int nid); *) (* L.d_strln *)
() in (* ("level " ^ string_of_int _level ^ *)
let f level p session exn_opt = match Paths.Path.curr_node p with (* " (Cfg.Node.get_id node) " ^ string_of_int (Cfg.Node.get_id _node)) *)
in
let f level p _ _ = match Paths.Path.curr_node p with
| Some node -> | Some node ->
do_any_node level node; do_any_node level node;
if level = 0 then do_node_caller node if level = 0 then do_node_caller node
@ -80,7 +82,7 @@ let check_access access_opt de_opt =
let filter = function let filter = function
| Sil.Call (_, _, etl, _, _) -> | Sil.Call (_, _, etl, _, _) ->
let formal_ids = find_formal_ids node in let formal_ids = find_formal_ids node in
let arg_is_formal_param (e, t) = match e with let arg_is_formal_param (e, _) = match e with
| Sil.Var id -> IList.exists (Ident.equal id) formal_ids | Sil.Var id -> IList.exists (Ident.equal id) formal_ids
| _ -> false in | _ -> false in
if IList.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;
@ -111,7 +113,7 @@ let check_access access_opt de_opt =
find_bucket n ncf find_bucket n ncf
| Some (Localise.Returned_from_call n) -> | Some (Localise.Returned_from_call n) ->
find_bucket n false find_bucket n false
| Some (Localise.Last_accessed (n, is_nullable)) when is_nullable -> | Some (Localise.Last_accessed (_, is_nullable)) when is_nullable ->
Some Localise.BucketLevel.b1 Some Localise.BucketLevel.b1
| _ -> | _ ->
begin begin

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

@ -79,7 +79,7 @@ let iterate_procedure_callbacks exe_env proc_name =
| None -> () in | None -> () in
Option.may Option.may
(fun (idenv, tenv, proc_name, proc_desc, language) -> (fun (idenv, tenv, proc_name, proc_desc, _) ->
IList.iter IList.iter
(fun (language_opt, proc_callback) -> (fun (language_opt, proc_callback) ->
let language_matches = match language_opt with let language_matches = match language_opt with

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

@ -381,14 +381,13 @@ module Node = struct
pdesc_tbl_add cfg proc_attributes.ProcAttributes.proc_name pdesc; pdesc_tbl_add cfg proc_attributes.ProcAttributes.proc_name pdesc;
pdesc pdesc
let remove_node' filter_out_fun cfg node = let remove_node' filter_out_fun cfg =
let remove_node_in_cfg nodes = let remove_node_in_cfg nodes =
IList.filter filter_out_fun nodes in IList.filter filter_out_fun nodes in
cfg.node_list := remove_node_in_cfg !(cfg.node_list) cfg.node_list := remove_node_in_cfg !(cfg.node_list)
let remove_node_set cfg nodes = let remove_node_set cfg nodes =
remove_node' (fun node' -> not (NodeSet.mem node' nodes)) remove_node' (fun node' -> not (NodeSet.mem node' nodes)) cfg
cfg nodes
let proc_desc_remove cfg name remove_nodes = let proc_desc_remove cfg name remove_nodes =
(if remove_nodes then (if remove_nodes then
@ -500,7 +499,7 @@ module Node = struct
| Stmt_node s -> | Stmt_node s ->
if sub_instrs then print_sub_instrs () if sub_instrs then print_sub_instrs ()
else F.fprintf fmt "statements (%s) %a" s pp_loc () else F.fprintf fmt "statements (%s) %a" s pp_loc ()
| Prune_node (is_true_branch, if_kind, descr) -> | Prune_node (_, _, descr) ->
if sub_instrs then print_sub_instrs () if sub_instrs then print_sub_instrs ()
else F.fprintf fmt "assume %s %a" descr pp_loc () else F.fprintf fmt "assume %s %a" descr pp_loc ()
| Exit_node _ -> | Exit_node _ ->
@ -526,11 +525,11 @@ module Node = struct
match get_kind node with match get_kind node with
| Stmt_node _ -> | Stmt_node _ ->
"Instructions" "Instructions"
| Prune_node (is_true_branch, if_kind, descr) -> | Prune_node (_, _, descr) ->
"Conditional" ^ " " ^ descr "Conditional" ^ " " ^ descr
| Exit_node _ -> | Exit_node _ ->
"Exit" "Exit"
| Skip_node s -> | Skip_node _ ->
"Skip" "Skip"
| Start_node _ -> | Start_node _ ->
"Start" "Start"
@ -568,7 +567,7 @@ module Node = struct
do_node (proc_desc_get_start_node proc_desc) do_node (proc_desc_get_start_node proc_desc)
(** iterate between two nodes or until we reach a branching structure *) (** iterate between two nodes or until we reach a branching structure *)
let proc_desc_iter_slope_range f proc_desc src_node dst_node = let proc_desc_iter_slope_range f src_node dst_node =
let visited = ref NodeSet.empty in let visited = ref NodeSet.empty in
let rec do_node node = begin let rec do_node node = begin
visited := NodeSet.add node !visited; visited := NodeSet.add node !visited;
@ -672,7 +671,7 @@ let rec pp_node_list f = function
(** Get all the procdescs (defined and declared) *) (** Get all the procdescs (defined and declared) *)
let get_all_procs cfg = let get_all_procs cfg =
let procs = ref [] in let procs = ref [] in
let f pname pdesc = procs := pdesc :: !procs in let f _ pdesc = procs := pdesc :: !procs in
iter_proc_desc cfg f; !procs iter_proc_desc cfg f; !procs
(** Get the procedures whose body is defined in this cfg *) (** Get the procedures whose body is defined in this cfg *)
@ -724,7 +723,7 @@ let add_abstraction_instructions cfg =
if node_requires_abstraction node then Node.append_instrs_temps node [Sil.Abstract loc] [] in if node_requires_abstraction node then Node.append_instrs_temps node [Sil.Abstract loc] [] in
IList.iter do_node all_nodes IList.iter do_node all_nodes
let get_name_of_local (curr_f : Procdesc.t) (x, typ) = let get_name_of_local (curr_f : Procdesc.t) (x, _) =
Sil.mk_pvar x (Procdesc.get_proc_name curr_f) Sil.mk_pvar x (Procdesc.get_proc_name curr_f)
(* returns a list of local static variables (ie local variables defined static) in a proposition *) (* returns a list of local static variables (ie local variables defined static) in a proposition *)
@ -766,7 +765,7 @@ let remove_abducted_retvars p =
IList.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, _) -> | Sil.Earray (_, elems, _) ->
IList.fold_left (fun exps (index, strexp) -> collect_exps exps strexp) exps elems in IList.fold_left (fun exps (_, strexp) -> collect_exps exps strexp) exps elems in
let rec compute_reachable_hpreds_rec sigma (reach, exps) = let rec compute_reachable_hpreds_rec sigma (reach, exps) =
let add_hpred_if_reachable (reach, exps) = function let add_hpred_if_reachable (reach, exps) = function
| Sil.Hpointsto (lhs, rhs, _) as hpred when Sil.ExpSet.mem lhs exps -> | Sil.Hpointsto (lhs, rhs, _) as hpred when Sil.ExpSet.mem lhs exps ->
@ -925,7 +924,7 @@ let load_cfg_from_file (filename : DB.filename) : cfg option =
(** save a copy in the results dir of the source files of procedures defined in the cfg, (** save a copy in the results dir of the source files of procedures defined in the cfg,
unless an updated copy already exists *) unless an updated copy already exists *)
let save_source_files cfg = let save_source_files cfg =
let process_proc pname pdesc = let process_proc _ pdesc =
let loc = Node.proc_desc_get_loc pdesc in let loc = Node.proc_desc_get_loc pdesc in
let source_file = loc.Location.file in let source_file = loc.Location.file in
let source_file_str = DB.source_file_to_abs_path source_file in let source_file_str = DB.source_file_to_abs_path source_file in
@ -945,7 +944,7 @@ let save_source_files cfg =
Node.iter_proc_desc cfg process_proc Node.iter_proc_desc cfg process_proc
(** Save the .attr files for the procedures in the cfg. *) (** Save the .attr files for the procedures in the cfg. *)
let save_attributes filename cfg = let save_attributes cfg =
let save_proc proc_desc = let save_proc proc_desc =
let attributes = Procdesc.get_attributes proc_desc in let attributes = Procdesc.get_attributes proc_desc in
let loc = attributes.ProcAttributes.loc in let loc = attributes.ProcAttributes.loc in
@ -966,7 +965,7 @@ let save_attributes filename cfg =
IList.iter save_proc (get_all_procs cfg) IList.iter save_proc (get_all_procs cfg)
(** Inline a synthetic (access or bridge) method. *) (** Inline a synthetic (access or bridge) method. *)
let inline_synthetic_method ret_ids etl proc_desc proc_name loc_call : Sil.instr option = let inline_synthetic_method ret_ids etl proc_desc loc_call : Sil.instr option =
let modified = ref None in let modified = ref None in
let debug = false in let debug = false in
let found instr instr' = let found instr instr' =
@ -976,32 +975,32 @@ let inline_synthetic_method ret_ids etl proc_desc proc_name loc_call : Sil.instr
L.stderr "XX inline_synthetic_method found instr: %a@." (Sil.pp_instr pe_text) instr; L.stderr "XX inline_synthetic_method found instr: %a@." (Sil.pp_instr pe_text) instr;
L.stderr "XX inline_synthetic_method instr': %a@." (Sil.pp_instr pe_text) instr' L.stderr "XX inline_synthetic_method instr': %a@." (Sil.pp_instr pe_text) instr'
end in end in
let do_instr node instr = let do_instr _ instr =
match instr, ret_ids, etl with match instr, ret_ids, etl with
| Sil.Letderef (id1, Sil.Lfield (Sil.Var id2, fn, ft), bt, loc), | Sil.Letderef (_, Sil.Lfield (Sil.Var _, fn, ft), bt, _),
[ret_id], [ret_id],
[(e1, t1)] -> (* getter for fields *) [(e1, _)] -> (* getter for fields *)
let instr' = Sil.Letderef (ret_id, Sil.Lfield (e1, fn, ft), bt, loc_call) in let instr' = Sil.Letderef (ret_id, Sil.Lfield (e1, fn, ft), bt, loc_call) in
found instr instr' found instr instr'
| Sil.Letderef (id1, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc), [ret_id], [] | Sil.Letderef (_, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, _), [ret_id], []
when Sil.pvar_is_global pvar -> (* getter for static fields *) when Sil.pvar_is_global pvar -> (* getter for static fields *)
let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in
found instr instr' found instr instr'
| Sil.Set (Sil.Lfield (ex1, fn, ft), bt , ex2, loc), | Sil.Set (Sil.Lfield (_, fn, ft), bt , _, _),
_, _,
[(e1, t1); (e2, t2)] -> (* setter for fields *) [(e1, _); (e2, _)] -> (* setter for fields *)
let instr' = Sil.Set (Sil.Lfield (e1, fn, ft), bt , e2, loc_call) in let instr' = Sil.Set (Sil.Lfield (e1, fn, ft), bt , e2, loc_call) in
found instr instr' found instr instr'
| Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , ex2, loc), _, [(e1, t1)] | Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , _, _), _, [(e1, _)]
when Sil.pvar_is_global pvar -> (* setter for static fields *) when Sil.pvar_is_global pvar -> (* setter for static fields *)
let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in
found instr instr' found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _ | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', _, cf), _, _
when IList.length ret_ids = IList.length ret_ids' when IList.length ret_ids = IList.length ret_ids'
&& IList.length etl' = IList.length etl -> && IList.length etl' = IList.length etl ->
let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in
found instr instr' found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _ | Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', _, cf), _, _
when IList.length ret_ids = IList.length ret_ids' when IList.length ret_ids = IList.length ret_ids'
&& IList.length etl' + 1 = IList.length etl -> && IList.length etl' + 1 = IList.length etl ->
let etl1 = match IList.rev etl with (* remove last element *) let etl1 = match IList.rev etl with (* remove last element *)
@ -1024,7 +1023,7 @@ let proc_inline_synthetic_methods cfg proc_desc : unit =
let is_synthetic = attributes.ProcAttributes.is_synthetic_method in let is_synthetic = attributes.ProcAttributes.is_synthetic_method in
let is_bridge = attributes.ProcAttributes.is_bridge_method in let is_bridge = attributes.ProcAttributes.is_bridge_method in
if is_access || is_bridge || is_synthetic if is_access || is_bridge || is_synthetic
then inline_synthetic_method ret_ids etl pd pn loc then inline_synthetic_method ret_ids etl pd loc
else None else None
| None -> None) | None -> None)
| _ -> None in | _ -> None in
@ -1057,5 +1056,5 @@ let store_cfg_to_file (filename : DB.filename) (save_sources : bool) (cfg : cfg)
| Some old_cfg -> Node.mark_unchanged_pdescs cfg old_cfg | Some old_cfg -> Node.mark_unchanged_pdescs cfg old_cfg
| None -> () | None -> ()
end; end;
save_attributes filename cfg; save_attributes cfg;
Serialization.to_file cfg_serializer filename cfg Serialization.to_file cfg_serializer filename cfg

2
infer/src/backend/cfg.mli
Unescape View File

@ -106,7 +106,7 @@ module Procdesc : sig
val iter_slope_calls : (Procname.t -> unit) -> t -> unit val iter_slope_calls : (Procname.t -> unit) -> t -> unit
(** iterate between two nodes or until we reach a branching structure *) (** iterate between two nodes or until we reach a branching structure *)
val iter_slope_range : (node -> unit) -> t -> node -> node -> unit val iter_slope_range : (node -> unit) -> node -> node -> unit
val set_exit_node : t -> node -> unit val set_exit_node : t -> node -> unit

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

@ -180,7 +180,7 @@ let restrict_defined (g: t) (nodeset_opt: Procname.Set.t option) =
let get_nodes (g: t) = let get_nodes (g: t) =
let nodes = ref Procname.Set.empty in let nodes = ref Procname.Set.empty in
let f node info = let f node _ =
nodes := Procname.Set.add node !nodes in nodes := Procname.Set.add node !nodes in
node_map_iter f g; node_map_iter f g;
!nodes !nodes
@ -204,7 +204,7 @@ let get_all_nodes (g: t) =
IList.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) = let get_nodes_and_calls (g: t) =
IList.filter (fun (n, calls) -> node_defined g n) (get_all_nodes g) IList.filter (fun (n, _) -> node_defined g n) (get_all_nodes g)
let node_get_num_ancestors g n = let node_get_num_ancestors g n =
(n, Procname.Set.cardinal (get_ancestors g n)) (n, Procname.Set.cardinal (get_ancestors g n))
@ -277,11 +277,11 @@ type nodes_and_edges =
let get_nodes_and_edges (g: t) : nodes_and_edges = let get_nodes_and_edges (g: t) : nodes_and_edges =
let nodes = ref [] in let nodes = ref [] in
let edges = ref [] in let edges = ref [] in
let do_children node info nto = let do_children node nto =
edges := (node, nto) :: !edges in edges := (node, nto) :: !edges in
let f node info = let f node info =
nodes := (node, info.defined, info.disabled) :: !nodes; nodes := (node, info.defined, info.disabled) :: !nodes;
Procname.Set.iter (do_children node info) info.children in Procname.Set.iter (do_children node) info.children in
node_map_iter f g; node_map_iter f g;
(!nodes, !edges) (!nodes, !edges)
@ -345,11 +345,11 @@ let store_to_file (filename : DB.filename) (call_graph : t) =
let pp_graph_dotty get_specs (g: t) fmt = let pp_graph_dotty get_specs (g: t) fmt =
let nodes_with_calls = get_all_nodes g in let nodes_with_calls = get_all_nodes g in
let num_specs n = try IList.length (get_specs n) with exn when exn_not_failure exn -> - 1 in let num_specs n = try IList.length (get_specs n) with exn when exn_not_failure exn -> - 1 in
let get_color (n, calls) = let get_color (n, _) =
if num_specs n != 0 then "green" else "red" in if num_specs n != 0 then "green" else "red" in
let get_shape (n, calls) = let get_shape (n, _) =
if node_defined g n then "box" else "diamond" in if node_defined g n then "box" else "diamond" in
let pp_node fmt (n, calls) = let pp_node fmt (n, _) =
F.fprintf fmt "\"%s\"" (Procname.to_filename n) in F.fprintf fmt "\"%s\"" (Procname.to_filename n) in
let pp_node_label fmt (n, calls) = 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 "\"%a | calls=%d %d | specs=%d)\"" Procname.pp n calls.in_calls calls.out_calls (num_specs n) in

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

@ -268,7 +268,7 @@ module CheckJoinPre : InfoLossCheckerSig = struct
match e with match e with
| Sil.Lvar _ -> false | Sil.Lvar _ -> false
| Sil.Var id when Ident.is_normal id -> IList.length es >= 1 | Sil.Var id when Ident.is_normal id -> IList.length es >= 1
| Sil.Var id -> | Sil.Var _ ->
if !Config.join_cond = 0 then if !Config.join_cond = 0 then
IList.exists (Sil.exp_equal Sil.exp_zero) es IList.exists (Sil.exp_equal Sil.exp_zero) es
else if Dangling.check side e then else if Dangling.check side e then
@ -307,17 +307,17 @@ end
module CheckJoinPost : InfoLossCheckerSig = struct module CheckJoinPost : InfoLossCheckerSig = struct
let init sigma1 sigma2 = let init _ _ =
NonInj.init () NonInj.init ()
let final () = let final () =
NonInj.final () NonInj.final ()
let fail_case side e es = let fail_case _ e es =
match e with match e with
| Sil.Lvar _ -> false | Sil.Lvar _ -> false
| Sil.Var id when Ident.is_normal id -> IList.length es >= 1 | Sil.Var id when Ident.is_normal id -> IList.length es >= 1
| Sil.Var id -> false | Sil.Var _ -> false
| _ -> false | _ -> false
let lost_little side e es = let lost_little side e es =
@ -463,7 +463,7 @@ end = struct
let init () = t := [] let init () = t := []
let final () = t := [] let final () = t := []
let entry_compare (e1, e2, _) (e1', e2', _) = let entry_compare (e1, e2, _) (_, e2', _) =
let n1 = Sil.exp_compare e1 e2 in let n1 = Sil.exp_compare e1 e2 in
if n1 <> 0 then n1 else Sil.exp_compare e2 e2' if n1 <> 0 then n1 else Sil.exp_compare e2 e2'
@ -628,7 +628,7 @@ end = struct
begin begin
let r = lookup_side' side e in let r = lookup_side' side e in
match r with match r with
| [(e1, e2, id) as t] -> if todo then Todo.push t; id | [(_, _, id) as t] -> if todo then Todo.push t; id
| _ -> L.d_strln "failure reason 9"; raise IList.Fail | _ -> L.d_strln "failure reason 9"; raise IList.Fail
end end
| Sil.Var _ | Sil.Const _ | Sil.Lvar _ -> if todo then Todo.push (e, e, e); e | Sil.Var _ | Sil.Const _ | Sil.Lvar _ -> if todo then Todo.push (e, e, e); e
@ -647,17 +647,17 @@ end = struct
(function (e1, e2, Sil.Var i) -> (i, select side e1 e2) | _ -> assert false) (function (e1, e2, Sil.Var i) -> (i, select side e1 e2) | _ -> assert false)
renaming_restricted in renaming_restricted in
let sub_list_side_sorted = let sub_list_side_sorted =
IList.sort (fun (i, e) (i', e') -> Sil.exp_compare e e') sub_list_side in IList.sort (fun (_, e) (_, e') -> Sil.exp_compare e e') sub_list_side in
let rec find_duplicates = let rec find_duplicates =
function function
| (i, e):: ((i', e'):: l' as t) -> Sil.exp_equal e e' || find_duplicates t | (_, e):: ((_, e'):: _ as t) -> Sil.exp_equal e e' || find_duplicates t
| _ -> false in | _ -> false in
if find_duplicates sub_list_side_sorted then (L.d_strln "failure reason 11"; raise IList.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 else Sil.sub_of_list sub_list_side
let to_subst_emb (side : side) = let to_subst_emb (side : side) =
let renaming_restricted = let renaming_restricted =
let pick_id_case (e1, e2, e) = let pick_id_case (e1, e2, _) =
match select side e1 e2 with match select side e1 e2 with
| Sil.Var i -> can_rename i | Sil.Var i -> can_rename i
| _ -> false in | _ -> false in
@ -672,7 +672,7 @@ end = struct
let compare (i, _) (i', _) = Ident.compare i i' in let compare (i, _) (i', _) = Ident.compare i i' in
IList.sort compare sub_list in IList.sort compare sub_list in
let rec find_duplicates = function let rec find_duplicates = function
| (i, _):: ((i', _):: l' as t) -> Ident.equal i i' || find_duplicates t | (i, _):: ((i', _):: _ as t) -> Ident.equal i i' || find_duplicates t
| _ -> false in | _ -> false in
if find_duplicates sub_list_sorted then (L.d_strln "failure reason 12"; raise IList.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 else Sil.sub_of_list sub_list_sorted
@ -905,8 +905,8 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Var id1, Sil.Var id2 -> | Sil.Var id1, Sil.Var id2 ->
ident_partial_join id1 id2 ident_partial_join id1 id2
| Sil.Var id, Sil.Const c | Sil.Var id, Sil.Const _
| Sil.Const c, Sil.Var id -> | Sil.Const _, Sil.Var id ->
if Ident.is_normal id then if Ident.is_normal id then
(L.d_strln "failure reason 20"; raise IList.Fail) (L.d_strln "failure reason 20"; raise IList.Fail)
else else
@ -938,7 +938,7 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
else else
let e1'' = exp_partial_join e1 e2 in let e1'' = exp_partial_join e1 e2 in
Sil.Cast (t1, e1'') Sil.Cast (t1, e1'')
| Sil.UnOp(unop1, e1, topt1), Sil.UnOp(unop2, e2, topt2) -> | Sil.UnOp(unop1, e1, topt1), Sil.UnOp(unop2, e2, _) ->
if not (Sil.unop_equal unop1 unop2) then (L.d_strln "failure reason 23"; raise IList.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 *) 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') -> | Sil.BinOp(Sil.PlusPI, e1, e1'), Sil.BinOp(Sil.PlusPI, e2, e2') ->
@ -956,7 +956,7 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Lvar(pvar1), Sil.Lvar(pvar2) -> | Sil.Lvar(pvar1), Sil.Lvar(pvar2) ->
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 25"; raise IList.Fail) if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 25"; raise IList.Fail)
else e1 else e1
| Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, t2) -> | Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, _) ->
if not (Sil.fld_equal f1 f2) then (L.d_strln "failure reason 26"; raise IList.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 *) else Sil.Lfield(exp_partial_join e1 e2, f1, t1) (* should be t1 = t2 *)
| Sil.Lindex(e1, e1'), Sil.Lindex(e2, e2') -> | Sil.Lindex(e1, e1'), Sil.Lindex(e2, e2') ->
@ -1011,7 +1011,7 @@ let rec exp_partial_meet (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
else else
let e1'' = exp_partial_meet e1 e2 in let e1'' = exp_partial_meet e1 e2 in
Sil.Cast (t1, e1'') Sil.Cast (t1, e1'')
| Sil.UnOp(unop1, e1, topt1), Sil.UnOp(unop2, e2, topt2) -> | Sil.UnOp(unop1, e1, topt1), Sil.UnOp(unop2, e2, _) ->
if not (Sil.unop_equal unop1 unop2) then (L.d_strln "failure reason 31"; raise IList.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 *) else Sil.UnOp (unop1, exp_partial_meet e1 e2, topt1) (* should be topt1 = topt2 *)
| Sil.BinOp(binop1, e1, e1'), Sil.BinOp(binop2, e2, e2') -> | Sil.BinOp(binop1, e1, e1'), Sil.BinOp(binop2, e2, e2') ->
@ -1031,7 +1031,7 @@ let rec exp_partial_meet (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Lvar(pvar1), Sil.Lvar(pvar2) -> | Sil.Lvar(pvar1), Sil.Lvar(pvar2) ->
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 35"; raise IList.Fail) if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 35"; raise IList.Fail)
else e1 else e1
| Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, t2) -> | Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, _) ->
if not (Sil.fld_equal f1 f2) then (L.d_strln "failure reason 36"; raise IList.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 *) else Sil.Lfield(exp_partial_meet e1 e2, f1, t1) (* should be t1 = t2 *)
| Sil.Lindex(e1, e1'), Sil.Lindex(e2, e2') -> | Sil.Lindex(e1, e1'), Sil.Lindex(e2, e2') ->
@ -1052,7 +1052,7 @@ 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 = let rec f_fld_se_list inst mode acc fld_se_list1 fld_se_list2 =
match fld_se_list1, fld_se_list2 with match fld_se_list1, fld_se_list2 with
| [], [] -> Sil.Estruct (IList.rev acc, inst) | [], [] -> Sil.Estruct (IList.rev acc, inst)
| [], other_fsel | other_fsel, [] -> | [], _ | _, [] ->
begin begin
match mode with match mode with
| JoinState.Pre -> (L.d_strln "failure reason 42"; raise IList.Fail) | JoinState.Pre -> (L.d_strln "failure reason 42"; raise IList.Fail)
@ -1082,7 +1082,7 @@ 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 = 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 match idx_se_list1, idx_se_list2 with
| [], [] -> Sil.Earray (size, IList.rev idx_se_list_acc, inst) | [], [] -> Sil.Earray (size, IList.rev idx_se_list_acc, inst)
| [], other_isel | other_isel, [] -> | [], _ | _, [] ->
begin begin
match mode with match mode with
| JoinState.Pre -> (L.d_strln "failure reason 44"; raise IList.Fail) | JoinState.Pre -> (L.d_strln "failure reason 44"; raise IList.Fail)
@ -1212,10 +1212,10 @@ let hpara_dll_partial_meet (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil
let hpred_partial_join mode (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred = let hpred_partial_join mode (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred =
let e1, e2, e = todo in let e1, e2, e = todo in
match hpred1, hpred2 with match hpred1, hpred2 with
| Sil.Hpointsto (e1, se1, te1), Sil.Hpointsto (e2, se2, te2) -> | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) ->
let te = exp_partial_join te1 te2 in let te = exp_partial_join te1 te2 in
Prop.mk_ptsto e (strexp_partial_join mode se1 se2) te Prop.mk_ptsto e (strexp_partial_join mode se1 se2) te
| Sil.Hlseg (k1, hpara1, root1, next1, shared1), Sil.Hlseg (k2, hpara2, root2, next2, shared2) -> | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) ->
let hpara' = hpara_partial_join hpara1 hpara2 in let hpara' = hpara_partial_join hpara1 hpara2 in
let next' = exp_partial_join next1 next2 in let next' = exp_partial_join next1 next2 in
let shared' = exp_list_partial_join shared1 shared2 in let shared' = exp_list_partial_join shared1 shared2 in
@ -1239,11 +1239,11 @@ let hpred_partial_join mode (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpr
let hpred_partial_meet (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred = let hpred_partial_meet (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred =
let e1, e2, e = todo in let e1, e2, e = todo in
match hpred1, hpred2 with match hpred1, hpred2 with
| Sil.Hpointsto (e1, se1, te1), Sil.Hpointsto (e2, se2, te2) when Sil.exp_equal te1 te2 -> | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) when Sil.exp_equal te1 te2 ->
Prop.mk_ptsto e (strexp_partial_meet se1 se2) te1 Prop.mk_ptsto e (strexp_partial_meet se1 se2) te1
| Sil.Hpointsto _, _ | _, Sil.Hpointsto _ -> | Sil.Hpointsto _, _ | _, Sil.Hpointsto _ ->
(L.d_strln "failure reason 58"; raise IList.Fail) (L.d_strln "failure reason 58"; raise IList.Fail)
| Sil.Hlseg (k1, hpara1, root1, next1, shared1), Sil.Hlseg (k2, hpara2, root2, next2, shared2) -> | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) ->
let hpara' = hpara_partial_meet hpara1 hpara2 in let hpara' = hpara_partial_meet hpara1 hpara2 in
let next' = exp_partial_meet next1 next2 in let next' = exp_partial_meet next1 next2 in
let shared' = exp_list_partial_meet shared1 shared2 in let shared' = exp_list_partial_meet shared1 shared2 in
@ -1322,7 +1322,7 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
CheckJoin.add side root next; CheckJoin.add side root next;
Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared') Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared')
| Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared) | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared)
when Sil.exp_equal iF e -> when Sil.exp_equal iF e ->
let oF' = do_side side exp_partial_join oF opposite in let oF' = do_side side exp_partial_join oF opposite in
let shared' = Rename.lookup_list side shared in let shared' = Rename.lookup_list side shared in
@ -1335,7 +1335,7 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
CheckJoin.add side oB iB; CheckJoin.add side oB iB;
Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared') Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared')
| Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared) | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared)
when Sil.exp_equal iB e -> when Sil.exp_equal iB e ->
let oB' = do_side side exp_partial_join oB opposite in let oB' = do_side side exp_partial_join oB opposite in
let shared' = Rename.lookup_list side shared in let shared' = Rename.lookup_list side shared in
@ -1587,7 +1587,7 @@ let pi_partial_join mode
else widening_top in else widening_top in
let a' = Prop.mk_inequality (Sil.BinOp(Sil.Le, e, Sil.exp_int bound)) in let a' = Prop.mk_inequality (Sil.BinOp(Sil.Le, e, Sil.exp_int bound)) in
Some a' Some a'
| Some (e, n), [] -> | Some (e, _), [] ->
let bound = widening_top in let bound = widening_top in
let a' = Prop.mk_inequality (Sil.BinOp(Sil.Le, e, Sil.exp_int bound)) in let a' = Prop.mk_inequality (Sil.BinOp(Sil.Le, e, Sil.exp_int bound)) in
Some a' Some a'
@ -1651,8 +1651,8 @@ let pi_partial_join mode
| Sil.Aneq(e, e') | Sil.Aeq(e, e') | Sil.Aneq(e, e') | Sil.Aeq(e, e')
when (exp_is_const e && exp_is_const e') -> when (exp_is_const e && exp_is_const e') ->
true true
| Sil.Aneq(Sil.Var id, e') | Sil.Aneq(e', Sil.Var id) | Sil.Aneq(Sil.Var _, e') | Sil.Aneq(e', Sil.Var _)
| Sil.Aeq(Sil.Var id, e') | Sil.Aeq(e', Sil.Var id) | Sil.Aeq(Sil.Var _, e') | Sil.Aeq(e', Sil.Var _)
when (exp_is_const e') -> when (exp_is_const e') ->
true true
| Sil.Aneq _ -> false | Sil.Aneq _ -> false
@ -1913,8 +1913,8 @@ let jplist_collapse mode jplist =
let jprop_list_add_ids jplist = let jprop_list_add_ids jplist =
let seq_number = ref 0 in let seq_number = ref 0 in
let rec do_jprop = function let rec do_jprop = function
| Specs.Jprop.Prop (n, p) -> incr seq_number; Specs.Jprop.Prop (!seq_number, p) | Specs.Jprop.Prop (_, p) -> incr seq_number; Specs.Jprop.Prop (!seq_number, p)
| Specs.Jprop.Joined (n, p, jp1, jp2) -> | Specs.Jprop.Joined (_, p, jp1, jp2) ->
let jp1' = do_jprop jp1 in let jp1' = do_jprop jp1 in
let jp2' = do_jprop jp2 in let jp2' = do_jprop jp2 in
incr seq_number; incr seq_number;

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

@ -125,12 +125,12 @@ let strip_special_chars s =
let rec strexp_to_string pe coo f se = let rec strexp_to_string pe coo f se =
match se with match se with
| Sil.Eexp (Sil.Lvar pvar, inst) -> F.fprintf f "%a" (Sil.pp_pvar pe) pvar | Sil.Eexp (Sil.Lvar pvar, _) -> F.fprintf f "%a" (Sil.pp_pvar pe) pvar
| Sil.Eexp (Sil.Var id, inst) -> | Sil.Eexp (Sil.Var id, _) ->
if !print_full_prop then if !print_full_prop then
F.fprintf f "%a" (Ident.pp pe) id F.fprintf f "%a" (Ident.pp pe) id
else () else ()
| Sil.Eexp (e, inst) -> | Sil.Eexp (e, _) ->
if !print_full_prop then if !print_full_prop then
F.fprintf f "%a" (Sil.pp_exp pe) e F.fprintf f "%a" (Sil.pp_exp pe) e
else F.fprintf f "_" else F.fprintf f "_"
@ -145,7 +145,7 @@ and struct_to_dotty_str pe coo f ls : unit =
and get_contents_sexp pe coo f se = and get_contents_sexp pe coo f se =
match se with match se with
| Sil.Eexp (e', inst') -> | Sil.Eexp (e', _) ->
F.fprintf f "%a" (Sil.pp_exp pe) e' F.fprintf f "%a" (Sil.pp_exp pe) e'
| Sil.Estruct (se', _) -> | Sil.Estruct (se', _) ->
F.fprintf f "| { %a }" (struct_to_dotty_str pe coo) se' F.fprintf f "| { %a }" (struct_to_dotty_str pe coo) se'
@ -241,14 +241,14 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list
incr dotty_state_count; incr dotty_state_count;
let coo = mk_coordinate n lambda in let coo = mk_coordinate n lambda in
(match hpred with (match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) | Sil.Hpointsto (_, Sil.Eexp (e, _), _)
when not (Sil.exp_equal e Sil.exp_zero) && !print_full_prop -> when not (Sil.exp_equal e Sil.exp_zero) && !print_full_prop ->
let e_color_str = color_to_str (exp_color hpred e) in let e_color_str = color_to_str (exp_color hpred e) in
[Dotdangling(coo, e, e_color_str)] [Dotdangling(coo, e, e_color_str)]
| Sil.Hlseg (k, hpara, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> | Sil.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) ->
let e2_color_str = color_to_str (exp_color hpred e2) in let e2_color_str = color_to_str (exp_color hpred e2) in
[Dotdangling(coo, e2, e2_color_str)] [Dotdangling(coo, e2, e2_color_str)]
| Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, elist) -> | Sil.Hdllseg (_, _, _, e2, e3, _, _) ->
let e2_color_str = color_to_str (exp_color hpred e2) in let e2_color_str = color_to_str (exp_color hpred e2) in
let e3_color_str = color_to_str (exp_color hpred e3) in let e3_color_str = color_to_str (exp_color hpred e3) in
let ll = if not (Sil.exp_equal e2 Sil.exp_zero) then let ll = if not (Sil.exp_equal e2 Sil.exp_zero) then
@ -292,7 +292,7 @@ let rec dotty_mk_node pe sigma =
let n = !dotty_state_count in let n = !dotty_state_count in
incr dotty_state_count; incr dotty_state_count;
let do_hpred_lambda exp_color = function let do_hpred_lambda exp_color = function
| (Sil.Hpointsto (e, Sil.Earray(e', l, _), Sil.Sizeof(Sil.Tarray(t, s), _)), lambda) -> | (Sil.Hpointsto (e, Sil.Earray(e', l, _), Sil.Sizeof(Sil.Tarray(t, _), _)), lambda) ->
incr dotty_state_count; (* increment once more n+1 is the box for the array *) incr dotty_state_count; (* increment once more n+1 is the box for the array *)
let e_color_str = color_to_str (exp_color e) in let e_color_str = color_to_str (exp_color e) in
let e_color_str'= color_to_str (exp_color e') in let e_color_str'= color_to_str (exp_color e') in
@ -307,11 +307,11 @@ let rec dotty_mk_node pe sigma =
let e_color_str = color_to_str (exp_color e) in let e_color_str = color_to_str (exp_color e) in
if IList.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)] [Dotpointsto((mk_coordinate n lambda), e, e_color_str)]
| (Sil.Hlseg (k, hpara, e1, e2, elist), lambda) -> | (Sil.Hlseg (k, hpara, e1, e2, _), lambda) ->
incr dotty_state_count; (* increment once more n+1 is the box for last element of the list *) incr dotty_state_count; (* increment once more n+1 is the box for last element of the list *)
let eq_color_str = color_to_str (exp_color e1) in let eq_color_str = color_to_str (exp_color e1) in
[Dotlseg((mk_coordinate n lambda), e1, e2, k, hpara.Sil.body, eq_color_str)] [Dotlseg((mk_coordinate n lambda), e1, e2, k, hpara.Sil.body, eq_color_str)]
| (Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, elist), lambda) -> | (Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda) ->
let e1_color_str = color_to_str (exp_color e1) in let e1_color_str = color_to_str (exp_color e1) in
incr dotty_state_count; (* increment once more n+1 is the box for e4 *) incr dotty_state_count; (* increment once more n+1 is the box for e4 *)
[Dotdllseg((mk_coordinate n lambda), e1, e2, e3, e4, k, hpara_dll.Sil.body_dll, e1_color_str)] in [Dotdllseg((mk_coordinate n lambda), e1, e2, e3, e4, k, hpara_dll.Sil.body_dll, e1_color_str)] in
@ -349,7 +349,7 @@ let compute_fields_struct sigma =
fields_structs:=[]; fields_structs:=[];
let rec do_strexp se in_struct = let rec do_strexp se in_struct =
match se with match se with
| Sil.Eexp (e, inst) -> if in_struct then fields_structs:= e ::!fields_structs else () | Sil.Eexp (e, _) -> if in_struct then fields_structs:= e ::!fields_structs else ()
| Sil.Estruct (l, _) -> IList.iter (fun e -> do_strexp e true) (snd (IList.split l)) | 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 | Sil.Earray (_, l, _) -> IList.iter (fun e -> do_strexp e false) (snd (IList.split l)) in
let rec fs s = let rec fs s =
@ -384,7 +384,7 @@ let in_cycle cycle edge =
let node_in_cycle cycle node = let node_in_cycle cycle node =
match cycle, node with match cycle, node with
| Some cycle', Dotstruct(coo, e1, l, c,te) -> (* only struct nodes can be in cycle *) | Some _, Dotstruct(_, _, l, _,_) -> (* only struct nodes can be in cycle *)
IList.exists (in_cycle cycle) l IList.exists (in_cycle cycle) l
| _ -> false | _ -> false
@ -393,7 +393,7 @@ let node_in_cycle cycle node =
let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle =
let find_target_one_fld (fn, se) = let find_target_one_fld (fn, se) =
match se with match se with
| Sil.Eexp (e, inst) -> | Sil.Eexp (e, _) ->
if is_nil e p then begin if is_nil e p then begin
let n'= make_nil_node lambda in let n'= make_nil_node lambda in
if !print_full_prop then if !print_full_prop then
@ -419,7 +419,7 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle =
[(LinkStructToExp, Ident.fieldname_to_string fn, n,"")] [(LinkStructToExp, Ident.fieldname_to_string fn, n,"")]
| _ -> (* by construction there must be at most 2 nodes for an expression*) | _ -> (* by construction there must be at most 2 nodes for an expression*)
L.out "@\n Too many nodes! Error! @\n@.@."; assert false) L.out "@\n Too many nodes! Error! @\n@.@."; assert false)
| Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *) | Sil.Estruct (_, _) -> [] (* inner struct are printed by print_struc function *)
| Sil.Earray _ -> [] in (* inner arrays are printed by print_array function *) | Sil.Earray _ -> [] in (* inner arrays are printed by print_array function *)
match list_fld with match list_fld with
| [] -> [] | [] -> []
@ -431,7 +431,7 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle =
let rec compute_target_array_elements dotnodes list_elements p f lambda = let rec compute_target_array_elements dotnodes list_elements p f lambda =
let find_target_one_element (idx, se) = let find_target_one_element (idx, se) =
match se with match se with
| Sil.Eexp (e, inst) -> | Sil.Eexp (e, _) ->
if is_nil e p then begin if is_nil e p then begin
let n'= make_nil_node lambda in let n'= make_nil_node lambda in
[(LinkArrayToExp, Sil.exp_to_string idx, n',"")] [(LinkArrayToExp, Sil.exp_to_string idx, n',"")]
@ -453,7 +453,7 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda =
| _ -> (* by construction there must be at most 2 nodes for an expression*) | _ -> (* by construction there must be at most 2 nodes for an expression*)
L.out "@\n Too many nodes! Error! @\n@.@."; assert false L.out "@\n Too many nodes! Error! @\n@.@."; assert false
) )
| Sil.Estruct (l, _) -> [] (* inner struct are printed by print_struc function *) | Sil.Estruct (_, _) -> [] (* inner struct are printed by print_struc function *)
| Sil.Earray _ ->[] (* inner arrays are printed by print_array function *) | Sil.Earray _ ->[] (* inner arrays are printed by print_array function *)
in in
match list_elements with match list_elements with
@ -462,7 +462,7 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda =
let targets_a = find_target_one_element a in let targets_a = find_target_one_element a in
targets_a @ compute_target_array_elements dotnodes list_ele' p f lambda targets_a @ compute_target_array_elements dotnodes list_ele' p f lambda
let compute_target_from_eexp dotnodes e p f lambda = let compute_target_from_eexp dotnodes e p lambda =
if is_nil e p then if is_nil e p then
let n'= make_nil_node lambda in let n'= make_nil_node lambda in
[(LinkExpToExp, n', "")] [(LinkExpToExp, n', "")]
@ -498,7 +498,7 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
| [] -> [] | [] -> []
| (Sil.Hpointsto (e, Sil.Earray(_, lie, _), _), lambda):: sigma' -> | (Sil.Hpointsto (e, Sil.Earray(_, lie, _), _), lambda):: sigma' ->
make_links_for_arrays e lie lambda sigma' make_links_for_arrays e lie lambda sigma'
| (Sil.Hpointsto (e, Sil.Estruct (lfld, _), t), lambda):: sigma' -> | (Sil.Hpointsto (e, Sil.Estruct (lfld, _), _), lambda):: sigma' ->
let src = look_up dotnodes e lambda in let src = look_up dotnodes e lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
@ -522,12 +522,12 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
else [] in else [] in
lnk_from_address_struct @ links_from_fields @ lnk_from_address_struct @ links_from_fields @
dotty_mk_set_links dotnodes sigma' p f cycle) dotty_mk_set_links dotnodes sigma' p f cycle)
| (Sil.Hpointsto (e, Sil.Eexp (e', inst'), t), lambda):: sigma' -> | (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda):: sigma' ->
let src = look_up dotnodes e lambda in let src = look_up dotnodes e lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
| nl -> if !print_full_prop then | nl -> if !print_full_prop then
let target_list = compute_target_from_eexp dotnodes e' p f lambda in let target_list = compute_target_from_eexp dotnodes e' p lambda in
let ff n = IList.map (fun (k, m, lab_target) -> let ff n = IList.map (fun (k, m, lab_target) ->
mk_link k (mk_coordinate n lambda) "" mk_link k (mk_coordinate n lambda) ""
(mk_coordinate m lambda) (strip_special_chars lab_target) (mk_coordinate m lambda) (strip_special_chars lab_target)
@ -536,16 +536,16 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
ll @ dotty_mk_set_links dotnodes sigma' p f cycle ll @ dotty_mk_set_links dotnodes sigma' p f cycle
else dotty_mk_set_links dotnodes sigma' p f cycle) else dotty_mk_set_links dotnodes sigma' p f cycle)
| (Sil.Hlseg (_, pred, e1, e2, elist), lambda):: sigma' -> | (Sil.Hlseg (_, _, e1, e2, _), lambda):: sigma' ->
let src = look_up dotnodes e1 lambda in let src = look_up dotnodes e1 lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
| n:: _ -> | n:: _ ->
let (_, m, lab) = IList.hd (compute_target_from_eexp dotnodes e2 p f lambda) in let (_, m, lab) = IList.hd (compute_target_from_eexp dotnodes e2 p lambda) in
let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in
lnk:: dotty_mk_set_links dotnodes sigma' p f cycle lnk:: dotty_mk_set_links dotnodes sigma' p f cycle
) )
| (Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist), lambda):: sigma' -> | (Sil.Hdllseg (_, _, e1, e2, e3, _, _), lambda):: sigma' ->
let src = look_up dotnodes e1 lambda in let src = look_up dotnodes e1 lambda in
(match src with (match src with
| [] -> assert false | [] -> assert false
@ -571,7 +571,7 @@ let print_kind f kind =
current_pre:=!dotty_state_count; current_pre:=!dotty_state_count;
F.fprintf f "\n PRE%iL0 [label=\"PRE %i \", style=filled, color= yellow]\n" !dotty_state_count !spec_counter; F.fprintf f "\n PRE%iL0 [label=\"PRE %i \", style=filled, color= yellow]\n" !dotty_state_count !spec_counter;
print_stack_info:= true; print_stack_info:= true;
| Spec_postcondition pre -> | Spec_postcondition _ ->
F.fprintf f "\n POST%iL0 [label=\"POST %i \", style=filled, color= yellow]\n" !dotty_state_count !post_counter; F.fprintf f "\n POST%iL0 [label=\"POST %i \", style=filled, color= yellow]\n" !dotty_state_count !post_counter;
print_stack_info:= true; print_stack_info:= true;
| Generic_proposition -> | Generic_proposition ->
@ -693,7 +693,7 @@ let rec print_struct f pe e te l coo c =
n lambda e_no_special_char n lambda print_type (struct_to_dotty_str pe coo) l c; n lambda e_no_special_char n lambda print_type (struct_to_dotty_str pe coo) l c;
F.fprintf f "}\n" F.fprintf f "}\n"
and print_array f pe e1 e2 l ty coo c = and print_array f pe e1 e2 l coo c =
let n = coo.id in let n = coo.id in
let lambda = coo.lambda in let lambda = coo.lambda in
let e_no_special_char = strip_special_chars (Sil.exp_to_string e1) in let e_no_special_char = strip_special_chars (Sil.exp_to_string e1) in
@ -701,7 +701,7 @@ and print_array f pe e1 e2 l ty coo c =
F.fprintf f " node [shape=record]; \n struct%iL%i [label=\"{<%s%iL%i> ARRAY| SIZE: %a } | %a\" ] fontcolor=%s\n" n lambda e_no_special_char n lambda (Sil.pp_exp pe) e2 (get_contents pe coo) l c; F.fprintf f " node [shape=record]; \n struct%iL%i [label=\"{<%s%iL%i> ARRAY| SIZE: %a } | %a\" ] fontcolor=%s\n" n lambda e_no_special_char n lambda (Sil.pp_exp pe) e2 (get_contents pe coo) l c;
F.fprintf f "}\n" F.fprintf f "}\n"
and print_sll f pe nesting k e1 e2 coo = and print_sll f pe nesting k e1 coo =
let n = coo.id in let n = coo.id in
let lambda = coo.lambda in let lambda = coo.lambda in
let n' = !dotty_state_count in let n' = !dotty_state_count in
@ -721,7 +721,7 @@ and print_sll f pe nesting k e1 e2 coo =
incr lambda_counter; incr lambda_counter;
pp_dotty f (Lambda_pred(n + 1, lambda, false)) (Prop.normalize (Prop.from_sigma nesting)) None pp_dotty f (Lambda_pred(n + 1, lambda, false)) (Prop.normalize (Prop.from_sigma nesting)) None
and print_dll f pe nesting k e1 e2 e3 e4 coo = and print_dll f pe nesting k e1 e4 coo =
let n = coo.id in let n = coo.id in
let lambda = coo.lambda in let lambda = coo.lambda in
let n' = !dotty_state_count in let n' = !dotty_state_count in
@ -760,15 +760,15 @@ and dotty_pp_state f pe cycle dotnode =
let l' = if !print_full_prop then l let l' = if !print_full_prop then l
else IList.filter (fun edge -> in_cycle cycle edge) l in else IList.filter (fun edge -> in_cycle cycle edge) l in
print_struct f pe e1 te l' coo c print_struct f pe e1 te l' coo c
| Dotarray(coo, e1, e2, l, ty, c) when !print_full_prop -> print_array f pe e1 e2 l ty coo c | Dotarray(coo, e1, e2, l, _, c) when !print_full_prop -> print_array f pe e1 e2 l coo c
| Dotlseg(coo, e1, e2, Sil.Lseg_NE, nesting, c) when !print_full_prop -> | Dotlseg(coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_NE e1 e2 coo print_sll f pe nesting Sil.Lseg_NE e1 coo
| Dotlseg(coo, e1, e2, Sil.Lseg_PE, nesting, c) when !print_full_prop -> | Dotlseg(coo, e1, _, Sil.Lseg_PE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_PE e1 e2 coo print_sll f pe nesting Sil.Lseg_PE e1 coo
| Dotdllseg(coo, e1, e2, e3, e4, Sil.Lseg_NE, nesting, c) when !print_full_prop -> | Dotdllseg(coo, e1, _, _, e4, Sil.Lseg_NE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_NE e1 e2 e3 e4 coo print_dll f pe nesting Sil.Lseg_NE e1 e4 coo
| Dotdllseg(coo, e1, e2, e3, e4, Sil.Lseg_PE, nesting, c) when !print_full_prop -> | Dotdllseg(coo, e1, _, _, e4, Sil.Lseg_PE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_PE e1 e2 e3 e4 coo print_dll f pe nesting Sil.Lseg_PE e1 e4 coo
| _ -> () | _ -> ()
(* Build the graph data structure to be printed *) (* Build the graph data structure to be printed *)
@ -856,7 +856,7 @@ let pp_dotty_one_spec f pre posts =
invisible_arrows:= true; invisible_arrows:= true;
pp_dotty f (Spec_precondition) pre None; pp_dotty f (Spec_precondition) pre None;
invisible_arrows:= false; invisible_arrows:= false;
IList.iter (fun (po, path) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po None; IList.iter (fun (po, _) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po None;
for j = 1 to 4 do 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; F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre;
done done
@ -949,7 +949,8 @@ let pp_cfgnodelabel fmt (n : Cfg.Node.t) =
Format.fprintf fmt "Exit %s" (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) Format.fprintf fmt "Exit %s" (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc))
| Cfg.Node.Join_node -> | Cfg.Node.Join_node ->
Format.fprintf fmt "+" Format.fprintf fmt "+"
| Cfg.Node.Prune_node (is_true_branch, ik, s) -> Format.fprintf fmt "Prune (%b branch)" is_true_branch | Cfg.Node.Prune_node (is_true_branch, _, _) ->
Format.fprintf fmt "Prune (%b branch)" is_true_branch
| Cfg.Node.Stmt_node s -> Format.fprintf fmt " %s" s | Cfg.Node.Stmt_node s -> Format.fprintf fmt " %s" s
| Cfg.Node.Skip_node s -> Format.fprintf fmt "Skip %s" s in | Cfg.Node.Skip_node s -> Format.fprintf fmt "Skip %s" s in
let instr_string i = let instr_string i =
@ -1116,10 +1117,10 @@ let rec make_visual_heap_nodes sigma =
| [] -> [] | [] -> []
| Sil.Hpointsto (e, se, t):: sigma' -> | Sil.Hpointsto (e, se, t):: sigma' ->
VH_pointsto(n, e, se, t):: make_visual_heap_nodes sigma' VH_pointsto(n, e, se, t):: make_visual_heap_nodes sigma'
| Sil.Hlseg (k, hpara, e1, e2, elist):: sigma' -> | Sil.Hlseg (k, hpara, e1, e2, _):: sigma' ->
working_list:= (n, hpara.Sil.body)::!working_list; working_list:= (n, hpara.Sil.body)::!working_list;
VH_lseg(n, e1, e2, k):: make_visual_heap_nodes sigma' VH_lseg(n, e1, e2, k):: make_visual_heap_nodes sigma'
| Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, elist):: sigma'-> | Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _):: sigma'->
working_list:= (n, hpara_dll.Sil.body_dll)::!working_list; working_list:= (n, hpara_dll.Sil.body_dll)::!working_list;
VH_dllseg(n, e1, e2, e3, e4, k):: make_visual_heap_nodes sigma' VH_dllseg(n, e1, e2, e3, e4, k):: make_visual_heap_nodes sigma'
@ -1158,9 +1159,9 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
VH_dangling(n, e) in VH_dangling(n, e) in
let get_rhs_predicate hpred = let get_rhs_predicate hpred =
(match hpred with (match hpred with
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) -> [e] | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when not (Sil.exp_equal e Sil.exp_zero) -> [e]
| Sil.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> [e2] | Sil.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> [e2]
| Sil.Hdllseg (_, _, e1, e2, e3, _, _) -> | Sil.Hdllseg (_, _, _, e2, e3, _, _) ->
if (Sil.exp_equal e2 Sil.exp_zero) then if (Sil.exp_equal e2 Sil.exp_zero) then
if (Sil.exp_equal e3 Sil.exp_zero) then [] if (Sil.exp_equal e3 Sil.exp_zero) then []
else [e3] else [e3]
@ -1191,8 +1192,10 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
(* field_lab is the name of the field which points to n (if any)*) (* field_lab is the name of the field which points to n (if any)*)
let rec compute_target_nodes_from_sexp nodes se prop field_lab = let rec compute_target_nodes_from_sexp nodes se prop field_lab =
match se with match se with
| Sil.Eexp (e, inst) when is_nil e prop -> [] (* Nil is not represented by a node, it's just a value which should be printed*) | Sil.Eexp (e, _) when is_nil e prop ->
| Sil.Eexp (e, inst) -> (* Nil is not represented by a node, it's just a value which should be printed*)
[]
| Sil.Eexp (e, _) ->
let e_node = select_node_at_address nodes e in let e_node = select_node_at_address nodes e in
(match e_node with (match e_node with
| None -> | None ->
@ -1225,7 +1228,7 @@ let rec make_visual_heap_edges nodes sigma prop =
mk_visual_heap_edge (get_node_id n) (get_node_id m) lab in mk_visual_heap_edge (get_node_id n) (get_node_id m) lab in
match sigma with match sigma with
| [] -> [] | [] -> []
| Sil.Hpointsto (e, se, t):: sigma' -> | Sil.Hpointsto (e, se, _):: sigma' ->
let e_node = select_node_at_address nodes e in let e_node = select_node_at_address nodes e in
(match e_node with (match e_node with
| None -> assert false | None -> assert false
@ -1234,7 +1237,7 @@ let rec make_visual_heap_edges nodes sigma prop =
let ll = IList.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 ll @ make_visual_heap_edges nodes sigma' prop
) )
| Sil.Hlseg (_, pred, e1, e2, elist):: sigma' -> | Sil.Hlseg (_, _, e1, e2, _):: sigma' ->
let e1_node = select_node_at_address nodes e1 in let e1_node = select_node_at_address nodes e1 in
(match e1_node with (match e1_node with
| None -> assert false | None -> assert false
@ -1244,7 +1247,7 @@ let rec make_visual_heap_edges nodes sigma prop =
ll @ make_visual_heap_edges nodes sigma' prop ll @ make_visual_heap_edges nodes sigma' prop
) )
| Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist):: sigma' -> | Sil.Hdllseg (_, _, e1, e2, e3, _, _):: sigma' ->
let e1_node = select_node_at_address nodes e1 in let e1_node = select_node_at_address nodes e1 in
(match e1_node with (match e1_node with
| None -> assert false | None -> assert false
@ -1274,7 +1277,7 @@ let prop_to_set_of_visual_heaps prop =
let rec pointsto_contents_to_xml (co: Sil.strexp) : Io_infer.Xml.node = let rec pointsto_contents_to_xml (co: Sil.strexp) : Io_infer.Xml.node =
match co with match co with
| Sil.Eexp (e, inst) -> | Sil.Eexp (e, _) ->
Io_infer.Xml.create_tree "cell" [("content-value", exp_to_xml_string e)] [] Io_infer.Xml.create_tree "cell" [("content-value", exp_to_xml_string e)] []
| Sil.Estruct (fel, _) -> | 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 let f (fld, exp) = Io_infer.Xml.create_tree "struct-field" [("id", Ident.fieldname_to_string fld)] [(pointsto_contents_to_xml exp)] in
@ -1317,17 +1320,17 @@ let heap_node_to_xml node =
| VH_dangling(id, addr) -> | VH_dangling(id, addr) ->
let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","dangling"); ("memory-type", pointsto_addr_kind addr)] in let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","dangling"); ("memory-type", pointsto_addr_kind addr)] in
Io_infer.Xml.create_tree "node" atts [] Io_infer.Xml.create_tree "node" atts []
| VH_pointsto(id, addr, cont, t) -> | VH_pointsto(id, addr, cont, _) ->
let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","allocated"); ("memory-type", pointsto_addr_kind addr)] in let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","allocated"); ("memory-type", pointsto_addr_kind addr)] in
let contents = pointsto_contents_to_xml cont in let contents = pointsto_contents_to_xml cont in
Io_infer.Xml.create_tree "node" atts [contents] Io_infer.Xml.create_tree "node" atts [contents]
| VH_lseg(id, addr, cont, Sil.Lseg_NE) -> | VH_lseg(id, addr, _, Sil.Lseg_NE) ->
let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","single linked list"); ("list-type","non-empty"); ("memory-type", "other")] in let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","single linked list"); ("list-type","non-empty"); ("memory-type", "other")] in
Io_infer.Xml.create_tree "node" atts [] Io_infer.Xml.create_tree "node" atts []
| VH_lseg(id, addr, cont, Sil.Lseg_PE) -> | VH_lseg(id, addr, _, Sil.Lseg_PE) ->
let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","single linked list"); ("list-type","possibly empty"); ("memory-type", "other")] in let atts =[("id", string_of_int id); ("address", exp_to_xml_string addr); ("node-type","single linked list"); ("list-type","possibly empty"); ("memory-type", "other")] in
Io_infer.Xml.create_tree "node" atts [] Io_infer.Xml.create_tree "node" atts []
| VH_dllseg(id, addr1, cont1, cont2, addr2, k) -> | VH_dllseg(id, addr1, cont1, cont2, addr2, _) ->
let contents1 = pointsto_contents_to_xml (Sil.Eexp (cont1, Sil.inst_none)) in let contents1 = pointsto_contents_to_xml (Sil.Eexp (cont1, Sil.inst_none)) in
let contents2 = pointsto_contents_to_xml (Sil.Eexp (cont2, Sil.inst_none)) in let contents2 = pointsto_contents_to_xml (Sil.Eexp (cont2, Sil.inst_none)) in
let atts =[("id", string_of_int id); ("addr-first", exp_to_xml_string addr1); ("addr-last", exp_to_xml_string addr2); ("node-type","double linked list"); ("memory-type", "other") ] in let atts =[("id", string_of_int id); ("addr-first", exp_to_xml_string addr1); ("addr-last", exp_to_xml_string addr2); ("node-type","double linked list"); ("memory-type", "other") ] in
@ -1359,12 +1362,17 @@ let print_specs_xml signature specs loc fmt =
reset_node_counter (); reset_node_counter ();
let do_one_spec pre posts n = let do_one_spec pre posts n =
let add_stack_to_prop _prop = let add_stack_to_prop _prop =
let pre_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma pre)) in (* add stack vars from pre *) (* add stack vars from pre *)
let pre_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma pre)) in
let _prop' = Prop.replace_sigma (pre_stack @ Prop.get_sigma _prop) _prop in let _prop' = Prop.replace_sigma (pre_stack @ Prop.get_sigma _prop) _prop in
Prop.normalize _prop' in Prop.normalize _prop' in
let jj = ref 0 in let jj = ref 0 in
let xml_pre = prop_to_xml pre "precondition" !jj in let xml_pre = prop_to_xml pre "precondition" !jj 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 let xml_spec =
xml_pre ::
(IList.map (fun (po, _) ->
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 Io_infer.Xml.create_tree "specification" [("id", string_of_int n)] xml_spec in
let j = ref 0 in let j = ref 0 in
let list_of_specs_xml = let list_of_specs_xml =

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

@ -46,7 +46,7 @@ let find_variable_assigment node id : Sil.instr option =
let res = ref None in let res = ref None in
let node_instrs = Cfg.Node.get_instrs node in let node_instrs = Cfg.Node.get_instrs node in
let find_set instr = match instr with let find_set instr = match instr with
| Sil.Set (Sil.Lvar pv, _, e, _) when Sil.exp_equal (Sil.Var id) e -> | Sil.Set (Sil.Lvar _, _, e, _) when Sil.exp_equal (Sil.Var id) e ->
res := Some instr; res := Some instr;
true true
| _ -> false in | _ -> false in
@ -275,7 +275,7 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
end end
end end
else Some (Sil.Dpvar pvar) else Some (Sil.Dpvar pvar)
| Sil.Lfield (Sil.Var id, f, typ) when Ident.is_normal id -> | Sil.Lfield (Sil.Var id, f, _) when Ident.is_normal id ->
if !verbose then if !verbose then
begin begin
L.d_str "exp_lv_dexp: Lfield with var "; L.d_str "exp_lv_dexp: Lfield with var ";
@ -286,7 +286,7 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
(match _find_normal_variable_letderef seen node id with (match _find_normal_variable_letderef seen node id with
| None -> None | None -> None
| Some de -> Some (Sil.Darrow (de, f))) | Some de -> Some (Sil.Darrow (de, f)))
| Sil.Lfield (e1, f, typ) -> | Sil.Lfield (e1, f, _) ->
if !verbose then if !verbose then
begin begin
L.d_str "exp_lv_dexp: Lfield "; L.d_str "exp_lv_dexp: Lfield ";
@ -334,7 +334,7 @@ and _exp_rv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
| Sil.Var id when Ident.is_normal id -> | Sil.Var id when Ident.is_normal id ->
if !verbose then (L.d_str "exp_rv_dexp: normal var "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "exp_rv_dexp: normal var "; Sil.d_exp e; L.d_ln ());
_find_normal_variable_letderef seen node id _find_normal_variable_letderef seen node id
| Sil.Lfield (e1, f, typ) -> | Sil.Lfield (e1, f, _) ->
if !verbose then if !verbose then
begin begin
L.d_str "exp_rv_dexp: Lfield "; L.d_str "exp_rv_dexp: Lfield ";
@ -412,9 +412,9 @@ let leak_from_list_abstraction hpred prop =
let check_hpred texp hp = match hpred_type hp with let check_hpred texp hp = match hpred_type hp with
| Some texp' when Sil.exp_equal texp texp' -> found := true | Some texp' when Sil.exp_equal texp texp' -> found := true
| _ -> () in | _ -> () in
let check_hpara texp n hpara = let check_hpara texp _ hpara =
IList.iter (check_hpred texp) hpara.Sil.body in IList.iter (check_hpred texp) hpara.Sil.body in
let check_hpara_dll texp n hpara = let check_hpara_dll texp _ hpara =
IList.iter (check_hpred texp) hpara.Sil.body_dll in IList.iter (check_hpred texp) hpara.Sil.body_dll in
match hpred_type hpred with match hpred_type hpred with
| Some texp -> | Some texp ->
@ -430,7 +430,7 @@ let find_hpred_typ hpred = match hpred with
| _ -> None | _ -> None
(** find the type of pvar and remove the pointer, if any *) (** find the type of pvar and remove the pointer, if any *)
let find_pvar_typ_without_ptr tenv prop pvar = let find_pvar_typ_without_ptr prop pvar =
let res = ref None in let res = ref None in
let do_hpred = function let do_hpred = function
| Sil.Hpointsto (e, _, te) when Sil.exp_equal e (Sil.Lvar pvar) -> | Sil.Hpointsto (e, _, te) when Sil.exp_equal e (Sil.Lvar pvar) ->
@ -470,8 +470,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
let check_pvar pvar = (* check that pvar is local or global and has the same type as the leaked hpred *) let check_pvar pvar = (* check that pvar is local or global and has the same type as the leaked hpred *)
(Sil.pvar_is_local pvar || Sil.pvar_is_global pvar) && (Sil.pvar_is_local pvar || Sil.pvar_is_global pvar) &&
not (pvar_is_frontend_tmp pvar) && not (pvar_is_frontend_tmp pvar) &&
match hpred_typ_opt, find_pvar_typ_without_ptr tenv prop pvar with match hpred_typ_opt, find_pvar_typ_without_ptr prop pvar with
| Some (Sil.Sizeof (t1, st1)), Some (Sil.Sizeof (Sil.Tptr (_t2, _), st2)) -> | Some (Sil.Sizeof (t1, _)), Some (Sil.Sizeof (Sil.Tptr (_t2, _), _)) ->
(try (try
let t2 = Sil.expand_type tenv _t2 in let t2 = Sil.expand_type tenv _t2 in
Sil.typ_equal t1 t2 Sil.typ_equal t1 t2
@ -483,7 +483,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
| None -> | None ->
if !verbose then (L.d_str "explain_leak: no current instruction"; L.d_ln ()); if !verbose then (L.d_str "explain_leak: no current instruction"; L.d_ln ());
value_str_from_pvars_vpath [] vpath value_str_from_pvars_vpath [] vpath
| Some (Sil.Nullify (pvar, loc, _)) when check_pvar pvar -> | Some (Sil.Nullify (pvar, _, _)) when check_pvar pvar ->
if !verbose then (L.d_str "explain_leak: current instruction is Nullify for pvar "; Sil.d_pvar pvar; L.d_ln ()); if !verbose then (L.d_str "explain_leak: current instruction is Nullify for pvar "; Sil.d_pvar pvar; L.d_ln ());
(match exp_lv_dexp (State.get_node ()) (Sil.Lvar pvar) with (match exp_lv_dexp (State.get_node ()) (Sil.Lvar pvar) with
| None -> None | None -> None
@ -564,7 +564,7 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
let res = ref (None, None) in let res = ref (None, None) in
IList.iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel; IList.iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel;
!res !res
| sexp -> | _ ->
None, None in None, None in
let do_hpred sigma_acc' sigma_todo' = let do_hpred sigma_acc' sigma_todo' =
let substituted_from_normal id = let substituted_from_normal id =
@ -577,7 +577,7 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
do_sexp sigma_acc' sigma_todo' (Sil.Lvar pv) sexp texp do_sexp sigma_acc' sigma_todo' (Sil.Lvar pv) sexp texp
| Sil.Hpointsto (Sil.Var id, sexp, texp) when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) -> | Sil.Hpointsto (Sil.Var id, sexp, texp) when Ident.is_normal id || (Ident.is_footprint id && substituted_from_normal id) ->
do_sexp sigma_acc' sigma_todo' (Sil.Var id) sexp texp do_sexp sigma_acc' sigma_todo' (Sil.Var id) sexp texp
| hpred -> | _ ->
(* if !verbose then (L.d_str "vpath_find do_hpred: no match "; Sil.d_hpred hpred; L.d_ln ()); *) (* if !verbose then (L.d_str "vpath_find do_hpred: no match "; Sil.d_hpred hpred; L.d_ln ()); *)
None, None in None, None in
match sigma_todo with match sigma_todo with
@ -664,13 +664,13 @@ let explain_dexp_access prop dexp is_nullable =
| None -> None | None -> None
| Some (Sil.Eexp (e, _)) -> find_ptsto e | Some (Sil.Eexp (e, _)) -> find_ptsto e
| Some _ -> None) | Some _ -> None)
| (Sil.Dbinop(Sil.PlusPI, Sil.Dpvar pvar, Sil.Dconst c) as de) -> | (Sil.Dbinop(Sil.PlusPI, Sil.Dpvar _, Sil.Dconst _) as de) ->
if !verbose then (L.d_strln ("lookup: case )pvar + constant) " ^ Sil.dexp_to_string de)); if !verbose then (L.d_strln ("lookup: case )pvar + constant) " ^ Sil.dexp_to_string de));
None None
| Sil.Dfcall (Sil.Dconst c, _, loc, _) -> | Sil.Dfcall (Sil.Dconst c, _, loc, _) ->
if !verbose then (L.d_strln "lookup: found Dfcall "); if !verbose then (L.d_strln "lookup: found Dfcall ");
(match c with (match c with
| Sil.Cfun pn -> (* Treat function as an update *) | Sil.Cfun _ -> (* Treat function as an update *)
Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Location.line)) Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Location.line))
| _ -> None) | _ -> None)
| de -> | de ->
@ -680,9 +680,9 @@ let explain_dexp_access prop dexp is_nullable =
| None -> | None ->
if !verbose then (L.d_strln ("explain_dexp_access: cannot find inst of " ^ Sil.dexp_to_string dexp)); if !verbose then (L.d_strln ("explain_dexp_access: cannot find inst of " ^ Sil.dexp_to_string dexp));
None None
| Some (Sil.Iupdate (_, ncf, n, pos)) -> | Some (Sil.Iupdate (_, ncf, n, _)) ->
Some (Localise.Last_assigned (n, ncf)) Some (Localise.Last_assigned (n, ncf))
| Some (Sil.Irearrange (_, _, n, pos)) -> | Some (Sil.Irearrange (_, _, n, _)) ->
Some (Localise.Last_accessed (n, is_nullable)) Some (Localise.Last_accessed (n, is_nullable))
| Some (Sil.Ireturn_from_call n) -> | Some (Sil.Ireturn_from_call n) ->
Some (Localise.Returned_from_call n) Some (Localise.Returned_from_call n)
@ -696,11 +696,11 @@ let explain_dexp_access prop dexp is_nullable =
let explain_dereference_access outermost_array is_nullable _de_opt prop = let explain_dereference_access outermost_array is_nullable _de_opt prop =
let de_opt = let de_opt =
let rec remove_outermost_array_access = function (* remove outermost array access from [de] *) let rec remove_outermost_array_access = function (* remove outermost array access from [de] *)
| Sil.Dbinop(Sil.PlusPI, de1, de2) -> (* remove pointer arithmetic before array access *) | Sil.Dbinop(Sil.PlusPI, de1, _) -> (* remove pointer arithmetic before array access *)
remove_outermost_array_access de1 remove_outermost_array_access de1
| Sil.Darray(Sil.Dderef de1, de2) -> (* array access is a deref already: remove both *) | Sil.Darray(Sil.Dderef de1, _) -> (* array access is a deref already: remove both *)
de1 de1
| Sil.Darray(de1, de2) -> (* remove array access *) | Sil.Darray(de1, _) -> (* remove array access *)
de1 de1
| Sil.Dderef de -> (* remove implicit array access *) | Sil.Dderef de -> (* remove implicit array access *)
de de
@ -758,16 +758,16 @@ let _explain_access
?(is_premature_nil = false) ?(is_premature_nil = false)
deref_str prop loc = deref_str prop loc =
let rec find_outermost_dereference node e = match e with let rec find_outermost_dereference node e = match e with
| Sil.Const c -> | Sil.Const _ ->
if !verbose then (L.d_str "find_outermost_dereference: constant "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "find_outermost_dereference: constant "; Sil.d_exp e; L.d_ln ());
exp_lv_dexp node e exp_lv_dexp node e
| Sil.Var id when Ident.is_normal id -> (* look up the normal variable declaration *) | Sil.Var id when Ident.is_normal id -> (* look up the normal variable declaration *)
if !verbose then (L.d_str "find_outermost_dereference: normal var "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "find_outermost_dereference: normal var "; Sil.d_exp e; L.d_ln ());
find_normal_variable_letderef node id find_normal_variable_letderef node id
| Sil.Lfield (e', f, t) -> | Sil.Lfield (e', _, _) ->
if !verbose then (L.d_str "find_outermost_dereference: Lfield "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "find_outermost_dereference: Lfield "; Sil.d_exp e; L.d_ln ());
find_outermost_dereference node e' find_outermost_dereference node e'
| Sil.Lindex(e', e2) -> | Sil.Lindex(e', _) ->
if !verbose then (L.d_str "find_outermost_dereference: Lindex "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "find_outermost_dereference: Lindex "; Sil.d_exp e; L.d_ln ());
find_outermost_dereference node e' find_outermost_dereference node e'
| Sil.Lvar _ -> | Sil.Lvar _ ->
@ -785,22 +785,23 @@ let _explain_access
| _ -> | _ ->
if !verbose then (L.d_str "find_outermost_dereference: no match for "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "find_outermost_dereference: no match for "; Sil.d_exp e; L.d_ln ());
None in None in
let find_exp_dereferenced node = match State.get_instr () with let find_exp_dereferenced () = match State.get_instr () with
| Some Sil.Set (e, _, _, _) -> | Some Sil.Set (e, _, _, _) ->
if !verbose then (L.d_str "explain_dereference Sil.Set "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "explain_dereference Sil.Set "; Sil.d_exp e; L.d_ln ());
Some e Some e
| Some Sil.Letderef (_, e, _, _) -> | Some Sil.Letderef (_, e, _, _) ->
if !verbose then (L.d_str "explain_dereference Sil.Leteref "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "explain_dereference Sil.Leteref "; Sil.d_exp e; L.d_ln ());
Some e Some e
| Some Sil.Call (_, Sil.Const (Sil.Cfun fn), [(e, typ)], loc, _) when Procname.to_string fn = "free" -> | Some Sil.Call (_, Sil.Const (Sil.Cfun fn), [(e, _)], _, _)
when Procname.to_string fn = "free" ->
if !verbose then (L.d_str "explain_dereference Sil.Call "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "explain_dereference Sil.Call "; Sil.d_exp e; L.d_ln ());
Some e Some e
| Some Sil.Call (_, (Sil.Var id as e), _, loc, _) -> | Some Sil.Call (_, (Sil.Var _ as e), _, _, _) ->
if !verbose then (L.d_str "explain_dereference Sil.Call "; Sil.d_exp e; L.d_ln ()); if !verbose then (L.d_str "explain_dereference Sil.Call "; Sil.d_exp e; L.d_ln ());
Some e Some e
| _ -> None in | _ -> None in
let node = State.get_node () in let node = State.get_node () in
match find_exp_dereferenced node with match find_exp_dereferenced () with
| None -> | None ->
if !verbose then L.d_strln "_explain_access: find_exp_dereferenced returned None"; if !verbose then L.d_strln "_explain_access: find_exp_dereferenced returned None";
Localise.no_desc Localise.no_desc

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

@ -27,8 +27,8 @@ type err_data =
Prop.normal Prop.t option * Exceptions.err_class Prop.normal Prop.t option * Exceptions.err_class
let err_data_compare let err_data_compare
((nodeid1, key1), session1, loc1, ml_loc_opt1, ltr1, po1, ec1) (_, _, loc1, _, _, _, _)
((nodeid2, key2), session2, loc2, ml_loc_opt2, ltr2, po2, ec2) = (_, _, loc2, _, _, _, _) =
Location.compare loc1 loc2 Location.compare loc1 loc2
module ErrDataSet = (* set err_data with no repeated loc *) module ErrDataSet = (* set err_data with no repeated loc *)
@ -42,12 +42,12 @@ module ErrLogHash = Hashtbl.Make (struct
type t = Exceptions.err_kind * bool * Localise.t * Localise.error_desc * string type t = Exceptions.err_kind * bool * Localise.t * Localise.error_desc * string
let hash (ekind, in_footprint, err_name, desc, severity) = let hash (ekind, in_footprint, err_name, desc, _) =
Hashtbl.hash (ekind, in_footprint, err_name, Localise.error_desc_hash desc) Hashtbl.hash (ekind, in_footprint, err_name, Localise.error_desc_hash desc)
let equal let equal
(ekind1, in_footprint1, err_name1, desc1, severity1) (ekind1, in_footprint1, err_name1, desc1, _)
(ekind2, in_footprint2, err_name2, desc2, severity2) = (ekind2, in_footprint2, err_name2, desc2, _) =
(ekind1, in_footprint1, err_name1) = (ekind2, in_footprint2, err_name2) && (ekind1, in_footprint1, err_name1) = (ekind2, in_footprint2, err_name2) &&
Localise.error_desc_equal desc1 desc2 Localise.error_desc_equal desc1 desc2
@ -78,7 +78,7 @@ type iter_fun =
let iter (f: iter_fun) (err_log: t) = let iter (f: iter_fun) (err_log: t) =
ErrLogHash.iter (fun (ekind, in_footprint, err_name, desc, severity) set -> ErrLogHash.iter (fun (ekind, in_footprint, err_name, desc, severity) set ->
ErrDataSet.iter ErrDataSet.iter
(fun (node_id_key, section, loc, ml_loc_opt, ltr, pre_opt, eclass) -> (fun (node_id_key, _, loc, ml_loc_opt, ltr, pre_opt, eclass) ->
f f
node_id_key loc ml_loc_opt ekind in_footprint err_name node_id_key loc ml_loc_opt ekind in_footprint err_name
desc severity ltr pre_opt eclass) desc severity ltr pre_opt eclass)
@ -94,14 +94,14 @@ let size filter (err_log: t) =
(** Print errors from error log *) (** Print errors from error log *)
let pp_errors fmt (errlog : t) = let pp_errors fmt (errlog : t) =
let f (ekind, _, ename, _, _) locs = let f (ekind, _, ename, _, _) _ =
if ekind == Exceptions.Kerror then if ekind == Exceptions.Kerror then
F.fprintf fmt "%a@ " Localise.pp ename in F.fprintf fmt "%a@ " Localise.pp ename in
ErrLogHash.iter f errlog ErrLogHash.iter f errlog
(** Print warnings from error log *) (** Print warnings from error log *)
let pp_warnings fmt (errlog : t) = let pp_warnings fmt (errlog : t) =
let f (ekind, _, ename, desc, _) locs = let f (ekind, _, ename, desc, _) _ =
if ekind == Exceptions.Kwarning then if ekind == Exceptions.Kwarning then
F.fprintf fmt "%a %a@ " Localise.pp ename Localise.pp_error_desc desc in F.fprintf fmt "%a %a@ " Localise.pp ename Localise.pp_error_desc desc in
ErrLogHash.iter f errlog ErrLogHash.iter f errlog
@ -110,10 +110,10 @@ let pp_warnings fmt (errlog : t) =
let pp_html path_to_root fmt (errlog: t) = let pp_html path_to_root fmt (errlog: t) =
let pp_eds fmt eds = let pp_eds fmt eds =
let pp_nodeid_session_loc let pp_nodeid_session_loc
fmt ((nodeid, nodekey), session, loc, ml_loc_opt, ltr, pre_opt, eclass) = fmt ((nodeid, _), session, loc, _, _, _, _) =
Io_infer.Html.pp_session_link path_to_root fmt (nodeid, session, loc.Location.line) in Io_infer.Html.pp_session_link path_to_root fmt (nodeid, session, loc.Location.line) in
ErrDataSet.iter (pp_nodeid_session_loc fmt) eds in ErrDataSet.iter (pp_nodeid_session_loc fmt) eds in
let f do_fp ek (ekind, infp, err_name, desc, severity) eds = let f do_fp ek (ekind, infp, err_name, desc, _) eds =
if ekind == ek && do_fp == infp if ekind == ek && do_fp == infp
then then
F.fprintf fmt "<br>%a %a %a" F.fprintf fmt "<br>%a %a %a"
@ -231,7 +231,7 @@ module Err_table = struct
let err_string = Localise.to_string err_name in let err_string = Localise.to_string err_name in
let count = try StringMap.find err_string !err_name_map with Not_found -> 0 in let count = try StringMap.find err_string !err_name_map with Not_found -> 0 in
err_name_map := StringMap.add err_string (count + n) !err_name_map in err_name_map := StringMap.add err_string (count + n) !err_name_map in
let count (ekind', in_footprint, err_name, desc, severity) eds = let count (ekind', in_footprint, err_name, _, _) eds =
if ekind = ekind' && in_footprint then count_err err_name (ErrDataSet.cardinal eds) in if ekind = ekind' && in_footprint then count_err err_name (ErrDataSet.cardinal eds) in
ErrLogHash.iter count err_table; ErrLogHash.iter count err_table;
let pp err_string count = F.fprintf fmt " %s:%d" err_string count in let pp err_string count = F.fprintf fmt " %s:%d" err_string count in
@ -249,7 +249,7 @@ module Err_table = struct
let map_warn_fp = ref LocMap.empty in let map_warn_fp = ref LocMap.empty in
let map_warn_re = ref LocMap.empty in let map_warn_re = ref LocMap.empty in
let map_info = ref LocMap.empty in let map_info = ref LocMap.empty in
let add_err nslm (ekind , in_fp, err_name, desc, severity) = let add_err nslm (ekind , in_fp, err_name, desc, _) =
let map = match in_fp, ekind with let map = match in_fp, ekind with
| true, Exceptions.Kerror -> map_err_fp | true, Exceptions.Kerror -> map_err_fp
| false, Exceptions.Kerror -> map_err_re | false, Exceptions.Kerror -> map_err_re
@ -265,7 +265,7 @@ module Err_table = struct
ErrDataSet.iter (fun loc -> add_err loc err_name) eds in ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
ErrLogHash.iter f err_table; ErrLogHash.iter f err_table;
let pp ekind (nodeidkey, session, loc, ml_loc_opt, ltr, pre_opt, eclass) fmt err_names = let pp ekind (nodeidkey, _, loc, ml_loc_opt, _, _, _) fmt err_names =
IList.iter (fun (err_name, desc) -> IList.iter (fun (err_name, desc) ->
Exceptions.pp_err nodeidkey loc ekind err_name desc ml_loc_opt fmt ()) err_names in Exceptions.pp_err nodeidkey loc ekind err_name desc ml_loc_opt fmt ()) err_names in
F.fprintf fmt "@.Detailed errors during footprint phase:@."; F.fprintf fmt "@.Detailed errors during footprint phase:@.";

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

@ -147,7 +147,7 @@ let recognize_exception exn =
desc, Some ml_loc, Exn_user, Medium, None, Nocat) desc, Some ml_loc, Exn_user, Medium, None, Nocat)
| Dangling_pointer_dereference (dko, desc, ml_loc) -> | Dangling_pointer_dereference (dko, desc, ml_loc) ->
let visibility = match dko with let visibility = match dko with
| Some dk -> Exn_user (* only show to the user if the category was identified *) | Some _ -> Exn_user (* only show to the user if the category was identified *)
| None -> Exn_developer in | None -> Exn_developer in
(Localise.dangling_pointer_dereference, (Localise.dangling_pointer_dereference,
desc, Some ml_loc, visibility, High, None, Prover) desc, Some ml_loc, visibility, High, None, Prover)
@ -192,7 +192,7 @@ let recognize_exception exn =
| Invalid_argument s -> | Invalid_argument s ->
let desc = Localise.verbatim_desc s in let desc = Localise.verbatim_desc s in
(Localise.from_string "Invalid_argument", desc, None, Exn_system, Low, None, Nocat) (Localise.from_string "Invalid_argument", desc, None, Exn_system, Low, None, Nocat)
| Java_runtime_exception (exn_name, pre_str, desc) -> | Java_runtime_exception (exn_name, _, desc) ->
let exn_str = Typename.name exn_name in let exn_str = Typename.name exn_name in
(Localise.from_string exn_str, desc, None, Exn_user, High, None, Prover) (Localise.from_string exn_str, desc, None, Exn_user, High, None, Prover)
| Leak (fp_part, _, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc) -> | Leak (fp_part, _, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc) ->
@ -231,7 +231,7 @@ let recognize_exception exn =
| Precondition_not_met (desc, ml_loc) -> | Precondition_not_met (desc, ml_loc) ->
(Localise.precondition_not_met, (Localise.precondition_not_met,
desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat) (** always a warning *) desc, Some ml_loc, Exn_user, Medium, Some Kwarning, Nocat) (** always a warning *)
| Retain_cycle (prop, hpred, desc, ml_loc) -> | Retain_cycle (_, _, desc, ml_loc) ->
(Localise.retain_cycle, (Localise.retain_cycle,
desc, Some ml_loc, Exn_user, High, None, Prover) desc, Some ml_loc, Exn_user, High, None, Prover)
| Return_expression_required (desc, ml_loc) -> | Return_expression_required (desc, ml_loc) ->
@ -320,7 +320,7 @@ let err_class_string = function
let print_key = false let print_key = false
(** pretty print an error given its (id,key), location, kind, name, description, and optional ml location *) (** pretty print an error given its (id,key), location, kind, name, description, and optional ml location *)
let pp_err (node_id, node_key) loc ekind ex_name desc ml_loc_opt fmt () = let pp_err (_, node_key) loc ekind ex_name desc ml_loc_opt fmt () =
let kind = err_kind_string (if ekind = Kinfo then Kwarning else ekind) (* eclipse does not know about infos: treat as warning *) in let kind = err_kind_string (if ekind = Kinfo then Kwarning else ekind) (* eclipse does not know about infos: treat as warning *) in
let pp_key fmt k = if print_key then F.fprintf fmt " key: %d " k else () in let pp_key fmt k = if print_key then F.fprintf fmt " key: %d " k else () in
F.fprintf fmt "%s:%d: %s: %a %a%a%a@\n" F.fprintf fmt "%s:%d: %s: %a %a%a%a@\n"

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

@ -155,7 +155,7 @@ let file_data_to_tenv file_data =
assert false assert false
| Some tenv -> tenv | Some tenv -> tenv
let file_data_to_cfg exe_env file_data = let file_data_to_cfg file_data =
match file_data.cfg with match file_data.cfg with
| None -> | None ->
let cfg = match Cfg.load_cfg_from_file file_data.cfg_file with let cfg = match Cfg.load_cfg_from_file file_data.cfg_file with
@ -175,7 +175,7 @@ let get_tenv exe_env pname =
(** return the cfg associated to the procedure *) (** return the cfg associated to the procedure *)
let get_cfg exe_env pname = let get_cfg exe_env pname =
let file_data = get_file_data exe_env pname in let file_data = get_file_data exe_env pname in
file_data_to_cfg exe_env file_data file_data_to_cfg file_data
(** [iter_files f exe_env] applies [f] to the filename and tenv and cfg for each file in [exe_env] *) (** [iter_files f exe_env] applies [f] to the filename and tenv and cfg for each file in [exe_env] *)
let iter_files f exe_env = let iter_files f exe_env =
@ -189,7 +189,7 @@ let iter_files f exe_env =
begin begin
DB.current_source := fname; DB.current_source := fname;
Config.nLOC := file_data.nLOC; Config.nLOC := file_data.nLOC;
f fname (file_data_to_tenv file_data) (file_data_to_cfg exe_env file_data); f fname (file_data_to_cfg file_data);
DB.SourceFileSet.add fname seen_files_acc DB.SourceFileSet.add fname seen_files_acc
end in end in
ignore (Procname.Hash.fold do_file exe_env.proc_map DB.SourceFileSet.empty) ignore (Procname.Hash.fold do_file exe_env.proc_map DB.SourceFileSet.empty)

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

@ -44,7 +44,7 @@ val get_tenv : t -> Procname.t -> Sil.tenv
val get_cfg : t -> Procname.t -> Cfg.cfg val get_cfg : t -> Procname.t -> Cfg.cfg
(** [iter_files f exe_env] applies [f] to the source file and tenv and cfg for each file in [exe_env] *) (** [iter_files f exe_env] applies [f] to the source file and tenv and cfg for each file in [exe_env] *)
val iter_files : (DB.source_file -> Sil.tenv -> Cfg.cfg -> unit) -> t -> unit val iter_files : (DB.source_file -> Cfg.cfg -> unit) -> t -> unit
(** check if a procedure is marked as active *) (** check if a procedure is marked as active *)
val proc_is_active : t -> Procname.t -> bool val proc_is_active : t -> Procname.t -> bool

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

@ -22,7 +22,7 @@ module WeightedPnameSet =
end) end)
let pp_weightedpnameset fmt set = let pp_weightedpnameset fmt set =
let f (pname, weight) = F.fprintf fmt "%a@ " Procname.pp pname in let f (pname, _) = F.fprintf fmt "%a@ " Procname.pp pname in
WeightedPnameSet.iter f set WeightedPnameSet.iter f set
let compute_weighed_pnameset gr = let compute_weighed_pnameset gr =
@ -210,7 +210,7 @@ let post_process_procs exe_env procs_done =
(** Find the max string in the [set] which satisfies [filter],and count the number of attempts. (** Find the max string in the [set] which satisfies [filter],and count the number of attempts.
Precedence is given to strings in [priority_set] *) Precedence is given to strings in [priority_set] *)
let filter_max exe_env cg filter set priority_set = let filter_max exe_env filter set priority_set =
let rec find_max n filter set = let rec find_max n filter set =
let elem = WeightedPnameSet.max_elt set in let elem = WeightedPnameSet.max_elt set in
if filter elem then if filter elem then
@ -322,7 +322,7 @@ end
propagates results, and handles fixpoints in the call graph. *) propagates results, and handles fixpoints in the call graph. *)
let main_algorithm exe_env analyze_proc filter_out process_result : unit = let main_algorithm exe_env analyze_proc filter_out process_result : unit =
let call_graph = Exe_env.get_cg exe_env in let call_graph = Exe_env.get_cg exe_env in
let filter_initial (pname, w) = let filter_initial (pname, _) =
let summary = Specs.get_summary_unsafe "main_algorithm" pname in let summary = Specs.get_summary_unsafe "main_algorithm" pname in
Specs.get_timestamp summary = 0 in Specs.get_timestamp summary = 0 in
wpnames_todo := WeightedPnameSet.filter filter_initial (compute_weighed_pnameset call_graph); wpnames_todo := WeightedPnameSet.filter filter_initial (compute_weighed_pnameset call_graph);
@ -333,7 +333,7 @@ let main_algorithm exe_env analyze_proc filter_out process_result : unit =
tot_procs := WeightedPnameSet.cardinal !wpnames_todo; tot_procs := WeightedPnameSet.cardinal !wpnames_todo;
num_procs_done := 0; num_procs_done := 0;
let max_timeout = ref 1 in let max_timeout = ref 1 in
let wpname_can_be_analyzed (pname, weight) : bool = let wpname_can_be_analyzed (pname, _) : bool =
(* Return true if [pname] is not up to date and it can be analyzed right now *) (* Return true if [pname] is not up to date and it can be analyzed right now *)
Procname.Set.for_all Procname.Set.for_all
(proc_is_done call_graph) (Cg.get_nonrecursive_dependents call_graph pname) && (proc_is_done call_graph) (Cg.get_nonrecursive_dependents call_graph pname) &&
@ -383,7 +383,7 @@ let main_algorithm exe_env analyze_proc filter_out process_result : unit =
try try
let pname, calls = let pname, calls =
(** find max analyzable proc *) (** find max analyzable proc *)
filter_max exe_env call_graph wpname_can_be_analyzed !wpnames_todo wpnames_address_of in filter_max exe_env wpname_can_be_analyzed !wpnames_todo wpnames_address_of in
process_one_proc pname calls process_one_proc pname calls
with Not_found -> (* no analyzable procs *) with Not_found -> (* no analyzable procs *)
L.err "Error: can't analyze any procs. Printing current spec table@\n@[<v>%a@]@." L.err "Error: can't analyze any procs. Printing current spec table@\n@[<v>%a@]@."
@ -430,11 +430,11 @@ let interprocedural_algorithm
(* wrap _process_result and handle exceptions *) (* wrap _process_result and handle exceptions *)
try _process_result exe_env (pname, calls) summary with try _process_result exe_env (pname, calls) summary with
| exn -> | exn ->
let err_name, _, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in let err_name, _, _, _, _, _, _ = Exceptions.recognize_exception exn in
let err_str = "process_result raised " ^ (Localise.to_string err_name) in let err_str = "process_result raised " ^ (Localise.to_string err_name) in
L.err "Error: %s@." err_str; L.err "Error: %s@." err_str;
let exn' = Exceptions.Internal_error (Localise.verbatim_desc err_str) in let exn' = Exceptions.Internal_error (Localise.verbatim_desc err_str) in
Reporting.log_error pname exn'; Reporting.log_error pname exn';
post_process_procs exe_env [pname] in post_process_procs exe_env [pname] in
main_algorithm main_algorithm
exe_env (fun exe_env (n, w) -> analyze_proc exe_env n) filter_out process_result exe_env (fun exe_env (n, _) -> analyze_proc exe_env n) filter_out process_result

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

@ -67,7 +67,7 @@ let flatten_options list =
let rec drop_first n = function let rec drop_first n = function
| xs when n == 0 -> xs | xs when n == 0 -> xs
| x:: xs -> drop_first (n - 1) xs | _ :: xs -> drop_first (n - 1) xs
| [] -> [] | [] -> []
let drop_last n list = let drop_last n list =

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

@ -135,7 +135,7 @@ let fieldname_to_simplified_string fn =
match string_split_character s '.' with match string_split_character s '.' with
| Some s1, s2 -> | Some s1, s2 ->
(match string_split_character s1 '.' with (match string_split_character s1 '.' with
| Some s3, s4 -> s4 ^ "." ^ s2 | Some _, s4 -> s4 ^ "." ^ s2
| _ -> s) | _ -> s)
| _ -> s | _ -> s
@ -143,7 +143,7 @@ let fieldname_to_simplified_string fn =
let fieldname_to_flat_string fn = let fieldname_to_flat_string fn =
let s = Mangled.to_string fn.fname in let s = Mangled.to_string fn.fname in
match string_split_character s '.' with match string_split_character s '.' with
| Some s1, s2 -> s2 | Some _, s2 -> s2
| _ -> s | _ -> s
(** Returns the class part of the fieldname *) (** Returns the class part of the fieldname *)

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

@ -352,7 +352,7 @@ let print_usage_exit () =
exit(1) exit(1)
let () = (* parse command-line arguments *) let () = (* parse command-line arguments *)
let f arg = let f _ =
() (* ignore anonymous arguments *) in () (* ignore anonymous arguments *) in
Arg.parse arg_desc f usage; Arg.parse arg_desc f usage;
if not (Sys.file_exists !Config.results_dir) then if not (Sys.file_exists !Config.results_dir) then
@ -364,7 +364,7 @@ let () = (* parse command-line arguments *)
module Simulator = struct (** Simulate the analysis only *) module Simulator = struct (** Simulate the analysis only *)
let reset_summaries cg = let reset_summaries cg =
IList.iter IList.iter
(fun (pname, in_out_calls) -> Specs.reset_summary cg pname None) (fun (pname, _) -> Specs.reset_summary cg pname None)
(Cg.get_nodes_and_calls cg) (Cg.get_nodes_and_calls cg)
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for (** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for
@ -386,14 +386,14 @@ module Simulator = struct (** Simulate the analysis only *)
let procs_done = Fork.procs_become_done (Exe_env.get_cg exe_env) proc_name in let procs_done = Fork.procs_become_done (Exe_env.get_cg exe_env) proc_name in
Fork.post_process_procs exe_env procs_done Fork.post_process_procs exe_env procs_done
let analyze_proc exe_env tenv proc_name = let analyze_proc _ proc_name =
L.err "in analyze_proc %a@." Procname.pp proc_name; L.err "in analyze_proc %a@." Procname.pp proc_name;
(* for i = 1 to Random.int 1000000 do () done; *) (* for i = 1 to Random.int 1000000 do () done; *)
let prev_summary = Specs.get_summary_unsafe "Simulator" proc_name in let prev_summary = Specs.get_summary_unsafe "Simulator" proc_name in
let timestamp = max 1 (prev_summary.Specs.timestamp) in let timestamp = max 1 (prev_summary.Specs.timestamp) in
{ prev_summary with Specs.timestamp = timestamp } { prev_summary with Specs.timestamp = timestamp }
let filter_out cg proc_name = false let filter_out _ _ = false
end end
let analyze exe_env = let analyze exe_env =
@ -412,7 +412,7 @@ let analyze exe_env =
Simulator.reset_summaries (Exe_env.get_cg exe_env); Simulator.reset_summaries (Exe_env.get_cg exe_env);
Fork.interprocedural_algorithm Fork.interprocedural_algorithm
exe_env exe_env
(Simulator.analyze_proc exe_env) Simulator.analyze_proc
Simulator.process_result Simulator.process_result
Simulator.filter_out Simulator.filter_out
end end
@ -643,7 +643,7 @@ let compute_clusters exe_env files_changed : Cluster.t list =
let defined_procs = Cg.get_defined_nodes global_cg in let defined_procs = Cg.get_defined_nodes global_cg in
let total_nodes = IList.length nodes in let total_nodes = IList.length nodes in
let computed_nodes = ref 0 in let computed_nodes = ref 0 in
let do_node (n, defined, restricted) = let do_node (n, defined, _) =
L.log_progress "Computing dependencies..." computed_nodes total_nodes; L.log_progress "Computing dependencies..." computed_nodes total_nodes;
if defined then if defined then
Cg.add_defined_node file_cg Cg.add_defined_node file_cg
@ -711,7 +711,7 @@ let compute_clusters exe_env files_changed : Cluster.t list =
clusters' clusters'
(** compute the set of procedures in [cg] changed since the last analysis *) (** compute the set of procedures in [cg] changed since the last analysis *)
let cg_get_changed_procs exe_env source_dir cg = let cg_get_changed_procs source_dir cg =
let cfg_fname = DB.source_dir_get_internal_file source_dir ".cfg" in let cfg_fname = DB.source_dir_get_internal_file source_dir ".cfg" in
let cfg_opt = Cfg.load_cfg_from_file cfg_fname in let cfg_opt = Cfg.load_cfg_from_file cfg_fname in
let pdesc_changed pname = let pdesc_changed pname =
@ -750,11 +750,11 @@ let compute_files_changed_map _exe_env (source_dirs : DB.source_dir list) exclud
| Some cg -> (source_dir, cg) :: cg_list) | Some cg -> (source_dir, cg) :: cg_list)
[] []
sorted_dirs in sorted_dirs in
let exe_env_get_files_changed files_changed_map exe_env = let exe_env_get_files_changed files_changed_map =
let cg_get_files_changed files_changed_map (source_dir, cg) = let cg_get_files_changed files_changed_map (source_dir, cg) =
let changed_procs = let changed_procs =
if !incremental_mode = ANALYZE_ALL then Cg.get_defined_nodes cg if !incremental_mode = ANALYZE_ALL then Cg.get_defined_nodes cg
else cg_get_changed_procs exe_env source_dir cg in else cg_get_changed_procs source_dir cg in
if changed_procs <> [] then if changed_procs <> [] then
let file_pname = ClusterMakefile.source_file_to_pname (Cg.get_source cg) in 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 Procname.Map.add file_pname (proc_list_to_set changed_procs) files_changed_map
@ -763,7 +763,7 @@ let compute_files_changed_map _exe_env (source_dirs : DB.source_dir list) exclud
let exe_env = Exe_env.freeze _exe_env in let exe_env = Exe_env.freeze _exe_env in
let files_changed = let files_changed =
if !incremental_mode = ANALYZE_ALL then Procname.Map.empty if !incremental_mode = ANALYZE_ALL then Procname.Map.empty
else exe_env_get_files_changed Procname.Map.empty exe_env in else exe_env_get_files_changed Procname.Map.empty in
files_changed, exe_env files_changed, exe_env
(** Create an exe_env from a cluster. *) (** Create an exe_env from a cluster. *)
@ -824,7 +824,7 @@ let open_output_file f fname =
let close_output_file = function let close_output_file = function
| None -> () | None -> ()
| Some (fmt, cout) -> close_out cout | Some (_, cout) -> close_out cout
let setup_logging () = let setup_logging () =
if !Config.developer_mode then if !Config.developer_mode then

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

@ -31,9 +31,9 @@ type filters =
proc_filter : proc_filter; proc_filter : proc_filter;
} }
let default_path_filter : path_filter = function path -> true let default_path_filter : path_filter = function _ -> true
let default_error_filter : error_filter = function error_name -> true let default_error_filter : error_filter = function _ -> true
let default_proc_filter : proc_filter = function proc_name -> true let default_proc_filter : proc_filter = function _ -> true
let do_not_filter : filters = let do_not_filter : filters =
{ {
@ -63,7 +63,7 @@ let is_matching patterns =
module FileContainsStringMatcher = struct module FileContainsStringMatcher = struct
type matcher = DB.source_file -> bool type matcher = DB.source_file -> bool
let default_matcher : matcher = fun fname -> false let default_matcher : matcher = fun _ -> false
let file_contains regexp file_in = let file_contains regexp file_in =
let rec loop () = let rec loop () =
@ -104,7 +104,7 @@ struct
type matcher = DB.source_file -> Procname.t -> bool type matcher = DB.source_file -> Procname.t -> bool
let default_matcher : matcher = let default_matcher : matcher =
fun source_file proc_name -> false fun _ _ -> false
type method_pattern = { type method_pattern = {
class_name : string; class_name : string;
@ -158,7 +158,7 @@ struct
| `String s -> s:: accu | `String s -> s:: accu
| _ -> failwith ("Unrecognised parameters in " ^ Yojson.Basic.to_string (`Assoc assoc)) in | _ -> failwith ("Unrecognised parameters in " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.rev (IList.fold_left collect [] l) in IList.rev (IList.fold_left collect [] l) in
let create_method_pattern mp assoc = let create_method_pattern assoc =
let loop mp = function let loop mp = function
| (key, `String s) when key = "class" -> | (key, `String s) when key = "class" ->
{ mp with class_name = s } { mp with class_name = s }
@ -169,17 +169,17 @@ struct
| (key, _) when key = "language" -> mp | (key, _) when key = "language" -> mp
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in | _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.fold_left loop default_method_pattern assoc IList.fold_left loop default_method_pattern assoc
and create_string_contains sc assoc = and create_string_contains assoc =
let loop sc = function let loop sc = function
| (key, `String pattern) when key = "source_contains" -> pattern | (key, `String pattern) when key = "source_contains" -> pattern
| (key, _) when key = "language" -> sc | (key, _) when key = "language" -> sc
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in | _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.fold_left loop default_source_contains assoc in IList.fold_left loop default_source_contains assoc in
match detect_pattern assoc with match detect_pattern assoc with
| Method_pattern (language, mp) -> | Method_pattern (language, _) ->
Method_pattern (language, create_method_pattern mp assoc) Method_pattern (language, create_method_pattern assoc)
| Source_contains (language, sc) -> | Source_contains (language, _) ->
Source_contains (language, create_string_contains sc assoc) Source_contains (language, create_string_contains assoc)
let rec translate accu (json : Yojson.Basic.json) : pattern list = let rec translate accu (json : Yojson.Basic.json) : pattern list =
match json with match json with
@ -201,7 +201,7 @@ struct
StringMap.add pattern.class_name (pattern:: previous) map) StringMap.add pattern.class_name (pattern:: previous) map)
StringMap.empty StringMap.empty
m_patterns in m_patterns in
fun source_file proc_name -> fun _ proc_name ->
let class_name = Procname.java_get_class proc_name let class_name = Procname.java_get_class proc_name
and method_name = Procname.java_get_method proc_name in and method_name = Procname.java_get_method proc_name in
try try
@ -217,12 +217,12 @@ struct
let create_file_matcher patterns = let create_file_matcher patterns =
let s_patterns, m_patterns = let s_patterns, m_patterns =
let collect (s_patterns, m_patterns) = function let collect (s_patterns, m_patterns) = function
| Source_contains (lang, s) -> (s:: s_patterns, m_patterns) | Source_contains (_, s) -> (s:: s_patterns, m_patterns)
| Method_pattern (lang, mp) -> (s_patterns, mp :: m_patterns) in | Method_pattern (_, mp) -> (s_patterns, mp :: m_patterns) in
IList.fold_left collect ([], []) patterns in IList.fold_left collect ([], []) patterns in
let s_matcher = let s_matcher =
let matcher = FileContainsStringMatcher.create_matcher s_patterns in let matcher = FileContainsStringMatcher.create_matcher s_patterns in
fun source_file proc_name -> matcher source_file fun source_file _ -> matcher source_file
and m_matcher = create_method_matcher m_patterns in and m_matcher = create_method_matcher m_patterns in
fun source_file proc_name -> fun source_file proc_name ->
m_matcher source_file proc_name || s_matcher source_file proc_name m_matcher source_file proc_name || s_matcher source_file proc_name

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

@ -269,7 +269,7 @@ let begin_latex_file fmt =
Latex.pp_begin fmt (author, title, table_of_contents) Latex.pp_begin fmt (author, title, table_of_contents)
(** Write proc summary to latex file *) (** Write proc summary to latex file *)
let write_summary_latex fname fmt summary = let write_summary_latex fmt summary =
let proc_name = Specs.get_proc_name summary in let proc_name = Specs.get_proc_name summary in
Latex.pp_section fmt ("Analysis of function " ^ (Latex.convert_string (Procname.to_string proc_name))); Latex.pp_section fmt ("Analysis of function " ^ (Latex.convert_string (Procname.to_string proc_name)));
F.fprintf fmt "@[<v>%a@]" (Specs.pp_summary (pe_latex Black) !whole_seconds) summary F.fprintf fmt "@[<v>%a@]" (Specs.pp_summary (pe_latex Black) !whole_seconds) summary
@ -364,7 +364,7 @@ let summary_values top_proc_set summary =
let do_spec spec = visited := Specs.Visitedset.union spec.Specs.visited !visited in let do_spec spec = visited := Specs.Visitedset.union spec.Specs.visited !visited in
IList.iter do_spec specs; IList.iter do_spec specs;
let visited_lines = ref IntSet.empty in let visited_lines = ref IntSet.empty in
Specs.Visitedset.iter (fun (n, ls) -> Specs.Visitedset.iter (fun (_, ls) ->
IList.iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls) IList.iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls)
!visited; !visited;
Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in
@ -437,7 +437,7 @@ module ProcsCsv = struct
Io_infer.Xml.tag_proof_trace Io_infer.Xml.tag_proof_trace
(** Write proc summary stats in csv format *) (** Write proc summary stats in csv format *)
let pp_summary fname top_proc_set fmt summary = let pp_summary top_proc_set fmt summary =
let pp x = F.fprintf fmt x in let pp x = F.fprintf fmt x in
let sv = summary_values top_proc_set summary in let sv = summary_values top_proc_set summary in
pp "\"%s\"," (Escape.escape_csv sv.vname); pp "\"%s\"," (Escape.escape_csv sv.vname);
@ -530,10 +530,10 @@ module BugsCsv = struct
"advice" "advice"
(** Write bug report in csv format *) (** Write bug report in csv format *)
let pp_bugs error_filter fname fmt summary = let pp_bugs error_filter fmt summary =
let pp x = F.fprintf fmt x in let pp x = F.fprintf fmt x in
let err_log = summary.Specs.attributes.ProcAttributes.err_log in let err_log = summary.Specs.attributes.ProcAttributes.err_log in
let pp_row (node_id, node_key) loc ml_loc_opt ekind in_footprint error_name error_desc severity ltr pre_opt eclass = let pp_row (_, node_key) loc _ ekind in_footprint error_name error_desc severity ltr _ eclass =
if in_footprint && error_filter error_desc error_name then if in_footprint && error_filter error_desc error_name then
let err_desc_string = error_desc_to_csv_string error_desc in let err_desc_string = error_desc_to_csv_string error_desc in
let err_advice_string = error_advice_to_csv_string error_desc in let err_advice_string = error_advice_to_csv_string error_desc in
@ -579,10 +579,12 @@ module BugsJson = struct
let pp_json_close fmt () = F.fprintf fmt "]\n@?" let pp_json_close fmt () = F.fprintf fmt "]\n@?"
(** Write bug report in JSON format *) (** Write bug report in JSON format *)
let pp_bugs error_filter fname fmt summary = let pp_bugs error_filter fmt summary =
let pp x = F.fprintf fmt x in let pp x = F.fprintf fmt x in
let err_log = summary.Specs.attributes.ProcAttributes.err_log in let err_log = summary.Specs.attributes.ProcAttributes.err_log in
let pp_row (node_id, node_key) loc ml_loc_opt ekind in_footprint error_name error_desc severity ltr pre_opt eclass = let pp_row
(_, node_key) loc ml_loc_opt ekind in_footprint error_name error_desc severity ltr _ eclass
=
if in_footprint && error_filter error_desc error_name then if in_footprint && error_filter error_desc error_name then
let kind = Exceptions.err_kind_string ekind in let kind = Exceptions.err_kind_string ekind in
let bug_type = Localise.to_string error_name in let bug_type = Localise.to_string error_name in
@ -617,9 +619,9 @@ end
module BugsTxt = struct module BugsTxt = struct
(** Write bug report in text format *) (** Write bug report in text format *)
let pp_bugs error_filter fname fmt summary = let pp_bugs error_filter fmt summary =
let err_log = summary.Specs.attributes.ProcAttributes.err_log in let err_log = summary.Specs.attributes.ProcAttributes.err_log in
let pp_row (node_id, node_key) loc ml_loc_opt ekind in_footprint error_name error_desc severity ltr pre_opt eclass = let pp_row (node_id, node_key) loc _ ekind in_footprint error_name error_desc _ _ _ _ =
if in_footprint && error_filter error_desc error_name then if in_footprint && error_filter error_desc error_name then
Exceptions.pp_err (node_id, node_key) loc ekind error_name error_desc None fmt () in Exceptions.pp_err (node_id, node_key) loc ekind error_name error_desc None fmt () in
Errlog.iter pp_row err_log Errlog.iter pp_row err_log
@ -659,7 +661,8 @@ module BugsXml = struct
(** print bugs from summary in xml *) (** print bugs from summary in xml *)
let pp_bugs error_filter linereader fmt summary = let pp_bugs error_filter linereader fmt summary =
let err_log = summary.Specs.attributes.ProcAttributes.err_log in let err_log = summary.Specs.attributes.ProcAttributes.err_log in
let do_row (node_id, node_key) loc ml_loc_opt ekind in_footprint error_name error_desc severity ltr pre_opt eclass = let do_row
(_, node_key) loc _ ekind in_footprint error_name error_desc severity ltr pre_opt eclass =
if in_footprint && error_filter error_desc error_name then if in_footprint && error_filter error_desc error_name then
let err_desc_string = error_desc_to_xml_string error_desc in let err_desc_string = error_desc_to_xml_string error_desc in
let precondition_tree () = match pre_opt with let precondition_tree () = match pre_opt with
@ -726,7 +729,7 @@ module CallsCsv = struct
Io_infer.Xml.tag_call_trace Io_infer.Xml.tag_call_trace
(** Write proc summary stats in csv format *) (** Write proc summary stats in csv format *)
let pp_calls fname fmt summary = let pp_calls fmt summary =
let pp x = F.fprintf fmt x in let pp x = F.fprintf fmt x in
let stats = summary.Specs.stats in let stats = summary.Specs.stats in
let caller_name = Specs.get_proc_name summary in let caller_name = Specs.get_proc_name summary in
@ -746,7 +749,7 @@ module UnitTest = struct
let procs_done = ref [] let procs_done = ref []
(** Print unit test for every spec in the summary *) (** Print unit test for every spec in the summary *)
let print_unit_test fname proc_name summary = let print_unit_test proc_name summary =
let cnt = ref 0 in let cnt = ref 0 in
let fmt = F.std_formatter in let fmt = F.std_formatter in
let do_spec spec = let do_spec spec =
@ -861,7 +864,7 @@ module Stats = struct
let process_err_log error_filter linereader err_log stats = let process_err_log error_filter linereader err_log stats =
let found_errors = ref false in let found_errors = ref false in
let process_row (node_id, node_key) loc ml_loc_opt ekind in_footprint error_name error_desc severity ltr pre_opt eclass = let process_row _ loc _ ekind in_footprint error_name error_desc _ ltr _ _ =
let type_str = Localise.to_string error_name in let type_str = Localise.to_string error_name in
if in_footprint && error_filter error_desc error_name if in_footprint && error_filter error_desc error_name
then match ekind with then match ekind with
@ -974,18 +977,18 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna
(filters.Inferconfig.path_filter summary.Specs.attributes.ProcAttributes.loc.Location.file (filters.Inferconfig.path_filter summary.Specs.attributes.ProcAttributes.loc.Location.file
|| always_report ()) && || always_report ()) &&
filters.Inferconfig.error_filter error_name && filters.Inferconfig.proc_filter proc_name in filters.Inferconfig.error_filter error_name && filters.Inferconfig.proc_filter proc_name in
do_outf procs_csv (fun outf -> F.fprintf outf.fmt "%a" (ProcsCsv.pp_summary fname top_proc_set) summary); do_outf procs_csv (fun outf -> ProcsCsv.pp_summary top_proc_set outf.fmt summary);
do_outf calls_csv (fun outf -> F.fprintf outf.fmt "%a" (CallsCsv.pp_calls fname) summary); do_outf calls_csv (fun outf -> CallsCsv.pp_calls outf.fmt summary);
do_outf procs_xml (fun outf -> ProcsXml.pp_proc top_proc_set outf.fmt summary); do_outf procs_xml (fun outf -> ProcsXml.pp_proc top_proc_set outf.fmt summary);
do_outf bugs_csv (fun outf -> BugsCsv.pp_bugs error_filter fname outf.fmt summary); do_outf bugs_csv (fun outf -> BugsCsv.pp_bugs error_filter outf.fmt summary);
do_outf bugs_json (fun outf -> BugsJson.pp_bugs error_filter fname outf.fmt summary); do_outf bugs_json (fun outf -> BugsJson.pp_bugs error_filter outf.fmt summary);
do_outf bugs_txt (fun outf -> BugsTxt.pp_bugs error_filter linereader outf.fmt summary); do_outf bugs_txt (fun outf -> BugsTxt.pp_bugs error_filter outf.fmt summary);
do_outf bugs_xml (fun outf -> BugsXml.pp_bugs error_filter linereader outf.fmt summary); do_outf bugs_xml (fun outf -> BugsXml.pp_bugs error_filter linereader outf.fmt summary);
do_outf report (fun outf -> Stats.process_summary error_filter summary linereader stats); do_outf report (fun _ -> Stats.process_summary error_filter summary linereader stats);
if !precondition_stats then PreconditionStats.do_summary proc_name summary; if !precondition_stats then PreconditionStats.do_summary proc_name summary;
if !unit_test then UnitTest.print_unit_test fname proc_name summary; if !unit_test then UnitTest.print_unit_test proc_name summary;
Config.pp_simple := pp_simple_saved; Config.pp_simple := pp_simple_saved;
do_outf latex (fun outf -> write_summary_latex (DB.filename_from_string fname) outf.fmt summary); do_outf latex (fun outf -> write_summary_latex outf.fmt summary);
if !svg then begin if !svg then begin
let specs = Specs.get_specs_from_payload summary in let specs = Specs.get_specs_from_payload summary in
let dot_file = DB.filename_add_suffix base ".dot" in let dot_file = DB.filename_add_suffix base ".dot" in
@ -1058,7 +1061,7 @@ module AnalysisResults = struct
| Some summary -> | Some summary ->
summaries := (fname, summary) :: !summaries in summaries := (fname, summary) :: !summaries in
apply_without_gc (IList.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 summ_cmp (_, summ1) (_, summ2) =
let n = let n =
DB.source_file_compare DB.source_file_compare
summ1.Specs.attributes.ProcAttributes.loc.Location.file summ1.Specs.attributes.ProcAttributes.loc.Location.file

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

@ -253,14 +253,13 @@ let propagate (wl : Worklist.t) pname is_exception (pset: Paths.PathSet.t) (curr
(** propagate a set of results, including exceptions and divergence *) (** propagate a set of results, including exceptions and divergence *)
let propagate_nodes_divergence let propagate_nodes_divergence
tenv (pdesc: Cfg.Procdesc.t) (pset: Paths.PathSet.t) tenv (pdesc: Cfg.Procdesc.t) (pset: Paths.PathSet.t)
(path: Paths.Path.t) (kind_curr_node : Cfg.Node.nodekind) (_succ_nodes: Cfg.node list) (succ_nodes_: Cfg.node list) (exn_nodes: Cfg.node list) (wl : Worklist.t) =
(exn_nodes: Cfg.node list) (wl : Worklist.t) =
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let pset_exn, pset_ok = Paths.PathSet.partition (Tabulation.prop_is_exn pname) pset in 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 *) let succ_nodes = match State.get_goto_node () with (* handle Sil.Goto_node target, if any *)
| Some node_id -> | Some node_id ->
IList.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 | None -> succ_nodes_ in
if !Config.footprint && not (Paths.PathSet.is_empty (State.get_diverging_states_node ())) then if !Config.footprint && not (Paths.PathSet.is_empty (State.get_diverging_states_node ())) then
begin begin
Errdesc.warning_err (State.get_loc ()) "Propagating Divergence@."; Errdesc.warning_err (State.get_loc ()) "Propagating Divergence@.";
@ -303,7 +302,7 @@ let prop_max_size = ref (0, Prop.prop_emp)
let prop_max_chain_size = ref (0, Prop.prop_emp) let prop_max_chain_size = ref (0, Prop.prop_emp)
(* Check if the prop exceeds the current max *) (* Check if the prop exceeds the current max *)
let check_prop_size p path = let check_prop_size p _ =
let size = Prop.Metrics.prop_size p in let size = Prop.Metrics.prop_size p in
if size > fst !prop_max_size then if size > fst !prop_max_size then
(prop_max_size := (size, p); (prop_max_size := (size, p);
@ -552,15 +551,14 @@ let forward_tabulate cfg tenv wl =
let pset = let pset =
do_symbolic_execution (handle_exn curr_node) cfg tenv curr_node prop path in do_symbolic_execution (handle_exn curr_node) cfg tenv curr_node prop path in
L.d_decrease_indent 1; L.d_ln(); L.d_decrease_indent 1; L.d_ln();
propagate_nodes_divergence propagate_nodes_divergence tenv proc_desc pset succ_nodes exn_nodes wl;
tenv proc_desc pset path curr_node_kind succ_nodes exn_nodes wl;
with with
| exn when Exceptions.handle_exception exn && !Config.footprint -> | exn when Exceptions.handle_exception exn && !Config.footprint ->
handle_exn curr_node exn; handle_exn curr_node exn;
if !Config.nonstop then if !Config.nonstop then
propagate_nodes_divergence propagate_nodes_divergence
tenv proc_desc (Paths.PathSet.from_renamed_list [(prop, path)]) tenv proc_desc (Paths.PathSet.from_renamed_list [(prop, path)])
path curr_node_kind succ_nodes exn_nodes wl; succ_nodes exn_nodes wl;
L.d_decrease_indent 1; L.d_ln ()) L.d_decrease_indent 1; L.d_ln ())
pathset_todo in pathset_todo in
try try
@ -645,7 +643,7 @@ let vset_ref_add_path vset_ref path =
Paths.Path.iter_all_nodes_nocalls (fun n -> vset_ref := Cfg.NodeSet.add n !vset_ref) path Paths.Path.iter_all_nodes_nocalls (fun n -> vset_ref := Cfg.NodeSet.add n !vset_ref) path
let vset_ref_add_pathset vset_ref pathset = let vset_ref_add_pathset vset_ref pathset =
Paths.PathSet.iter (fun p path -> vset_ref_add_path vset_ref path) pathset Paths.PathSet.iter (fun _ path -> vset_ref_add_path vset_ref path) pathset
let compute_visited vset = let compute_visited vset =
let res = ref Specs.Visitedset.empty in let res = ref Specs.Visitedset.empty in
@ -663,7 +661,7 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let sub = let sub =
let fav = Sil.fav_new () in let fav = Sil.fav_new () in
Paths.PathSet.iter (fun prop path -> Prop.prop_fav_add fav prop) pathset; Paths.PathSet.iter (fun prop _ -> Prop.prop_fav_add fav prop) pathset;
let sub_list = IList.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 Sil.sub_of_list sub_list in
let pre_post_visited_list = let pre_post_visited_list =
@ -845,7 +843,7 @@ let execute_filter_prop wl cfg tenv pdesc init_node (precondition : Prop.normal
let get_procs_and_defined_children call_graph = let get_procs_and_defined_children call_graph =
IList.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 wl cfg proc_desc fmt proc_name = let pp_intra_stats wl proc_desc fmt _ =
let nstates = ref 0 in let nstates = ref 0 in
let nodes = Cfg.Procdesc.get_nodes proc_desc in let nodes = Cfg.Procdesc.get_nodes proc_desc in
IList.iter (fun node -> IList.iter (fun node ->
@ -901,7 +899,7 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
L.out "#### [FUNCTION %a] ... OK #####@\n" Procname.pp pname; L.out "#### [FUNCTION %a] ... OK #####@\n" Procname.pp pname;
L.out "#### Finished: Footprint Computation for %a %a ####@." L.out "#### Finished: Footprint Computation for %a %a ####@."
Procname.pp pname Procname.pp pname
(pp_intra_stats wl cfg pdesc) pname; (pp_intra_stats wl pdesc) pname;
L.out "#### [FUNCTION %a] Footprint Analysis result ####@\n%a@." L.out "#### [FUNCTION %a] Footprint Analysis result ####@\n%a@."
Procname.pp pname Procname.pp pname
(Paths.PathSet.pp pe_text) results; (Paths.PathSet.pp pe_text) results;
@ -935,7 +933,7 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
let outcome = if is_valid then "pass" else "fail" in let outcome = if is_valid then "pass" else "fail" in
L.out "Finished re-execution for precondition %d %a (%s)@." L.out "Finished re-execution for precondition %d %a (%s)@."
(Specs.Jprop.to_number p) (Specs.Jprop.to_number p)
(pp_intra_stats wl cfg pdesc) proc_name (pp_intra_stats wl pdesc) proc_name
outcome; outcome;
speco in speco in
if !Config.undo_join then if !Config.undo_join then
@ -967,17 +965,17 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
| Specs.RE_EXECUTION -> | Specs.RE_EXECUTION ->
re_execution pname re_execution pname
let set_current_language cfg proc_desc = let set_current_language proc_desc =
let language = (Cfg.Procdesc.get_attributes proc_desc).ProcAttributes.language in let language = (Cfg.Procdesc.get_attributes proc_desc).ProcAttributes.language in
Config.curr_language := language Config.curr_language := language
(** reset counters before analysing a procedure *) (** reset counters before analysing a procedure *)
let reset_global_counters cfg proc_name proc_desc = let reset_global_counters proc_desc =
Ident.NameGenerator.reset (); Ident.NameGenerator.reset ();
SymOp.reset_total (); SymOp.reset_total ();
reset_prop_metrics (); reset_prop_metrics ();
Abs.abs_rules_reset (); Abs.abs_rules_reset ();
set_current_language cfg proc_desc set_current_language proc_desc
(* Collect all pairs of the kind (precondition, runtime exception) from a summary *) (* Collect all pairs of the kind (precondition, runtime exception) from a summary *)
let exception_preconditions tenv pname summary = let exception_preconditions tenv pname summary =
@ -993,7 +991,7 @@ let exception_preconditions tenv pname summary =
IList.fold_left collect_spec [] (Specs.get_specs_from_payload summary) IList.fold_left collect_spec [] (Specs.get_specs_from_payload summary)
(* Collect all pairs of the kind (precondition, custom error) from a summary *) (* Collect all pairs of the kind (precondition, custom error) from a summary *)
let custom_error_preconditions tenv pname summary = let custom_error_preconditions summary =
let collect_errors pre errors (prop, _) = let collect_errors pre errors (prop, _) =
match Tabulation.lookup_custom_errors prop with match Tabulation.lookup_custom_errors prop with
| None -> errors | None -> errors
@ -1038,7 +1036,7 @@ let is_unavoidable pre =
(** Detects if there are specs of the form {precondition} proc {runtime exception} and report (** Detects if there are specs of the form {precondition} proc {runtime exception} and report
an error in that case, generating the trace that lead to the runtime exception if the method is an error in that case, generating the trace that lead to the runtime exception if the method is
called in the context { precondition } *) called in the context { precondition } *)
let report_runtime_exceptions tenv cfg pdesc summary = let report_runtime_exceptions tenv pdesc summary =
let pname = Specs.get_proc_name summary in let pname = Specs.get_proc_name summary in
let is_public_method = let is_public_method =
(Specs.get_attributes summary).ProcAttributes.access = Sil.Public in (Specs.get_attributes summary).ProcAttributes.access = Sil.Public in
@ -1064,7 +1062,7 @@ let report_runtime_exceptions tenv cfg pdesc summary =
IList.iter report (exception_preconditions tenv pname summary) IList.iter report (exception_preconditions tenv pname summary)
let report_custom_errors tenv cfg pdesc summary = let report_custom_errors summary =
let pname = Specs.get_proc_name summary in let pname = Specs.get_proc_name summary in
let report (pre, custom_error) = let report (pre, custom_error) =
if is_unavoidable pre then if is_unavoidable pre then
@ -1072,7 +1070,7 @@ let report_custom_errors tenv cfg pdesc summary =
let err_desc = Localise.desc_custom_error loc in let err_desc = Localise.desc_custom_error loc in
let exn = Exceptions.Custom_error (custom_error, err_desc) in let exn = Exceptions.Custom_error (custom_error, err_desc) in
Reporting.log_error pname ~pre: (Some (Specs.Jprop.to_prop pre)) exn in Reporting.log_error pname ~pre: (Some (Specs.Jprop.to_prop pre)) exn in
IList.iter report (custom_error_preconditions tenv pname summary) IList.iter report (custom_error_preconditions summary)
(** update a summary after analysing a procedure *) (** update a summary after analysing a procedure *)
@ -1084,7 +1082,7 @@ let update_summary prev_summary specs phase proc_name elapsed res =
let symops = prev_summary.Specs.stats.Specs.symops + SymOp.get_total () in let symops = prev_summary.Specs.stats.Specs.symops + SymOp.get_total () in
let stats_failure = match res with let stats_failure = match res with
| None -> prev_summary.Specs.stats.Specs.stats_failure | None -> prev_summary.Specs.stats.Specs.stats_failure
| Some failure_kind -> res in | Some _ -> res in
let stats = let stats =
{ prev_summary.Specs.stats with { prev_summary.Specs.stats with
Specs.stats_time; Specs.stats_time;
@ -1114,7 +1112,7 @@ let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
let proc_desc = match Cfg.Procdesc.find_from_name cfg proc_name with let proc_desc = match Cfg.Procdesc.find_from_name cfg proc_name with
| Some proc_desc -> proc_desc | Some proc_desc -> proc_desc
| None -> assert false in | None -> assert false in
reset_global_counters cfg proc_name proc_desc; reset_global_counters proc_desc;
let go, get_results = perform_analysis_phase cfg tenv proc_name proc_desc in let go, get_results = perform_analysis_phase cfg tenv proc_name proc_desc in
let res = Fork.Timeout.exe_timeout (Specs.get_iterations proc_name) go () in let res = Fork.Timeout.exe_timeout (Specs.get_iterations proc_name) go () in
let specs, phase = get_results () in let specs, phase = get_results () in
@ -1123,9 +1121,9 @@ let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
let updated_summary = let updated_summary =
update_summary prev_summary specs phase proc_name elapsed res in update_summary prev_summary specs phase proc_name elapsed res in
if !Config.curr_language == Config.C_CPP && Config.report_custom_error then if !Config.curr_language == Config.C_CPP && Config.report_custom_error then
report_custom_errors tenv cfg proc_desc updated_summary; report_custom_errors updated_summary;
if !Config.curr_language == Config.Java && !Config.report_runtime_exceptions then if !Config.curr_language == Config.Java && !Config.report_runtime_exceptions then
report_runtime_exceptions tenv cfg proc_desc updated_summary; report_runtime_exceptions tenv proc_desc updated_summary;
updated_summary updated_summary
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for (** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for
@ -1195,7 +1193,7 @@ let filter_out (call_graph: Cg.t) (proc_name: Procname.t) : bool =
let check_skipped_procs procs_and_defined_children = let check_skipped_procs procs_and_defined_children =
let skipped_procs = ref Procname.Set.empty in let skipped_procs = ref Procname.Set.empty in
let proc_check_skips (pname, dep) = let proc_check_skips (pname, _) =
let process_skip () = let process_skip () =
let call_stats = let call_stats =
(Specs.get_summary_unsafe "check_skipped_procs" pname).Specs.stats.Specs.call_stats in (Specs.get_summary_unsafe "check_skipped_procs" pname).Specs.stats.Specs.call_stats in
@ -1214,7 +1212,7 @@ let check_skipped_procs procs_and_defined_children =
(** create a function to filter procedures which were skips but now have a .specs file *) (** create a function to filter procedures which were skips but now have a .specs file *)
let filter_skipped_procs cg procs_and_defined_children = let filter_skipped_procs cg procs_and_defined_children =
let skipped_procs_with_summary = check_skipped_procs procs_and_defined_children in let skipped_procs_with_summary = check_skipped_procs procs_and_defined_children in
let filter (pname, dep) = let filter (pname, _) =
let calls_recurs pn = let calls_recurs pn =
let r = try Cg.calls_recursively cg pname pn with Not_found -> false in let r = try Cg.calls_recursively cg pname pn with Not_found -> false in
L.err "calls recursively %a %a: %b@." Procname.pp pname Procname.pp pn r; L.err "calls recursively %a %a: %b@." Procname.pp pname Procname.pp pn r;
@ -1223,7 +1221,7 @@ let filter_skipped_procs cg procs_and_defined_children =
filter filter
(** create a function to filter procedures which were analyzed before but had no specs *) (** create a function to filter procedures which were analyzed before but had no specs *)
let filter_nospecs (pname, dep) = let filter_nospecs (pname, _) =
if Specs.summary_exists pname if Specs.summary_exists pname
then Specs.get_specs pname = [] then Specs.get_specs pname = []
else false else false
@ -1386,7 +1384,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
let _print_stats exe_env = let _print_stats exe_env =
let proc_is_active proc_desc = let proc_is_active proc_desc =
Exe_env.proc_is_active exe_env (Cfg.Procdesc.get_proc_name proc_desc) in Exe_env.proc_is_active exe_env (Cfg.Procdesc.get_proc_name proc_desc) in
Exe_env.iter_files (fun fname tenv cfg -> Exe_env.iter_files (fun fname cfg ->
let proc_shadowed proc_desc = let proc_shadowed proc_desc =
(** return true if a proc with the same name in another module was analyzed instead *) (** return true if a proc with the same name in another module was analyzed instead *)
let proc_name = Cfg.Procdesc.get_proc_name proc_desc in let proc_name = Cfg.Procdesc.get_proc_name proc_desc in

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

@ -131,7 +131,7 @@ module Tags = struct
let create () = ref [] let create () = ref []
let add tags tag value = tags := (tag, value) :: !tags let add tags tag value = tags := (tag, value) :: !tags
let update tags tag value = let update tags tag value =
let tags' = IList.filter (fun (t, v) -> t <> tag) tags in let tags' = IList.filter (fun (t, _) -> t <> tag) tags in
(tag, value) :: tags' (tag, value) :: tags'
let get tags tag = let get tags tag =
try try
@ -184,8 +184,8 @@ let error_desc_set_bucket err_desc bucket show_in_message =
(** get the value tag, if any *) (** get the value tag, if any *)
let get_value_line_tag tags = let get_value_line_tag tags =
try try
let value = snd (IList.find (fun (_tag, value) -> _tag = Tags.value) tags) in let value = snd (IList.find (fun (_tag, _) -> _tag = Tags.value) tags) in
let line = snd (IList.find (fun (_tag, value) -> _tag = Tags.line) tags) in let line = snd (IList.find (fun (_tag, _) -> _tag = Tags.line) tags) in
Some [value; line] Some [value; line]
with Not_found -> None with Not_found -> None
@ -470,7 +470,7 @@ let dereference_string deref_str value_str access_opt loc =
let line_str = string_of_int n in let line_str = string_of_int n in
Tags.add tags Tags.accessed_line line_str; Tags.add tags Tags.accessed_line line_str;
["last accessed on line " ^ line_str] ["last accessed on line " ^ line_str]
| Some (Last_assigned (n, ncf)) -> | Some (Last_assigned (n, _)) ->
let line_str = string_of_int n in let line_str = string_of_int n in
Tags.add tags Tags.assigned_line line_str; Tags.add tags Tags.assigned_line line_str;
["last assigned on line " ^ line_str] ["last assigned on line " ^ line_str]
@ -498,7 +498,7 @@ let parameter_field_not_null_checked_desc (desc : error_desc) exp =
let field_not_nullable_desc exp = let field_not_nullable_desc exp =
let rec exp_to_string exp = let rec exp_to_string exp =
match exp with match exp with
| Sil.Lfield (exp', field, typ) -> (exp_to_string exp')^" -> "^(Ident.fieldname_to_string field) | Sil.Lfield (exp', field, _) -> (exp_to_string exp')^" -> "^(Ident.fieldname_to_string field)
| Sil.Lvar pvar -> Mangled.to_string (Sil.pvar_get_name pvar) | Sil.Lvar pvar -> Mangled.to_string (Sil.pvar_get_name pvar)
| _ -> "" in | _ -> "" in
let var_s = exp_to_string exp in let var_s = exp_to_string exp in
@ -512,7 +512,7 @@ let parameter_field_not_null_checked_desc (desc : error_desc) exp =
| _ -> desc | _ -> desc
let has_tag (desc : error_desc) tag = let has_tag (desc : error_desc) tag =
IList.exists (fun (tag', value) -> tag = tag') desc.tags IList.exists (fun (tag', _) -> tag = tag') desc.tags
let is_parameter_not_null_checked_desc desc = has_tag desc Tags.parameter_not_null_checked let is_parameter_not_null_checked_desc desc = has_tag desc Tags.parameter_not_null_checked
@ -713,7 +713,7 @@ let desc_retain_cycle prop cycle loc cycle_dotty =
match Str.split_delim (Str.regexp_string "&old_") s with match Str.split_delim (Str.regexp_string "&old_") s with
| [_; s'] -> s' | [_; s'] -> s'
| _ -> s in | _ -> s in
let do_edge ((se, _), f, se') = let do_edge ((se, _), f, _) =
match se with match se with
| Sil.Eexp(Sil.Lvar pvar, _) when Sil.pvar_equal pvar Sil.block_pvar -> | Sil.Eexp(Sil.Lvar pvar, _) when Sil.pvar_equal pvar Sil.block_pvar ->
str_cycle:=!str_cycle^" ("^(string_of_int !ct)^") a block capturing "^(Ident.fieldname_to_string f)^"; "; str_cycle:=!str_cycle^" ("^(string_of_int !ct)^") a block capturing "^(Ident.fieldname_to_string f)^"; ";

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

@ -69,7 +69,7 @@ let current_out_formatter = ref F.std_formatter
let current_err_formatter = ref F.err_formatter let current_err_formatter = ref F.err_formatter
(** Get the current err formatter *) (** Get the current err formatter *)
let get_err_formatter fmt = !current_err_formatter let get_err_formatter () = !current_err_formatter
(** Set the current out formatter *) (** Set the current out formatter *)
let set_out_formatter fmt = let set_out_formatter fmt =

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

@ -52,7 +52,7 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
check_equal sub vars e1 e2 check_equal sub vars e1 e2
| Sil.Sizeof _, _ | _, Sil.Sizeof _ -> | Sil.Sizeof _, _ | _, Sil.Sizeof _ ->
check_equal sub vars e1 e2 check_equal sub vars e1 e2
| Sil.Cast (t1, e1'), Sil.Cast (t2, e2') -> (* we are currently ignoring cast *) | Sil.Cast (_, e1'), Sil.Cast (_, e2') -> (* we are currently ignoring cast *)
exp_match e1' sub vars e2' exp_match e1' sub vars e2'
| Sil.Cast _, _ | _, Sil.Cast _ -> | Sil.Cast _, _ | _, Sil.Cast _ ->
None None
@ -68,7 +68,7 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
None (* Naive *) None (* Naive *)
| Sil.Lvar _, _ | _, Sil.Lvar _ -> | Sil.Lvar _, _ | _, Sil.Lvar _ ->
check_equal sub vars e1 e2 check_equal sub vars e1 e2
| Sil.Lfield(e1', fld1, t1), Sil.Lfield(e2', fld2, t2) when (Sil.fld_equal fld1 fld2) -> | Sil.Lfield(e1', fld1, _), Sil.Lfield(e2', fld2, _) when (Sil.fld_equal fld1 fld2) ->
exp_match e1' sub vars e2' exp_match e1' sub vars e2'
| Sil.Lfield _, _ | _, Sil.Lfield _ -> | Sil.Lfield _, _ | _, Sil.Lfield _ ->
None None
@ -91,7 +91,7 @@ let exp_list_match es1 sub vars es2 =
sometimes forgets fields of hpred. It can possibly cause a problem. *) sometimes forgets fields of hpred. It can possibly cause a problem. *)
let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option = let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option =
match sexp1, sexp2 with match sexp1, sexp2 with
| Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) -> | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) ->
exp_match exp1 sub vars exp2 exp_match exp1 sub vars exp2
| Sil.Eexp _, _ | _, Sil.Eexp _ -> | Sil.Eexp _, _ | _, Sil.Eexp _ ->
None None
@ -180,7 +180,7 @@ let rec instantiate_to_emp p condition sub vars = function
if not hpat.flag then None if not hpat.flag then None
else match hpat.hpred with else match hpat.hpred with
| Sil.Hpointsto _ | Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) | Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) -> None | Sil.Hpointsto _ | Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) | Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) -> None
| Sil.Hlseg (k, _, e1, e2, _) -> | Sil.Hlseg (_, _, e1, e2, _) ->
let fully_instantiated = not (IList.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 in if (not fully_instantiated) then None else
let e1' = Sil.exp_sub sub e1 let e1' = Sil.exp_sub sub e1
@ -190,7 +190,7 @@ let rec instantiate_to_emp p condition sub vars = function
| Some (sub_new, vars_leftover) -> | Some (sub_new, vars_leftover) ->
instantiate_to_emp p condition sub_new vars_leftover hpats instantiate_to_emp p condition sub_new vars_leftover hpats
end end
| Sil.Hdllseg (k, _, iF, oB, oF, iB, _) -> | Sil.Hdllseg (_, _, iF, oB, oF, iB, _) ->
let fully_instantiated = let fully_instantiated =
not (IList.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 in if (not fully_instantiated) then None else
@ -484,7 +484,7 @@ type iso_mode = Exact | LFieldForget | RFieldForget
let rec generate_todos_from_strexp mode todos sexp1 sexp2 = let rec generate_todos_from_strexp mode todos sexp1 sexp2 =
match sexp1, sexp2 with match sexp1, sexp2 with
| Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) -> | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) ->
let new_todos = (exp1, exp2) :: todos in let new_todos = (exp1, exp2) :: todos in
Some new_todos Some new_todos
| Sil.Eexp _, _ -> | Sil.Eexp _, _ ->

5
infer/src/backend/ondemand.ml
Unescape View File

@ -116,7 +116,7 @@ let restore_global_state st =
let do_analysis curr_pdesc callee_pname = let do_analysis curr_pdesc callee_pname =
let curr_pname = Cfg.Procdesc.get_proc_name curr_pdesc in let curr_pname = Cfg.Procdesc.get_proc_name curr_pdesc in
let really_do_analysis analyze_proc proc_desc = let really_do_analysis analyze_proc =
if trace () then L.stderr "[%d] really_do_analysis %a -> %a@." if trace () then L.stderr "[%d] really_do_analysis %a -> %a@."
!nesting !nesting
Procname.pp curr_pname Procname.pp curr_pname
@ -170,8 +170,7 @@ let do_analysis curr_pdesc callee_pname =
when procedure_should_be_analyzed curr_pdesc callee_pname -> when procedure_should_be_analyzed curr_pdesc callee_pname ->
begin begin
match callbacks.get_proc_desc callee_pname with match callbacks.get_proc_desc callee_pname with
| Some proc_desc -> | Some _ -> really_do_analysis callbacks.analyze_ondemand
really_do_analysis callbacks.analyze_ondemand proc_desc
| None -> () | None -> ()
end end
| _ -> | _ ->

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

@ -99,7 +99,7 @@ end = struct
let get_description path = let get_description path =
match path with match path with
| Pnode (node, exn_opt, session, path, stats, descr_opt) -> | Pnode (_, _, _, _, _, descr_opt) ->
descr_opt descr_opt
| _ -> None | _ -> None
@ -182,9 +182,9 @@ end = struct
(** restore the invariant that all the stats are dummy, so the path is ready for another traversal *) (** restore the invariant that all the stats are dummy, so the path is ready for another traversal *)
(** assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *) (** assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *)
let rec reset_stats = function let rec reset_stats = function
| Pstart (node, stats) -> | Pstart (_, stats) ->
if not (stats_is_dummy stats) then set_dummy_stats stats if not (stats_is_dummy stats) then set_dummy_stats stats
| Pnode (node, exn_opt, session, path, stats, _) -> | Pnode (_, _, _, path, stats, _) ->
if not (stats_is_dummy stats) then if not (stats_is_dummy stats) then
begin begin
reset_stats path; reset_stats path;
@ -197,7 +197,7 @@ end = struct
reset_stats path2; reset_stats path2;
set_dummy_stats stats set_dummy_stats stats
end end
| Pcall (path1, pname, path2, stats) -> | Pcall (path1, _, path2, stats) ->
if not (stats_is_dummy stats) then if not (stats_is_dummy stats) then
begin begin
reset_stats path1; reset_stats path1;
@ -221,7 +221,7 @@ end = struct
stats.max_length <- if found then 1 else 0; stats.max_length <- if found then 1 else 0;
stats.linear_num <- 1.0; stats.linear_num <- 1.0;
end end
| Pnode (node, exn_opt, session, path, stats, _) -> | Pnode (node, _, _, path, stats, _) ->
if stats_is_dummy stats then if stats_is_dummy stats then
begin begin
compute_stats do_calls f path; compute_stats do_calls f path;
@ -239,7 +239,7 @@ end = struct
stats.max_length <- max stats1.max_length stats2.max_length; stats.max_length <- max stats1.max_length stats2.max_length;
stats.linear_num <- stats1.linear_num +. stats2.linear_num stats.linear_num <- stats1.linear_num +. stats2.linear_num
end end
| Pcall (path1, pname, path2, stats) -> | Pcall (path1, _, path2, stats) ->
if stats_is_dummy stats then if stats_is_dummy stats then
begin begin
let stats2 = match do_calls with let stats2 = match do_calls with
@ -287,7 +287,7 @@ end = struct
(filter: Cfg.Node.t -> bool) (path: t) : unit = (filter: Cfg.Node.t -> bool) (path: t) : unit =
let rec doit level session path prev_exn_opt = match path with let rec doit level session path prev_exn_opt = match path with
| Pstart _ -> f level path session prev_exn_opt | Pstart _ -> f level path session prev_exn_opt
| Pnode (node, exn_opt, session', p, _, _) -> | Pnode (_, exn_opt, session', p, _, _) ->
let next_exn_opt = if prev_exn_opt <> None then None else exn_opt in (* no two consecutive exceptions *) let next_exn_opt = if prev_exn_opt <> None then None else exn_opt in (* no two consecutive exceptions *)
doit level session' p next_exn_opt; doit level session' p next_exn_opt;
f level path session prev_exn_opt f level path session prev_exn_opt
@ -328,7 +328,7 @@ end = struct
let sequence_up_to_last_seen = let sequence_up_to_last_seen =
if !position_seen then if !position_seen then
let rec remove_until_seen = function let rec remove_until_seen = function
| ((level, p, session, exn_opt) as x):: l -> | ((_, p, _, _) as x):: l ->
if path_pos_at_path p then IList.rev (x :: l) if path_pos_at_path p then IList.rev (x :: l)
else remove_until_seen l else remove_until_seen l
| [] -> [] in | [] -> [] in
@ -352,7 +352,7 @@ end = struct
end end
| None -> | None ->
() in () in
iter_longest_sequence (fun level p s exn_opt -> add_node (curr_node p)) None path; iter_longest_sequence (fun _ p _ _ -> add_node (curr_node p)) None path;
let max_rep_node = ref (Cfg.Node.dummy ()) in let max_rep_node = ref (Cfg.Node.dummy ()) in
let max_rep_num = ref 0 in let max_rep_num = ref 0 in
NodeMap.iter (fun node num -> if num > !max_rep_num then (max_rep_node := node; max_rep_num := num)) !map; NodeMap.iter (fun node num -> if num > !max_rep_num then (max_rep_node := node; max_rep_num := num)) !map;
@ -405,11 +405,15 @@ end = struct
let num = PathMap.find path !delayed in let num = PathMap.find path !delayed in
F.fprintf fmt "P%d" num F.fprintf fmt "P%d" num
with Not_found -> with Not_found ->
match path with match path with
| Pstart (node, _) -> F.fprintf fmt "n%a" Cfg.Node.pp node | Pstart (node, _) ->
| Pnode (node, exn_top, session, path, _, _) -> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path session Cfg.Node.pp node F.fprintf fmt "n%a" Cfg.Node.pp node
| Pjoin (path1, path2, _) -> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2 | Pnode (node, _, session, path, _, _) ->
| Pcall (path1, _, path2, _) -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 in F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path session Cfg.Node.pp node
| Pjoin (path1, path2, _) ->
F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2
| Pcall (path1, _, path2, _) ->
F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 in
let print_delayed () = let print_delayed () =
if not (PathMap.is_empty !delayed) then begin if not (PathMap.is_empty !delayed) then begin
let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in let f path num = F.fprintf fmt "P%d = %a@\n" num (doit 1) path in
@ -435,7 +439,7 @@ end = struct
Errlog.lt_loc = loc; Errlog.lt_loc = loc;
Errlog.lt_description = descr; Errlog.lt_description = descr;
Errlog.lt_node_tags = node_tags } in Errlog.lt_node_tags = node_tags } in
let g level path session exn_opt = let g level path _ exn_opt =
match curr_node path with match curr_node path with
| Some curr_node -> | Some curr_node ->
begin begin
@ -585,7 +589,7 @@ module PathSet : sig
end = struct end = struct
type t = Path.t PropMap.t type t = Path.t PropMap.t
let equal = PropMap.equal (fun p1 p2 -> true) (* only discriminate props, and ignore paths *) (* Path.equal *) let equal = PropMap.equal (fun _ _ -> true) (* only discriminate props, and ignore paths *)
let empty : t = PropMap.empty let empty : t = PropMap.empty
@ -668,7 +672,7 @@ end = struct
let size ps = let size ps =
let res = ref 0 in let res = ref 0 in
let add p _ = incr res in let add _ _ = incr res in
let () = PropMap.iter add ps let () = PropMap.iter add ps
in !res in !res

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

@ -19,7 +19,7 @@ module AllPreds = struct
NodeHash.clear preds_table NodeHash.clear preds_table
let mk_table cfg = let mk_table cfg =
let do_pdesc pname pdesc = let do_pdesc _ pdesc =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in let exit_node = Cfg.Procdesc.get_exit_node pdesc in
let add_edge is_exn nfrom nto = let add_edge is_exn nfrom nto =
if is_exn && Cfg.Node.equal nto exit_node then () if is_exn && Cfg.Node.equal nto exit_node then ()
@ -90,12 +90,12 @@ let rec use_exp cfg pdesc (exp: Sil.exp) acc =
and use_etl cfg pdesc (etl: (Sil.exp * Sil.typ) list) acc = and use_etl cfg pdesc (etl: (Sil.exp * Sil.typ) list) acc =
IList.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_instr cfg tenv (pdesc: Cfg.Procdesc.t) (instr: Sil.instr) acc = and use_instr cfg (pdesc: Cfg.Procdesc.t) (instr: Sil.instr) acc =
match instr with match instr with
| Sil.Set (_, _, e, _) | Sil.Set (_, _, e, _)
| Sil.Letderef (_, e, _, _) -> use_exp cfg pdesc e acc | Sil.Letderef (_, e, _, _) -> use_exp cfg pdesc e acc
| Sil.Prune (e, _, _, _) -> use_exp cfg pdesc e acc | Sil.Prune (e, _, _, _) -> use_exp cfg pdesc e acc
| Sil.Call (_, e, etl, _, _) -> use_etl cfg pdesc etl acc | Sil.Call (_, _, etl, _, _) -> use_etl cfg pdesc etl acc
| Sil.Nullify _ -> acc | Sil.Nullify _ -> acc
| Sil.Abstract _ | Sil.Remove_temps _ | Sil.Stackop _ | Sil.Declare_locals _ -> acc | Sil.Abstract _ | Sil.Remove_temps _ | Sil.Stackop _ | Sil.Declare_locals _ -> acc
| Sil.Goto_node (e, _) -> use_exp cfg pdesc e acc | Sil.Goto_node (e, _) -> use_exp cfg pdesc e acc
@ -144,11 +144,11 @@ let def_node cfg node acc =
| Cfg.Node.Stmt_node _ -> | Cfg.Node.Stmt_node _ ->
def_instrl cfg (Cfg.Node.get_instrs node) acc def_instrl cfg (Cfg.Node.get_instrs node) acc
let compute_live_instr cfg tenv pdesc s instr = let compute_live_instr cfg pdesc s instr =
use_instr cfg tenv pdesc instr (Vset.diff s (def_instr cfg instr Vset.empty)) use_instr cfg pdesc instr (Vset.diff s (def_instr cfg instr Vset.empty))
let compute_live_instrl cfg tenv pdesc instrs livel = let compute_live_instrl cfg pdesc instrs livel =
IList.fold_left (compute_live_instr cfg tenv pdesc) livel (IList.rev instrs) IList.fold_left (compute_live_instr cfg pdesc) livel (IList.rev instrs)
module Worklist = struct module Worklist = struct
module S = Cfg.NodeSet module S = Cfg.NodeSet
@ -226,7 +226,7 @@ let compute_candidates procdesc : Vset.t * (Vset.t -> Vset.elt list) =
!candidates, get_sorted_candidates !candidates, get_sorted_candidates
(** Construct a table wich associates to each node a set of live variables *) (** Construct a table wich associates to each node a set of live variables *)
let analyze_proc cfg tenv pdesc cand = let analyze_proc cfg pdesc cand =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in let exit_node = Cfg.Procdesc.get_exit_node pdesc in
Worklist.reset (); Worklist.reset ();
Table.reset (); Table.reset ();
@ -242,7 +242,7 @@ let analyze_proc cfg tenv pdesc cand =
| Cfg.Node.Start_node _ | Cfg.Node.Exit_node _ | Cfg.Node.Join_node | Cfg.Node.Skip_node _ -> curr_live | Cfg.Node.Start_node _ | Cfg.Node.Exit_node _ | Cfg.Node.Join_node | Cfg.Node.Skip_node _ -> curr_live
| Cfg.Node.Prune_node _ | Cfg.Node.Prune_node _
| Cfg.Node.Stmt_node _ -> | Cfg.Node.Stmt_node _ ->
compute_live_instrl cfg tenv pdesc (Cfg.Node.get_instrs node) curr_live in compute_live_instrl cfg pdesc (Cfg.Node.get_instrs node) curr_live in
Table.propagate_to_preds (Vset.inter live_at_predecessors cand) preds Table.propagate_to_preds (Vset.inter live_at_predecessors cand) preds
done done
with Not_found -> () with Not_found -> ()
@ -310,7 +310,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
(** Find the set of dead variables for the procedure pname and add nullify instructions. (** Find the set of dead variables for the procedure pname and add nullify instructions.
The variables that are possibly aliased are only considered just before the exit node. *) The variables that are possibly aliased are only considered just before the exit node. *)
let analyze_and_annotate_proc cfg tenv pname pdesc = let analyze_and_annotate_proc cfg pname pdesc =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in let exit_node = Cfg.Procdesc.get_exit_node pdesc in
let exit_node_is_succ node = let exit_node_is_succ node =
match Cfg.Node.get_succs node with match Cfg.Node.get_succs node with
@ -319,7 +319,7 @@ let analyze_and_annotate_proc cfg tenv pname pdesc =
let cand, get_sorted_cand = compute_candidates pdesc in let cand, get_sorted_cand = compute_candidates pdesc in
aliased_var:= Vset.empty; aliased_var:= Vset.empty;
captured_var:= Vset.empty; captured_var:= Vset.empty;
analyze_proc cfg tenv pdesc cand; (* as side effect it coputes the set aliased_var *) analyze_proc cfg pdesc cand; (* as side effect it coputes the set aliased_var *)
(* print_aliased_var "@.@.Aliased variable computed: " !aliased_var; (* print_aliased_var "@.@.Aliased variable computed: " !aliased_var;
L.out " PROCEDURE %s@." (Procname.to_string pname); *) L.out " PROCEDURE %s@." (Procname.to_string pname); *)
let dead_pvars_added = ref 0 in let dead_pvars_added = ref 0 in
@ -383,7 +383,7 @@ let add_dispatch_calls cfg cg tenv f_translate_typ_opt =
IList.exists instr_is_dispatch_call instrs in IList.exists instr_is_dispatch_call instrs in
let replace_dispatch_calls = function let replace_dispatch_calls = function
| Sil.Call (ret_ids, (Sil.Const (Sil.Cfun callee_pname) as call_exp), | Sil.Call (ret_ids, (Sil.Const (Sil.Cfun callee_pname) as call_exp),
(((receiver_exp, receiver_typ) :: _) as args), loc, call_flags) as instr (((_, receiver_typ) :: _) as args), loc, call_flags) as instr
when call_flags_is_dispatch call_flags -> when call_flags_is_dispatch call_flags ->
(* the frontend should not populate the list of targets *) (* the frontend should not populate the list of targets *)
assert (call_flags.Sil.cf_targets = []); assert (call_flags.Sil.cf_targets = []);
@ -392,7 +392,7 @@ let add_dispatch_calls cfg cg tenv f_translate_typ_opt =
let overrides = Prover.get_overrides_of tenv receiver_typ_no_ptr callee_pname in let overrides = Prover.get_overrides_of tenv receiver_typ_no_ptr callee_pname in
IList.sort (fun (_, p1) (_, p2) -> Procname.compare p1 p2) overrides in IList.sort (fun (_, p1) (_, p2) -> Procname.compare p1 p2) overrides in
(match sorted_overrides with (match sorted_overrides with
| ((_, target_pname) :: targets) as all_targets -> | ((_, target_pname) :: _) as all_targets ->
let targets_to_add = let targets_to_add =
if Config.sound_dynamic_dispatch then if Config.sound_dynamic_dispatch then
IList.map snd all_targets IList.map snd all_targets
@ -420,7 +420,7 @@ let add_dispatch_calls cfg cg tenv f_translate_typ_opt =
let doit ?(f_translate_typ=None) cfg cg tenv = let doit ?(f_translate_typ=None) cfg cg tenv =
AllPreds.mk_table cfg; AllPreds.mk_table cfg;
Cfg.iter_proc_desc cfg (analyze_and_annotate_proc cfg tenv); Cfg.iter_proc_desc cfg (analyze_and_annotate_proc cfg);
AllPreds.clear_table (); AllPreds.clear_table ();
if !Config.curr_language = Config.Java if !Config.curr_language = Config.Java
then add_dispatch_calls cfg cg tenv f_translate_typ; then add_dispatch_calls cfg cg tenv f_translate_typ;

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

@ -289,7 +289,7 @@ let proc_write_log whole_seconds cfg pname =
(** Creare a hash table mapping line numbers to the set of errors occurring on that line *) (** Creare a hash table mapping line numbers to the set of errors occurring on that line *)
let create_errors_per_line err_log = let create_errors_per_line err_log =
let err_per_line = Hashtbl.create 17 in let err_per_line = Hashtbl.create 17 in
let add_err node_id_key loc ml_loc_opt ekind in_footprint err_name desc severity ltr pre_opt eclass = let add_err _ loc _ _ _ err_name desc _ _ _ _ =
let err_str = Localise.to_string err_name ^ " " ^ (pp_to_string Localise.pp_error_desc desc) in let err_str = Localise.to_string err_name ^ " " ^ (pp_to_string Localise.pp_error_desc desc) in
try try
let set = Hashtbl.find err_per_line loc.Location.line in let set = Hashtbl.find err_per_line loc.Location.line in
@ -373,7 +373,7 @@ end = struct
end end
(** Create filename.c.html with line numbers and links to nodes *) (** Create filename.c.html with line numbers and links to nodes *)
let c_file_write_html proc_is_active linereader fname tenv cfg = let c_file_write_html proc_is_active linereader fname cfg =
let proof_cover = ref Specs.Visitedset.empty in let proof_cover = ref Specs.Visitedset.empty in
let tbl = Hashtbl.create 11 in let tbl = Hashtbl.create 11 in
let process_node n = let process_node n =

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

@ -142,8 +142,8 @@ let java_sig_compare (js1: java_signature) (js2 : java_signature) =
let c_function_mangled_compare mangled1 mangled2 = let c_function_mangled_compare mangled1 mangled2 =
match mangled1, mangled2 with match mangled1, mangled2 with
| Some mangled1, None -> 1 | Some _, None -> 1
| None, Some mangled2 -> -1 | None, Some _ -> -1
| None, None -> 0 | None, None -> 0
| Some mangled1, Some mangled2 -> | Some mangled1, Some mangled2 ->
string_compare mangled1 mangled2 string_compare mangled1 mangled2
@ -328,7 +328,7 @@ let java_is_anonymous_inner_class = function
let java_remove_hidden_inner_class_parameter = function let java_remove_hidden_inner_class_parameter = function
| Java_method js -> | Java_method js ->
(match IList.rev js.parameters with (match IList.rev js.parameters with
| (so, s) :: par' -> | (_, s) :: par' ->
if is_anonymous_inner_class_name s if is_anonymous_inner_class_name s
then Some (Java_method { js with parameters = IList.rev par'}) then Some (Java_method { js with parameters = IList.rev par'})
else None else None
@ -388,7 +388,7 @@ let is_class_initializer = function
(** [is_infer_undefined pn] returns true if [pn] is a special Infer undefined proc *) (** [is_infer_undefined pn] returns true if [pn] is a special Infer undefined proc *)
let is_infer_undefined pn = match pn with let is_infer_undefined pn = match pn with
| Java_method j -> | Java_method _ ->
let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in
Str.string_match regexp (java_get_class pn) 0 Str.string_match regexp (java_get_class pn) 0
| _ -> | _ ->
@ -439,7 +439,7 @@ let to_simplified_string ?(withclass = false) p =
| C_function (c1, c2) -> | C_function (c1, c2) ->
to_readable_string (c1, c2) false ^ "()" to_readable_string (c1, c2) false ^ "()"
| ObjC_Cpp_method osig -> c_method_to_string osig Simple | ObjC_Cpp_method osig -> c_method_to_string osig Simple
| ObjC_block name -> "block" | ObjC_block _ -> "block"
(** Convert a proc name to a filename *) (** Convert a proc name to a filename *)
let to_filename (pn : proc_name) = let to_filename (pn : proc_name) =

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

@ -110,12 +110,12 @@ let pp_texp_simple pe = match pe.pe_opt with
| PP_SIM_WITH_TYP -> Sil.pp_texp_full pe | PP_SIM_WITH_TYP -> Sil.pp_texp_full pe
(** Pretty print a pointsto representing a stack variable as an equality *) (** Pretty print a pointsto representing a stack variable as an equality *)
let pp_hpred_stackvar pe0 env f hpred = let pp_hpred_stackvar pe0 f hpred =
let pe, changed = Sil.color_pre_wrapper pe0 f hpred in let pe, changed = Sil.color_pre_wrapper pe0 f hpred in
begin match hpred with begin match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, se, te) -> | Sil.Hpointsto (Sil.Lvar pvar, se, te) ->
let pe' = match se with let pe' = match se with
| Sil.Eexp (Sil.Var id, inst) when not (Sil.pvar_is_global pvar) -> | Sil.Eexp (Sil.Var _, _) when not (Sil.pvar_is_global pvar) ->
{ pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *) { pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *)
| _ -> pe in | _ -> pe in
(match pe'.pe_kind with (match pe'.pe_kind with
@ -177,7 +177,7 @@ let pp_sigma_simple pe env fmt sigma =
let sigma_stack, sigma_nonstack = sigma_get_stack_nonstack false sigma in let sigma_stack, sigma_nonstack = sigma_get_stack_nonstack false sigma in
let pp_stack fmt _sg = let pp_stack fmt _sg =
let sg = IList.sort Sil.hpred_compare _sg in let sg = IList.sort Sil.hpred_compare _sg in
if sg != [] then Format.fprintf fmt "%a" (pp_semicolon_seq pe (pp_hpred_stackvar pe env)) sg in if sg != [] then Format.fprintf fmt "%a" (pp_semicolon_seq pe (pp_hpred_stackvar pe)) sg in
let pp_nl fmt doit = if doit then let pp_nl fmt doit = if doit then
(match pe.pe_kind with (match pe.pe_kind with
| PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n" | PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n"
@ -238,13 +238,13 @@ let pp_hpara_dll_simple _pe env n f pred =
let create_pvar_env (sigma: sigma) : (Sil.exp -> Sil.exp) = let create_pvar_env (sigma: sigma) : (Sil.exp -> Sil.exp) =
let env = ref [] in let env = ref [] in
let filter = function let filter = function
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (Sil.Var v, inst), _) -> | Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (Sil.Var v, _), _) ->
if not (Sil.pvar_is_global pvar) then env := (Sil.Var v, Sil.Lvar pvar) :: !env if not (Sil.pvar_is_global pvar) then env := (Sil.Var v, Sil.Lvar pvar) :: !env
| _ -> () in | _ -> () in
IList.iter filter sigma; IList.iter filter sigma;
let find e = let find e =
try try
snd (IList.find (fun (e1, e2) -> Sil.exp_equal e1 e) !env) snd (IList.find (fun (e1, _) -> Sil.exp_equal e1 e) !env)
with Not_found -> e in with Not_found -> e in
find find
@ -287,7 +287,7 @@ let pp_prop pe0 f prop =
let env = prop_pred_env prop in let env = prop_pred_env prop in
let iter_f n hpara = F.fprintf f "@,@[<h>%a@]" (pp_hpara_simple pe env n) hpara in let iter_f n hpara = F.fprintf f "@,@[<h>%a@]" (pp_hpara_simple pe env n) hpara in
let iter_f_dll n hpara_dll = F.fprintf f "@,@[<h>%a@]" (pp_hpara_dll_simple pe env n) hpara_dll in let iter_f_dll n hpara_dll = F.fprintf f "@,@[<h>%a@]" (pp_hpara_dll_simple pe env n) hpara_dll in
let pp_predicates fmt () = let pp_predicates _ () =
if Sil.Predicates.is_empty env if Sil.Predicates.is_empty env
then () then ()
else if latex then else if latex then
@ -573,7 +573,7 @@ let sym_eval abs e =
eval (Sil.BinOp (Sil.PlusPI, e11, e2')) eval (Sil.BinOp (Sil.PlusPI, e11, e2'))
| Sil.BinOp | Sil.BinOp
(Sil.PlusA, (Sil.PlusA,
(Sil.Sizeof (Sil.Tstruct struct_typ, st) as e1), (Sil.Sizeof (Sil.Tstruct struct_typ, _) as e1),
e2) -> e2) ->
(* pattern for extensible structs given a struct declatead as struct s { ... t arr[n] ... }, (* pattern for extensible structs given a struct declatead as struct s { ... t arr[n] ... },
allocation pattern malloc(sizeof(struct s) + k * siezof(t)) turn it into allocation pattern malloc(sizeof(struct s) + k * siezof(t)) turn it into
@ -698,7 +698,7 @@ let sym_eval abs e =
Sil.exp_int (Sil.Int.mul n m) Sil.exp_int (Sil.Int.mul n m)
| Sil.Const (Sil.Cfloat v), Sil.Const (Sil.Cfloat w) -> | Sil.Const (Sil.Cfloat v), Sil.Const (Sil.Cfloat w) ->
Sil.exp_float (v *. w) Sil.exp_float (v *. w)
| Sil.Var v, Sil.Var w -> | Sil.Var _, Sil.Var _ ->
Sil.BinOp(Sil.Mult, e1', e2') Sil.BinOp(Sil.Mult, e1', e2')
| _, _ -> | _, _ ->
if abs then Sil.exp_get_undefined false else Sil.BinOp(Sil.Mult, e1', e2') if abs then Sil.exp_get_undefined false else Sil.BinOp(Sil.Mult, e1', e2')
@ -841,7 +841,7 @@ and typ_normalize sub typ = match typ with
} }
| Sil.Tarray (t, e) -> | Sil.Tarray (t, e) ->
Sil.Tarray (typ_normalize sub t, exp_normalize sub e) Sil.Tarray (typ_normalize sub t, exp_normalize sub e)
| Sil.Tenum econsts -> | Sil.Tenum _ ->
typ typ
let run_with_abs_val_eq_zero f = let run_with_abs_val_eq_zero f =
@ -1003,7 +1003,7 @@ let atom_normalize sub a0 =
(e1, Sil.exp_int (n1 ++ n2)) (e1, Sil.exp_int (n1 ++ n2))
| Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n1), e1), Sil.Const (Sil.Cint n2) -> (* n1-e1 == n2 -> e1==n1-n2 *) | Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n1), e1), Sil.Const (Sil.Cint n2) -> (* n1-e1 == n2 -> e1==n1-n2 *)
(e1, Sil.exp_int (n1 -- n2)) (e1, Sil.exp_int (n1 -- n2))
| Sil.Lfield (e1', fld1, typ1), Sil.Lfield (e2', fld2, typ2) -> | Sil.Lfield (e1', fld1, _), Sil.Lfield (e2', fld2, _) ->
if Sil.fld_equal fld1 fld2 if Sil.fld_equal fld1 fld2
then normalize_eq (e1', e2') then normalize_eq (e1', e2')
else eq else eq
@ -1132,9 +1132,9 @@ let mk_ptsto lexp sexp te =
base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *) base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
let mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred = let mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred =
let default_strexp () = match te with let default_strexp () = match te with
| Sil.Sizeof (typ, st) -> | Sil.Sizeof (typ, _) ->
create_strexp_of_type tenvo struct_init_mode typ inst create_strexp_of_type tenvo struct_init_mode typ inst
| Sil.Var id -> | Sil.Var _ ->
Sil.Estruct ([], inst) Sil.Estruct ([], inst)
| te -> | te ->
L.err "trying to create ptsto with type: %a@\n@." (Sil.pp_texp_full pe_text) te; L.err "trying to create ptsto with type: %a@\n@." (Sil.pp_texp_full pe_text) te;
@ -1161,14 +1161,19 @@ let rec hpred_normalize sub hpred =
let normalized_cnt = strexp_normalize sub cnt in let normalized_cnt = strexp_normalize sub cnt in
let normalized_te = texp_normalize sub te in let normalized_te = texp_normalize sub te in
begin match normalized_cnt, normalized_te with begin match normalized_cnt, normalized_te with
| Sil.Earray (Sil.Sizeof (t, st1), [], inst), Sil.Sizeof (Sil.Tarray _, st2) -> | Sil.Earray (Sil.Sizeof (t, st1), [], inst), Sil.Sizeof (Sil.Tarray _, _) ->
(* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *) (* check for an empty array whose size expression is (Sizeof type), and turn the array
into a strexp of the given type *)
let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (t, st1), None) inst in let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (t, st1), None) inst in
replace_hpred hpred' replace_hpred hpred'
| Sil.Earray (Sil.BinOp(Sil.Mult, Sil.Sizeof (t, st1), x), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) | Sil.Earray (Sil.BinOp(Sil.Mult, Sil.Sizeof (t, st1), x), esel, inst),
| Sil.Earray (Sil.BinOp(Sil.Mult, x, Sil.Sizeof (t, st1)), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) -> Sil.Sizeof (Sil.Tarray _, _)
(* check for an array whose size expression is n * (Sizeof type), and turn the array into a strexp of the given type *) | Sil.Earray (Sil.BinOp(Sil.Mult, x, Sil.Sizeof (t, st1)), esel, inst),
let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (Sil.Tarray(t, x), st1), None) inst in Sil.Sizeof (Sil.Tarray _, _) ->
(* check for an array whose size expression is n * (Sizeof type), and turn the array
into a strexp of the given type *)
let hpred' =
mk_ptsto_exp None Fld_init (root, Sil.Sizeof (Sil.Tarray(t, x), st1), None) inst in
replace_hpred (replace_array_contents hpred' esel) replace_hpred (replace_array_contents hpred' esel)
| _ -> Sil.Hpointsto (normalized_root, normalized_cnt, normalized_te) | _ -> Sil.Hpointsto (normalized_root, normalized_cnt, normalized_te)
end end
@ -1176,7 +1181,7 @@ let rec hpred_normalize sub hpred =
let normalized_e1 = exp_normalize sub e1 in let normalized_e1 = exp_normalize sub e1 in
let normalized_e2 = exp_normalize sub e2 in let normalized_e2 = exp_normalize sub e2 in
let normalized_elist = IList.map (exp_normalize sub) elist in let normalized_elist = IList.map (exp_normalize sub) elist in
let normalized_para = hpara_normalize sub para in let normalized_para = hpara_normalize para in
Sil.Hlseg (k, normalized_para, normalized_e1, normalized_e2, normalized_elist) Sil.Hlseg (k, normalized_para, normalized_e1, normalized_e2, normalized_elist)
| Sil.Hdllseg (k, para, e1, e2, e3, e4, elist) -> | Sil.Hdllseg (k, para, e1, e2, e3, e4, elist) ->
let norm_e1 = exp_normalize sub e1 in let norm_e1 = exp_normalize sub e1 in
@ -1184,15 +1189,15 @@ let rec hpred_normalize sub hpred =
let norm_e3 = exp_normalize sub e3 in let norm_e3 = exp_normalize sub e3 in
let norm_e4 = exp_normalize sub e4 in let norm_e4 = exp_normalize sub e4 in
let norm_elist = IList.map (exp_normalize sub) elist in let norm_elist = IList.map (exp_normalize sub) elist in
let norm_para = hpara_dll_normalize sub para in let norm_para = hpara_dll_normalize para in
Sil.Hdllseg (k, norm_para, norm_e1, norm_e2, norm_e3, norm_e4, norm_elist) Sil.Hdllseg (k, norm_para, norm_e1, norm_e2, norm_e3, norm_e4, norm_elist)
and hpara_normalize sub para = and hpara_normalize para =
let normalized_body = IList.map (hpred_normalize Sil.sub_empty) (para.Sil.body) in let normalized_body = IList.map (hpred_normalize Sil.sub_empty) (para.Sil.body) in
let sorted_body = IList.sort Sil.hpred_compare normalized_body in let sorted_body = IList.sort Sil.hpred_compare normalized_body in
{ para with Sil.body = sorted_body } { para with Sil.body = sorted_body }
and hpara_dll_normalize sub para = and hpara_dll_normalize para =
let normalized_body = IList.map (hpred_normalize Sil.sub_empty) (para.Sil.body_dll) in let normalized_body = IList.map (hpred_normalize Sil.sub_empty) (para.Sil.body_dll) in
let sorted_body = IList.sort Sil.hpred_compare normalized_body in let sorted_body = IList.sort Sil.hpred_compare normalized_body in
{ para with Sil.body_dll = sorted_body } { para with Sil.body_dll = sorted_body }
@ -1302,7 +1307,7 @@ let pi_normalize sub sigma pi0 =
not (syntactically_different (e1, e2)) not (syntactically_different (e1, e2))
| Sil.Aeq(Sil.Const c1, Sil.Const c2) -> | Sil.Aeq(Sil.Const c1, Sil.Const c2) ->
not (Sil.const_equal c1 c2) not (Sil.const_equal c1 c2)
| a -> true in | _ -> true in
let pi' = IList.stable_sort Sil.atom_compare ((IList.filter filter_useful_atom nonineq_list) @ ineq_list) in let pi' = IList.stable_sort Sil.atom_compare ((IList.filter filter_useful_atom nonineq_list) @ ineq_list) in
let pi'' = pi_sorted_remove_redundant pi' in let pi'' = pi_sorted_remove_redundant pi' in
if pi_equal pi0 pi'' then pi0 else pi'' if pi_equal pi0 pi'' then pi0 else pi''
@ -1359,7 +1364,7 @@ let lexp_normalize_prop p lexp =
(** Collapse consecutive indices that should be added. For instance, (** Collapse consecutive indices that should be added. For instance,
this function reduces x[1][1] to x[2]. The [typ] argument is used this function reduces x[1][1] to x[2]. The [typ] argument is used
to ensure the soundness of this collapsing. *) to ensure the soundness of this collapsing. *)
let exp_collapse_consecutive_indices_prop p typ exp = let exp_collapse_consecutive_indices_prop typ exp =
let typ_is_base = function let typ_is_base = function
| Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true | Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true
| _ -> false in | _ -> false in
@ -1457,23 +1462,23 @@ let mk_ptsto_lvar tenv expand_structs inst ((pvar: Sil.pvar), texp, expo) : Sil.
(** Sil.Construct a lseg predicate *) (** Sil.Construct a lseg predicate *)
let mk_lseg k para e_start e_end es_shared = let mk_lseg k para e_start e_end es_shared =
let npara = hpara_normalize Sil.sub_empty para in let npara = hpara_normalize para in
Sil.Hlseg (k, npara, e_start, e_end, es_shared) Sil.Hlseg (k, npara, e_start, e_end, es_shared)
(** Sil.Construct a dllseg predicate *) (** Sil.Construct a dllseg predicate *)
let mk_dllseg k para exp_iF exp_oB exp_oF exp_iB exps_shared = let mk_dllseg k para exp_iF exp_oB exp_oF exp_iB exps_shared =
let npara = hpara_dll_normalize Sil.sub_empty para in let npara = hpara_dll_normalize para in
Sil.Hdllseg (k, npara, exp_iF, exp_oB , exp_oF, exp_iB, exps_shared) Sil.Hdllseg (k, npara, exp_iF, exp_oB , exp_oF, exp_iB, exps_shared)
(** Sil.Construct a hpara *) (** Sil.Construct a hpara *)
let mk_hpara root next svars evars body = let mk_hpara root next svars evars body =
let para = { Sil.root = root; Sil.next = next; Sil.svars = svars; Sil.evars = evars; Sil.body = body } in let para = { Sil.root = root; Sil.next = next; Sil.svars = svars; Sil.evars = evars; Sil.body = body } in
hpara_normalize Sil.sub_empty para hpara_normalize para
(** Sil.Construct a dll_hpara *) (** Sil.Construct a dll_hpara *)
let mk_dll_hpara iF oB oF svars evars body = let mk_dll_hpara iF oB oF svars evars body =
let para = { Sil.cell = iF; Sil.blink = oB; Sil.flink = oF; Sil.svars_dll = svars; Sil.evars_dll = evars; Sil.body_dll = body } in let para = { Sil.cell = iF; Sil.blink = oB; Sil.flink = oF; Sil.svars_dll = svars; Sil.evars_dll = evars; Sil.body_dll = body } in
hpara_dll_normalize Sil.sub_empty para hpara_dll_normalize para
(** Proposition [true /\ emp]. *) (** Proposition [true /\ emp]. *)
let prop_emp : normal t = let prop_emp : normal t =
@ -1536,7 +1541,7 @@ let get_fld_typ_path_opt src_exps snk_exp_ reachable_hpreds_ =
| (_, Sil.Eexp (e, _)) -> Sil.exp_equal target_exp e | (_, Sil.Eexp (e, _)) -> Sil.exp_equal target_exp e
| _ -> false in | _ -> false in
let extend_path hpred (snk_exp, path, reachable_hpreds) = match hpred with let extend_path hpred (snk_exp, path, reachable_hpreds) = match hpred with
| Sil.Hpointsto (lhs, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) -> | Sil.Hpointsto (lhs, Sil.Estruct (flds, _), Sil.Sizeof (typ, _)) ->
(try (try
let fld, _ = IList.find (fun fld -> strexp_matches snk_exp fld) flds in let fld, _ = IList.find (fun fld -> strexp_matches snk_exp fld) flds in
let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in
@ -1838,8 +1843,8 @@ let mark_vars_as_undefined prop vars_to_mark callee_pname loc path_pos =
(** Remove an attribute from all the atoms in the heap *) (** Remove an attribute from all the atoms in the heap *)
let remove_attribute att prop = let remove_attribute att prop =
let atom_remove atom pi = match atom with let atom_remove atom pi = match atom with
| Sil.Aneq (e, Sil.Const (Sil.Cattribute att_old)) | Sil.Aneq (_, Sil.Const (Sil.Cattribute att_old))
| Sil.Aneq (Sil.Const (Sil.Cattribute att_old), e) -> | Sil.Aneq (Sil.Const (Sil.Cattribute att_old), _) ->
if Sil.attribute_equal att_old att then if Sil.attribute_equal att_old att then
pi pi
else atom:: pi else atom:: pi
@ -1862,7 +1867,7 @@ let remove_attribute_from_exp att prop exp =
(* Replace an attribute OBJC_NULL($n1) with OBJC_NULL(var) when var = $n1, and also sets $n1 = 0 *) (* Replace an attribute OBJC_NULL($n1) with OBJC_NULL(var) when var = $n1, and also sets $n1 = 0 *)
let replace_objc_null prop lhs_exp rhs_exp = let replace_objc_null prop lhs_exp rhs_exp =
match get_objc_null_attribute prop rhs_exp, rhs_exp with match get_objc_null_attribute prop rhs_exp, rhs_exp with
| Some att, Sil.Var var -> | Some att, Sil.Var _ ->
let prop = remove_attribute_from_exp att prop rhs_exp in let prop = remove_attribute_from_exp att prop rhs_exp in
let prop = conjoin_eq rhs_exp Sil.exp_zero prop in let prop = conjoin_eq rhs_exp Sil.exp_zero prop in
add_or_replace_exp_attribute prop lhs_exp att add_or_replace_exp_attribute prop lhs_exp att
@ -1870,12 +1875,12 @@ let replace_objc_null prop lhs_exp rhs_exp =
let rec nullify_exp_with_objc_null prop exp = let rec nullify_exp_with_objc_null prop exp =
match exp with match exp with
| Sil.BinOp (op, exp1, exp2) -> | Sil.BinOp (_, exp1, exp2) ->
let prop' = nullify_exp_with_objc_null prop exp1 in let prop' = nullify_exp_with_objc_null prop exp1 in
nullify_exp_with_objc_null prop' exp2 nullify_exp_with_objc_null prop' exp2
| Sil.UnOp (op, exp, _) -> | Sil.UnOp (_, exp, _) ->
nullify_exp_with_objc_null prop exp nullify_exp_with_objc_null prop exp
| Sil.Var name -> | Sil.Var _ ->
(match get_objc_null_attribute prop exp with (match get_objc_null_attribute prop exp with
| Some att -> | Some att ->
let prop' = remove_attribute_from_exp att prop exp in let prop' = remove_attribute_from_exp att prop exp in
@ -2037,10 +2042,10 @@ let sigma_dfs_sort sigma =
let final () = ExpStack.final () in let final () = ExpStack.final () in
let rec handle_strexp = function let rec handle_strexp = function
| Sil.Eexp (e, inst) -> ExpStack.push e | Sil.Eexp (e, _) -> ExpStack.push e
| Sil.Estruct (fld_se_list, inst) -> | Sil.Estruct (fld_se_list, _) ->
IList.iter (fun (_, se) -> handle_strexp se) fld_se_list IList.iter (fun (_, se) -> handle_strexp se) fld_se_list
| Sil.Earray (_, idx_se_list, inst) -> | Sil.Earray (_, idx_se_list, _) ->
IList.iter (fun (_, se) -> handle_strexp se) idx_se_list in IList.iter (fun (_, se) -> handle_strexp se) idx_se_list in
let rec handle_e visited seen e = function let rec handle_e visited seen e = function
@ -2092,10 +2097,10 @@ let prop_fav_add_dfs fav prop =
let rec strexp_get_array_indices acc = function let rec strexp_get_array_indices acc = function
| Sil.Eexp _ -> acc | Sil.Eexp _ -> acc
| Sil.Estruct (fsel, inst) -> | Sil.Estruct (fsel, _) ->
let se_list = IList.map snd fsel in let se_list = IList.map snd fsel in
IList.fold_left strexp_get_array_indices acc se_list IList.fold_left strexp_get_array_indices acc se_list
| Sil.Earray (size, isel, _) -> | Sil.Earray (_, isel, _) ->
let acc_new = IList.fold_left (fun acc' (idx, _) -> idx:: acc') acc isel in let acc_new = IList.fold_left (fun acc' (idx, _) -> idx:: acc') acc isel in
let se_list = IList.map snd isel in let se_list = IList.map snd isel in
IList.fold_left strexp_get_array_indices acc_new se_list IList.fold_left strexp_get_array_indices acc_new se_list
@ -2245,7 +2250,7 @@ and typ_captured_ren ren typ = match typ with
Sil.Tptr (typ_captured_ren ren t', pk) Sil.Tptr (typ_captured_ren ren t', pk)
| Sil.Tarray (t, e) -> | Sil.Tarray (t, e) ->
Sil.Tarray (typ_captured_ren ren t, exp_captured_ren ren e) Sil.Tarray (typ_captured_ren ren t, exp_captured_ren ren e)
| Sil.Tenum econsts -> | Sil.Tenum _ ->
typ typ
let atom_captured_ren ren = function let atom_captured_ren ren = function
@ -2600,7 +2605,7 @@ let prop_iter_make_id_primed id iter =
let rec get_eqs acc = function let rec get_eqs acc = function
| [] | [_] -> | [] | [_] ->
IList.rev acc IList.rev acc
| (_, e1) :: (((_, e2) :: pairs') as pairs) -> | (_, e1) :: (((_, e2) :: _) as pairs) ->
get_eqs (Sil.Aeq(e1, e2):: acc) pairs in get_eqs (Sil.Aeq(e1, e2):: acc) pairs in
let sub_new, sub_use, eqs_add = let sub_new, sub_use, eqs_add =

2
infer/src/backend/prop.mli
Unescape View File

@ -176,7 +176,7 @@ val exp_normalize_noabs : Sil.subst -> Sil.exp -> Sil.exp
(** Collapse consecutive indices that should be added. For instance, (** Collapse consecutive indices that should be added. For instance,
this function reduces x[1][1] to x[2]. The [typ] argument is used this function reduces x[1][1] to x[2]. The [typ] argument is used
to ensure the soundness of this collapsing. *) to ensure the soundness of this collapsing. *)
val exp_collapse_consecutive_indices_prop : 'a t -> Sil.typ -> Sil.exp -> Sil.exp val exp_collapse_consecutive_indices_prop : Sil.typ -> Sil.exp -> Sil.exp
(** Normalize [exp] used for the address of a heap cell. (** Normalize [exp] used for the address of a heap cell.
This normalization does not combine two offsets inside [exp]. *) This normalization does not combine two offsets inside [exp]. *)

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

@ -31,7 +31,7 @@ let rec is_root = function
| Sil.UnOp _ | Sil.BinOp _ | Sil.Lfield _ | Sil.Lindex _ | Sil.Sizeof _ -> false | Sil.UnOp _ | Sil.BinOp _ | Sil.Lfield _ | Sil.Lindex _ | Sil.Sizeof _ -> false
(** Return [true] if the nodes are connected. Used to compute reachability. *) (** Return [true] if the nodes are connected. Used to compute reachability. *)
let nodes_connected g n1 n2 = let nodes_connected n1 n2 =
Sil.exp_equal n1 n2 (* Implemented as equality for now, later it might contain offset by a constant *) Sil.exp_equal n1 n2 (* Implemented as equality for now, later it might contain offset by a constant *)
(** Return [true] if the edge is an hpred, and [false] if it is an atom *) (** Return [true] if the edge is an hpred, and [false] if it is an atom *)
@ -44,17 +44,17 @@ let edge_is_hpred = function
let edge_get_source = function let edge_get_source = function
| Ehpred (Sil.Hpointsto(e, _, _)) -> e | Ehpred (Sil.Hpointsto(e, _, _)) -> e
| Ehpred (Sil.Hlseg(_, _, e, _, _)) -> e | Ehpred (Sil.Hlseg(_, _, e, _, _)) -> e
| Ehpred (Sil.Hdllseg(_, _, e1, _, _, e2, _)) -> e1 (* :: e2 only one direction supported for now *) | Ehpred (Sil.Hdllseg(_, _, e1, _, _, _, _)) -> e1 (* only one direction supported for now *)
| Eatom (Sil.Aeq (e1, _)) -> e1 | Eatom (Sil.Aeq (e1, _)) -> e1
| Eatom (Sil.Aneq (e1, _)) -> e1 | Eatom (Sil.Aneq (e1, _)) -> e1
| Esub_entry (x, e) -> Sil.Var x | Esub_entry (x, _) -> Sil.Var x
(** Return the successor nodes of the edge *) (** Return the successor nodes of the edge *)
let edge_get_succs = function let edge_get_succs = function
| Ehpred hpred -> Sil.ExpSet.elements (Prop.hpred_get_targets hpred) | Ehpred hpred -> Sil.ExpSet.elements (Prop.hpred_get_targets hpred)
| Eatom (Sil.Aeq (_, e2)) -> [e2] | Eatom (Sil.Aeq (_, e2)) -> [e2]
| Eatom (Sil.Aneq (_, e2)) -> [e2] | Eatom (Sil.Aneq (_, e2)) -> [e2]
| Esub_entry (s, e) -> [e] | Esub_entry (_, e) -> [e]
let get_sigma footprint_part g = let get_sigma footprint_part g =
if footprint_part then Prop.get_sigma_footprint g else Prop.get_sigma g if footprint_part then Prop.get_sigma_footprint g else Prop.get_sigma g
@ -120,7 +120,7 @@ let compute_exp_diff (e1: Sil.exp) (e2: Sil.exp) : Obj.t list =
(** Compute the subobjects in [se2] which are different from those in [se1] *) (** Compute the subobjects in [se2] which are different from those in [se1] *)
let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list = match se1, se2 with let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list = match se1, se2 with
| Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) -> if Sil.exp_equal e1 e2 then [] else [Obj.repr se2] | Sil.Eexp (e1, _), Sil.Eexp (e2, _) -> if Sil.exp_equal e1 e2 then [] else [Obj.repr se2]
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) -> | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) ->
compute_fsel_diff fsel1 fsel2 compute_fsel_diff fsel1 fsel2
| Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _) -> | Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _) ->

2
infer/src/backend/propgraph.mli
Unescape View File

@ -23,7 +23,7 @@ val from_prop : Prop.normal Prop.t -> t
val is_root : node -> bool val is_root : node -> bool
(** Return [true] if the nodes are connected. Used to compute reachability. *) (** Return [true] if the nodes are connected. Used to compute reachability. *)
val nodes_connected : t -> node -> node -> bool val nodes_connected : node -> node -> bool
(** Return the source of the edge *) (** Return the source of the edge *)
val edge_get_source : edge -> node val edge_get_source : edge -> node

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

@ -546,7 +546,7 @@ let is_root prop base_exp exp =
if check_equal prop base_exp e if check_equal prop base_exp e
then Some offlist_past then Some offlist_past
else None else None
| Sil.Cast(t, sub_exp) -> f offlist_past sub_exp | Sil.Cast(_, sub_exp) -> f offlist_past sub_exp
| Sil.Lfield(sub_exp, fldname, typ) -> f (Sil.Off_fld (fldname, typ) :: offlist_past) sub_exp | Sil.Lfield(sub_exp, fldname, typ) -> f (Sil.Off_fld (fldname, typ) :: offlist_past) sub_exp
| Sil.Lindex(sub_exp, e) -> f (Sil.Off_index e :: offlist_past) sub_exp | Sil.Lindex(sub_exp, e) -> f (Sil.Off_index e :: offlist_past) sub_exp
in f [] exp in f [] exp
@ -623,14 +623,14 @@ let check_disequal prop e1 e2 =
else else
let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest') in f [] e2 sigma_rest')
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, oB, oF, iB, _) :: sigma_rest -> | Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest ->
if is_root prop iF e != None || is_root prop iB e != None then if is_root prop iF e != None || is_root prop iB e != None then
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant') in Some (true, sigma_irrelevant')
else else
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant') in Some (false, sigma_irrelevant')
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) as hpred :: sigma_rest -> | Sil.Hdllseg (Sil.Lseg_PE, _, iF, _, oF, _, _) as hpred :: sigma_rest ->
(match is_root prop iF e with (match is_root prop iF e with
| None -> | None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant let sigma_irrelevant' = hpred :: sigma_irrelevant
@ -777,10 +777,11 @@ let check_inconsistency_two_hpreds prop =
let e_new = Prop.exp_normalize_prop prop_new e let e_new = Prop.exp_normalize_prop prop_new e
in f e_new [] sigma_new in f e_new [] sigma_new
else f e (hpred:: sigma_seen) sigma_rest else f e (hpred:: sigma_seen) sigma_rest
| Sil.Hdllseg (Sil.Lseg_PE, _, e1, e2, Sil.Const (Sil.Cint i), _, _) as hpred :: sigma_rest when Sil.Int.iszero i -> | Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, Sil.Const (Sil.Cint i), _, _) as hpred :: sigma_rest
when Sil.Int.iszero i ->
if Sil.exp_equal e1 e then true if Sil.exp_equal e1 e then true
else f e (hpred:: sigma_seen) sigma_rest else f e (hpred:: sigma_seen) sigma_rest
| Sil.Hdllseg (Sil.Lseg_PE, _, e1, e2, e3, e4, _) as hpred :: sigma_rest -> | Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, e3, _, _) as hpred :: sigma_rest ->
if Sil.exp_equal e1 e if Sil.exp_equal e1 e
then then
let prop' = Prop.normalize (Prop.from_sigma (sigma_seen@sigma_rest)) in let prop' = Prop.normalize (Prop.from_sigma (sigma_seen@sigma_rest)) in
@ -1125,7 +1126,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
| e1, Sil.BinOp (Sil.PlusA, Sil.Var v2, e2) | e1, Sil.BinOp (Sil.PlusA, Sil.Var v2, e2)
| e1, Sil.BinOp (Sil.PlusA, e2, Sil.Var v2) when Ident.is_primed v2 || Ident.is_footprint v2 -> | e1, Sil.BinOp (Sil.PlusA, e2, Sil.Var v2) when Ident.is_primed v2 || Ident.is_footprint v2 ->
do_imply subs (Sil.BinOp (Sil.MinusA, e1, e2)) (Sil.Var v2) do_imply subs (Sil.BinOp (Sil.MinusA, e1, e2)) (Sil.Var v2)
| Sil.Var v1, e2 -> | Sil.Var _, e2 ->
if calc_missing then if calc_missing then
let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in
subs subs
@ -1141,7 +1142,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
| Sil.Const c1, Sil.Const c2 -> | Sil.Const c1, Sil.Const c2 ->
if (Sil.const_equal c1 c2) then subs if (Sil.const_equal c1 c2) then subs
else raise (IMPL_EXC ("constants not equal", subs, (EXC_FALSE_EXPS (e1, e2)))) else raise (IMPL_EXC ("constants not equal", subs, (EXC_FALSE_EXPS (e1, e2))))
| Sil.Const (Sil.Cint n1), Sil.BinOp (Sil.PlusPI, _, _) -> | Sil.Const (Sil.Cint _), Sil.BinOp (Sil.PlusPI, _, _) ->
raise (IMPL_EXC ("pointer+index cannot evaluate to a constant", subs, (EXC_FALSE_EXPS (e1, e2)))) raise (IMPL_EXC ("pointer+index cannot evaluate to a constant", subs, (EXC_FALSE_EXPS (e1, e2))))
| Sil.Const (Sil.Cint n1), Sil.BinOp (Sil.PlusA, f1, Sil.Const (Sil.Cint n2)) -> | Sil.Const (Sil.Cint n1), Sil.BinOp (Sil.PlusA, f1, Sil.Const (Sil.Cint n2)) ->
do_imply subs (Sil.exp_int (n1 -- n2)) f1 do_imply subs (Sil.exp_int (n1 -- n2)) f1
@ -1153,7 +1154,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
do_imply subs (Sil.Lvar pv1) (Sil.BinOp (Sil.MinusA, e2, e1)) do_imply subs (Sil.Lvar pv1) (Sil.BinOp (Sil.MinusA, e2, e1))
| e1, Sil.Const _ -> | e1, Sil.Const _ ->
raise (IMPL_EXC ("lhs not constant", subs, (EXC_FALSE_EXPS (e1, e2)))) raise (IMPL_EXC ("lhs not constant", subs, (EXC_FALSE_EXPS (e1, e2))))
| Sil.Lfield(e1, fd1, t1), Sil.Lfield(e2, fd2, t2) when fd1 == fd2 -> | Sil.Lfield(e1, fd1, _), Sil.Lfield(e2, fd2, _) when fd1 == fd2 ->
do_imply subs e1 e2 do_imply subs e1 e2
| Sil.Lindex(e1, f1), Sil.Lindex(e2, f2) -> | Sil.Lindex(e1, f1), Sil.Lindex(e2, f2) ->
do_imply (do_imply subs e1 e2) f1 f2 do_imply (do_imply subs e1 e2) f1 f2
@ -1171,7 +1172,7 @@ let path_to_id path =
| Sil.Var id -> | Sil.Var id ->
if Ident.is_footprint id then None if Ident.is_footprint id then None
else Some (Ident.name_to_string (Ident.get_name id) ^ (string_of_int (Ident.get_stamp id))) else Some (Ident.name_to_string (Ident.get_name id) ^ (string_of_int (Ident.get_stamp id)))
| Sil.Lfield (e, fld, t) -> | Sil.Lfield (e, fld, _) ->
(match f e with (match f e with
| None -> None | None -> None
| Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld))) | Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld)))
@ -1179,7 +1180,7 @@ let path_to_id path =
(match f e with (match f e with
| None -> None | None -> None
| Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind))) | Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind)))
| Sil.Lvar pv -> | Sil.Lvar _ ->
Some (Sil.exp_to_string path) Some (Sil.exp_to_string path)
| Sil.Const (Sil.Cstr s) -> | Sil.Const (Sil.Cstr s) ->
Some ("_const_str_" ^ s) Some ("_const_str_" ^ s)
@ -1214,14 +1215,14 @@ let array_size_imply calc_missing subs size1 size2 indices2 =
let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subst2 * (Sil.strexp option) * (Sil.strexp option) = let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subst2 * (Sil.strexp option) * (Sil.strexp option) =
(* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_str " : "; Sil.d_typ_full typ2; L.d_ln(); *) (* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_str " : "; Sil.d_typ_full typ2; L.d_ln(); *)
match se1, se2 with match se1, se2 with
| Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) -> | Sil.Eexp (e1, _), Sil.Eexp (e2, _) ->
(exp_imply calc_missing subs e1 e2, None, None) (exp_imply calc_missing subs e1 e2, None, None)
| Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) -> | Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) ->
let subs', fld_frame, fld_missing = struct_imply source calc_missing subs fsel1 fsel2 typ2 in let subs', fld_frame, fld_missing = struct_imply source calc_missing subs fsel1 fsel2 typ2 in
let fld_frame_opt = if fld_frame != [] then Some (Sil.Estruct (fld_frame, inst1)) else None in let fld_frame_opt = if fld_frame != [] then Some (Sil.Estruct (fld_frame, inst1)) else None in
let fld_missing_opt = if fld_missing != [] then Some (Sil.Estruct (fld_missing, inst1)) else None in let fld_missing_opt = if fld_missing != [] then Some (Sil.Estruct (fld_missing, inst1)) else None in
subs', fld_frame_opt, fld_missing_opt subs', fld_frame_opt, fld_missing_opt
| Sil.Estruct _, Sil.Eexp (e2, inst2) -> | Sil.Estruct _, Sil.Eexp (e2, _) ->
begin begin
let e2' = Sil.exp_sub (snd subs) e2 in let e2' = Sil.exp_sub (snd subs) e2 in
match e2' with match e2' with
@ -1246,14 +1247,14 @@ let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subs
| Sil.Eexp (_, inst), Sil.Estruct (fsel, inst') -> | Sil.Eexp (_, inst), Sil.Estruct (fsel, inst') ->
d_impl_err ("WARNING: function call with parameters of struct type, treating as unknown", subs, (EXC_FALSE_SEXPS (se1, se2))); d_impl_err ("WARNING: function call with parameters of struct type, treating as unknown", subs, (EXC_FALSE_SEXPS (se1, se2)));
let fsel' = let fsel' =
let g (f, se) = (f, Sil.Eexp (Sil.Var (Ident.create_fresh Ident.knormal), inst)) in let g (f, _) = (f, Sil.Eexp (Sil.Var (Ident.create_fresh Ident.knormal), inst)) in
IList.map g fsel in IList.map g fsel in
sexp_imply source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 typ2 sexp_imply source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 typ2
| Sil.Eexp _, Sil.Earray (size, esel, inst) | Sil.Eexp _, Sil.Earray (size, _, inst)
| Sil.Estruct _, Sil.Earray (size, esel, inst) -> | Sil.Estruct _, Sil.Earray (size, _, inst) ->
let se1' = Sil.Earray (size, [(Sil.exp_zero, se1)], inst) in let se1' = Sil.Earray (size, [(Sil.exp_zero, se1)], inst) in
sexp_imply source calc_index_frame calc_missing subs se1' se2 typ2 sexp_imply source calc_index_frame calc_missing subs se1' se2 typ2
| Sil.Earray (size, _, _), Sil.Eexp (e, inst) -> | Sil.Earray (size, _, _), Sil.Eexp (_, inst) ->
let se2' = Sil.Earray (size, [(Sil.exp_zero, se2)], inst) in let se2' = Sil.Earray (size, [(Sil.exp_zero, se2)], inst) in
let typ2' = Sil.Tarray (typ2, size) in let typ2' = Sil.Tarray (typ2, size) in
sexp_imply source true calc_missing subs se1 se2' typ2' (* calculate index_frame because the rhs is a singleton array *) sexp_imply source true calc_missing subs se1 se2' typ2' (* calculate index_frame because the rhs is a singleton array *)
@ -1317,7 +1318,7 @@ and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2
and sexp_imply_nolhs source calc_missing subs se2 typ2 = and sexp_imply_nolhs source calc_missing subs se2 typ2 =
match se2 with match se2 with
| Sil.Eexp (_e2, inst) -> | Sil.Eexp (_e2, _) ->
let e2 = Sil.exp_sub (snd subs) _e2 in let e2 = Sil.exp_sub (snd subs) _e2 in
begin begin
match e2 with match e2 with
@ -1337,9 +1338,9 @@ and sexp_imply_nolhs source calc_missing subs se2 typ2 =
raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE)) raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE))
end end
| Sil.Estruct (fsel2, _) -> | Sil.Estruct (fsel2, _) ->
(fun (x, y, z) -> x) (struct_imply source calc_missing subs [] fsel2 typ2) (fun (x, _, _) -> x) (struct_imply source calc_missing subs [] fsel2 typ2)
| Sil.Earray (_, esel2, _) -> | Sil.Earray (_, esel2, _) ->
(fun (x, y, z) -> x) (array_imply source false calc_missing subs [] esel2 typ2) (fun (x, _, _) -> x) (array_imply source false calc_missing subs [] esel2 typ2)
let rec exp_list_imply calc_missing subs l1 l2 = match l1, l2 with let rec exp_list_imply calc_missing subs l1 l2 = match l1, l2 with
| [],[] -> subs | [],[] -> subs
@ -1357,11 +1358,11 @@ let filter_ne_lhs sub e0 = function
| _ -> None | _ -> None
let filter_hpred sub hpred2 hpred1 = match (Sil.hpred_sub sub hpred1), hpred2 with let filter_hpred sub hpred2 hpred1 = match (Sil.hpred_sub sub hpred1), hpred2 with
| Sil.Hlseg(Sil.Lseg_NE, hpara1, e1, f1, el1), Sil.Hlseg(Sil.Lseg_PE, hpara2, e2, f2, el2) -> | Sil.Hlseg(Sil.Lseg_NE, hpara1, e1, f1, el1), Sil.Hlseg(Sil.Lseg_PE, _, _, _, _) ->
if Sil.hpred_equal (Sil.Hlseg(Sil.Lseg_PE, hpara1, e1, f1, el1)) hpred2 then Some false else None if Sil.hpred_equal (Sil.Hlseg(Sil.Lseg_PE, hpara1, e1, f1, el1)) hpred2 then Some false else None
| Sil.Hlseg(Sil.Lseg_PE, hpara1, e1, f1, el1), Sil.Hlseg(Sil.Lseg_NE, hpara2, e2, f2, el2) -> | Sil.Hlseg(Sil.Lseg_PE, hpara1, e1, f1, el1), Sil.Hlseg(Sil.Lseg_NE, _, _, _, _) ->
if Sil.hpred_equal (Sil.Hlseg(Sil.Lseg_NE, hpara1, e1, f1, el1)) hpred2 then Some true else None (* return missing disequality *) if Sil.hpred_equal (Sil.Hlseg(Sil.Lseg_NE, hpara1, e1, f1, el1)) hpred2 then Some true else None (* return missing disequality *)
| Sil.Hpointsto(e1, se1, te1), Sil.Hlseg(k, hpara2, e2, f2, el2) -> | Sil.Hpointsto(e1, _, _), Sil.Hlseg(_, _, e2, _, _) ->
if Sil.exp_equal e1 e2 then Some false else None if Sil.exp_equal e1 e2 then Some false else None
| hpred1, hpred2 -> if Sil.hpred_equal hpred1 hpred2 then Some false else None | hpred1, hpred2 -> if Sil.hpred_equal hpred1 hpred2 then Some false else None
@ -1371,7 +1372,7 @@ let hpred_has_primed_lhs sub hpred =
find_primed e find_primed e
| Sil.Lindex (e, _) -> | Sil.Lindex (e, _) ->
find_primed e find_primed e
| Sil.BinOp (Sil.PlusPI, e1, e2) -> | Sil.BinOp (Sil.PlusPI, e1, _) ->
find_primed e1 find_primed e1
| _ -> | _ ->
Sil.fav_exists (Sil.exp_fav e) Ident.is_primed in Sil.fav_exists (Sil.exp_fav e) Ident.is_primed in
@ -1381,12 +1382,12 @@ let hpred_has_primed_lhs sub hpred =
exp_has_primed e exp_has_primed e
| Sil.Hlseg (_, _, e, _, _) -> | Sil.Hlseg (_, _, e, _, _) ->
exp_has_primed e exp_has_primed e
| Sil.Hdllseg (_, _, iF, oB, oF, iB, _) -> | Sil.Hdllseg (_, _, iF, _, _, iB, _) ->
exp_has_primed iF && exp_has_primed iB exp_has_primed iF && exp_has_primed iB
let move_primed_lhs_from_front subs sigma = match sigma with let move_primed_lhs_from_front subs sigma = match sigma with
| [] -> sigma | [] -> sigma
| hpred:: sigma' -> | hpred:: _ ->
if hpred_has_primed_lhs (snd subs) hpred then if hpred_has_primed_lhs (snd subs) hpred then
let (sigma_primed, sigma_unprimed) = IList.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 in match sigma_unprimed with
@ -1583,7 +1584,7 @@ end
let cast_exception tenv texp1 texp2 e1 subs = let cast_exception tenv texp1 texp2 e1 subs =
let _ = match texp1, texp2 with let _ = match texp1, texp2 with
| Sil.Sizeof (t1, st1), Sil.Sizeof (t2, st2) -> | Sil.Sizeof (t1, _), Sil.Sizeof (t2, st2) ->
if !Config.developer_mode || if !Config.developer_mode ||
(Sil.Subtype.is_cast st2 && (Sil.Subtype.is_cast st2 &&
not (Subtyping_check.check_subtype tenv t1 t2)) then not (Subtyping_check.check_subtype tenv t1 t2)) then
@ -1642,7 +1643,7 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing =
begin begin
match pos_type_opt with match pos_type_opt with
| None -> cast_exception tenv texp1 texp2 e1 subs | None -> cast_exception tenv texp1 texp2 e1 subs
| Some texp1' -> | Some _ ->
if has_changed then None, pos_type_opt (* missing *) if has_changed then None, pos_type_opt (* missing *)
else pos_type_opt, None (* frame *) else pos_type_opt, None (* frame *)
end end
@ -1661,7 +1662,7 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing =
(** pre-process implication between a non-array and an array: the non-array is turned into an array of size given by its type (** pre-process implication between a non-array and an array: the non-array is turned into an array of size given by its type
only active in type_size mode *) only active in type_size mode *)
let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with
| Sil.Eexp (e1, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size -> | Sil.Eexp (_, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size ->
let se1' = Sil.Earray (texp1, [(Sil.exp_zero, se1)], inst) in let se1' = Sil.Earray (texp1, [(Sil.exp_zero, se1)], inst) in
L.d_strln_color Orange "sexp_imply_preprocess"; L.d_str " se1: "; Sil.d_sexp se1; L.d_ln (); L.d_str " se1': "; Sil.d_sexp se1'; L.d_ln (); L.d_strln_color Orange "sexp_imply_preprocess"; L.d_str " se1: "; Sil.d_sexp se1; L.d_ln (); L.d_str " se1': "; Sil.d_sexp se1'; L.d_ln ();
se1' se1'
@ -1687,7 +1688,9 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2
| _ -> false in | _ -> false in
if IList.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 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') -> | Sil.Sizeof(Sil.Tptr (_t1, _), _), Sil.Sizeof(Sil.Tptr (_t2, _), _),
Sil.Eexp(e1', _), Sil.Eexp(e2', _)
when not (is_allocated_lhs e1') ->
begin begin
let t1, t2 = Sil.expand_type tenv _t1, Sil.expand_type tenv _t2 in let t1, t2 = Sil.expand_type tenv _t1, Sil.expand_type tenv _t2 in
match type_rhs e2' with match type_rhs e2' with
@ -1712,7 +1715,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Hpointsto (_e2, se2, texp2) -> | Sil.Hpointsto (_e2, se2, texp2) ->
let e2 = Sil.exp_sub (snd subs) _e2 in let e2 = Sil.exp_sub (snd subs) _e2 in
let _ = match e2 with let _ = match e2 with
| Sil.Lvar p -> () | Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented __POS__)) raise (Exceptions.Abduction_case_not_implemented __POS__))
@ -1753,7 +1756,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1') in (subs', prop1')
with with
| IMPL_EXC (s, _, body) when calc_missing -> | IMPL_EXC (s, _, _) when calc_missing ->
raise (MISSING_EXC s)) raise (MISSING_EXC s))
| Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (** Unroll lseg *) | Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (** Unroll lseg *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
@ -1797,7 +1800,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Hlseg (k, para2, _e2, _f2, _elist2) -> (* for now ignore implications between PE and NE *) | Sil.Hlseg (k, para2, _e2, _f2, _elist2) -> (* for now ignore implications between PE and NE *)
let e2, f2 = Sil.exp_sub (snd subs) _e2, Sil.exp_sub (snd subs) _f2 in let e2, f2 = Sil.exp_sub (snd subs) _e2, Sil.exp_sub (snd subs) _f2 in
let _ = match e2 with let _ = match e2 with
| Sil.Lvar p -> () | Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented __POS__)) raise (Exceptions.Abduction_case_not_implemented __POS__))
@ -1852,18 +1855,19 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) -> | Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) ->
(d_impl_err ("rhs dllsegPE not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs dllsegPE not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented __POS__)) raise (Exceptions.Abduction_case_not_implemented __POS__))
| Sil.Hdllseg (k, para2, iF2, oB2, oF2, iB2, elist2) -> (* for now ignore implications between PE and NE *) | Sil.Hdllseg (_, para2, iF2, oB2, oF2, iB2, elist2) ->
(* for now ignore implications between PE and NE *)
let iF2, oF2 = Sil.exp_sub (snd subs) iF2, Sil.exp_sub (snd subs) oF2 in let iF2, oF2 = Sil.exp_sub (snd subs) iF2, Sil.exp_sub (snd subs) oF2 in
let iB2, oB2 = Sil.exp_sub (snd subs) iB2, Sil.exp_sub (snd subs) oB2 in let iB2, oB2 = Sil.exp_sub (snd subs) iB2, Sil.exp_sub (snd subs) oB2 in
let _ = match oF2 with let _ = match oF2 with
| Sil.Lvar p -> () | Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented __POS__)) raise (Exceptions.Abduction_case_not_implemented __POS__))
| _ -> () | _ -> ()
in in
let _ = match oB2 with let _ = match oB2 with
| Sil.Lvar p -> () | Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then | Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2)); (d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented __POS__)) raise (Exceptions.Abduction_case_not_implemented __POS__))
@ -2002,7 +2006,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
ProverState.add_missing_sigma sigma2; ProverState.add_missing_sigma sigma2;
subs, prop1 subs, prop1
let prepare_prop_for_implication (sub1, sub2) pi1 sigma1 = let prepare_prop_for_implication (_, sub2) pi1 sigma1 =
let pi1' = (Prop.pi_sub sub2 (ProverState.get_missing_pi ())) @ pi1 in let pi1' = (Prop.pi_sub sub2 (ProverState.get_missing_pi ())) @ pi1 in
let sigma1' = (Prop.sigma_sub sub2 (ProverState.get_missing_sigma ())) @ sigma1 in let sigma1' = (Prop.sigma_sub sub2 (ProverState.get_missing_sigma ())) @ sigma1 in
let ep = Prop.replace_sub sub2 (Prop.replace_sigma sigma1' (Prop.from_pi pi1')) in let ep = Prop.replace_sub sub2 (Prop.replace_sigma sigma1' (Prop.from_pi pi1')) in
@ -2044,19 +2048,19 @@ let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
(* The commented-out condition should always hold. *) (* The commented-out condition should always hold. *)
let sub2' = extend_sub (snd subs) v2 e2 in let sub2' = extend_sub (snd subs) v2 e2 in
pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2' pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2'
| e2, f2 -> | _ ->
let pi1' = Prop.pi_sub (fst subs) pi1 in let pi1' = Prop.pi_sub (fst subs) pi1 in
let prop_for_impl = prepare_prop_for_implication subs pi1' [] in let prop_for_impl = prepare_prop_for_implication subs pi1' [] in
imply_atom calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in)); imply_atom calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in));
pre_check_pure_implication calc_missing subs pi1 pi2' pre_check_pure_implication calc_missing subs pi1 pi2'
) )
| Sil.Aeq (e1, e2) :: pi2' -> (* must be an inequality *) | Sil.Aeq _ :: pi2' -> (* must be an inequality *)
pre_check_pure_implication calc_missing subs pi1 pi2' pre_check_pure_implication calc_missing subs pi1 pi2'
| Sil.Aneq (Sil.Var v, f2):: pi2' -> | Sil.Aneq (Sil.Var v, _):: pi2' ->
if not (Ident.is_primed v || calc_missing) if not (Ident.is_primed v || calc_missing)
then raise (IMPL_EXC("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE)) then raise (IMPL_EXC("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE))
else pre_check_pure_implication calc_missing subs pi1 pi2' else pre_check_pure_implication calc_missing subs pi1 pi2'
| Sil.Aneq (e1, e2):: pi2' -> | Sil.Aneq _ :: pi2' ->
if calc_missing then pre_check_pure_implication calc_missing subs pi1 pi2' if calc_missing then pre_check_pure_implication calc_missing subs pi1 pi2'
else raise (IMPL_EXC ("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE)) else raise (IMPL_EXC ("ineq e2=f2 in rhs with e2 not primed var", (Sil.sub_empty, Sil.sub_empty), EXC_FALSE))

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

@ -30,7 +30,7 @@ let rec list_rev_and_concat l1 l2 =
If the index is provably out of bound, a bound error is given. If the index is provably out of bound, a bound error is given.
If the size is a constant and the index is not provably in bound, a warning is given. If the size is a constant and the index is not provably in bound, a warning is given.
*) *)
let check_bad_index pname tenv p size index loc = let check_bad_index pname p size index loc =
let size_is_constant = match size with let size_is_constant = match size with
| Sil.Const _ -> true | Sil.Const _ -> true
| _ -> false in | _ -> false in
@ -73,14 +73,14 @@ let check_bad_index pname tenv p size index loc =
end end
(** Perform bounds checking *) (** Perform bounds checking *)
let bounds_check pname tenv prop size e = let bounds_check pname prop size e =
if !Config.trace_rearrange then if !Config.trace_rearrange then
begin begin
L.d_str "Bounds check index:"; Sil.d_exp e; L.d_str "Bounds check index:"; Sil.d_exp e;
L.d_str " size: "; Sil.d_exp size; L.d_str " size: "; Sil.d_exp size;
L.d_ln() L.d_ln()
end; end;
check_bad_index pname tenv prop size e check_bad_index pname prop size e
let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp t let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp t
(off: Sil.offset list) inst : Sil.atom list * Sil.strexp * Sil.typ = (off: Sil.offset list) inst : Sil.atom list * Sil.strexp * Sil.typ =
@ -126,7 +126,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
| Sil.Tarray(_, size),[] -> | Sil.Tarray(_, size),[] ->
([], Sil.Earray(size, [], inst), t) ([], Sil.Earray(size, [], inst), t)
| Sil.Tarray(t', size'), (Sil.Off_index e) :: off' -> | Sil.Tarray(t', size'), (Sil.Off_index e) :: off' ->
bounds_check pname tenv orig_prop size' e (State.get_loc ()); bounds_check pname orig_prop size' e (State.get_loc ());
let atoms', se', res_t' = let atoms', se', res_t' =
create_struct_values create_struct_values
@ -191,7 +191,7 @@ let rec _strexp_extend_values
let off_new = Sil.Off_index(Sil.exp_zero):: off in let off_new = Sil.Off_index(Sil.exp_zero):: off in
_strexp_extend_values _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
| (Sil.Off_fld (f, _)):: _, Sil.Earray _, Sil.Tarray _ -> | (Sil.Off_fld _):: _, Sil.Earray _, Sil.Tarray _ ->
let off_new = Sil.Off_index(Sil.exp_zero):: off in let off_new = Sil.Off_index(Sil.exp_zero):: off in
_strexp_extend_values _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst
@ -200,7 +200,7 @@ let rec _strexp_extend_values
let replace_fv new_v fv = if Ident.fieldname_equal (fst fv) f then (f, new_v) else fv in let replace_fv new_v fv = if Ident.fieldname_equal (fst fv) f then (f, new_v) else fv in
let _, typ', _ = let _, typ', _ =
try try
IList.find (fun (f', t', a') -> Ident.fieldname_equal f f') IList.find (fun (f', _, _) -> Ident.fieldname_equal f f')
(instance_fields @ static_fields) (instance_fields @ static_fields)
with Not_found -> with Not_found ->
raise (Exceptions.Missing_fld (f, __POS__)) in raise (Exceptions.Missing_fld (f, __POS__)) in
@ -231,7 +231,7 @@ let rec _strexp_extend_values
let struct_typ = Sil.Tstruct { struct_typ with Sil.instance_fields = instance_fields' } in let struct_typ = Sil.Tstruct { struct_typ with Sil.instance_fields = instance_fields' } in
[(atoms', Sil.Estruct (res_fsel', inst'), struct_typ)] [(atoms', Sil.Estruct (res_fsel', inst'), struct_typ)]
end end
| (Sil.Off_fld (f, _)):: off', _, _ -> | (Sil.Off_fld (_, _)):: _, _, _ ->
raise (Exceptions.Bad_footprint __POS__) raise (Exceptions.Bad_footprint __POS__)
| (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tint _ | (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tint _
@ -252,7 +252,7 @@ let rec _strexp_extend_values
_strexp_extend_values _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst
| (Sil.Off_index e):: off', Sil.Earray(size, esel, inst_arr), Sil.Tarray(typ', size_for_typ') -> | (Sil.Off_index e):: off', Sil.Earray(size, esel, inst_arr), Sil.Tarray(typ', size_for_typ') ->
bounds_check pname tenv orig_prop size e (State.get_loc ()); bounds_check pname orig_prop size e (State.get_loc ());
begin begin
try try
let _, se' = IList.find (fun (e', _) -> Sil.exp_equal e e') esel in let _, se' = IList.find (fun (e', _) -> Sil.exp_equal e e') esel in
@ -447,7 +447,7 @@ let mk_ptsto_exp_footprint
If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *) If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *)
let prop_iter_check_fields_ptsto_shallow iter lexp = let prop_iter_check_fields_ptsto_shallow iter lexp =
let offset = Sil.exp_get_offsets lexp in let offset = Sil.exp_get_offsets lexp in
let (e, se, t) = let (_, se, _) =
match Prop.prop_iter_current iter with match Prop.prop_iter_current iter with
| Sil.Hpointsto (e, se, t), _ -> (e, se, t) | Sil.Hpointsto (e, se, t), _ -> (e, se, t)
| _ -> assert false in | _ -> assert false in
@ -461,7 +461,7 @@ let prop_iter_check_fields_ptsto_shallow iter lexp =
check_offset se' off' check_offset se' off'
with Not_found -> Some fld) with Not_found -> Some fld)
| _ -> Some fld) | _ -> Some fld)
| (Sil.Off_index e):: off' -> None in | (Sil.Off_index _):: _ -> None in
check_offset se offset check_offset se offset
let fav_max_stamp fav = let fav_max_stamp fav =
@ -528,8 +528,9 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let sigma_pto, sigma_rest = let sigma_pto, sigma_rest =
IList.partition (function IList.partition (function
| Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e' | Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e'
| Sil.Hlseg (_, _, e1, e2, _) -> Sil.exp_equal e e1 | Sil.Hlseg (_, _, e1, _, _) -> 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 | Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) ->
Sil.exp_equal e e_iF || Sil.exp_equal e e_iB
) footprint_sigma in ) footprint_sigma in
let atoms_sigma_list = let atoms_sigma_list =
match sigma_pto with match sigma_pto with
@ -797,8 +798,8 @@ let type_at_offset texp off =
| (Sil.Off_fld (f, _)):: off', Sil.Tstruct { Sil.instance_fields } -> | (Sil.Off_fld (f, _)):: off', Sil.Tstruct { Sil.instance_fields } ->
(try (try
let typ' = let typ' =
(fun (x, y, z) -> y) (fun (_, y, _) -> y)
(IList.find (fun (f', t', a') -> Ident.fieldname_equal f f') instance_fields) in (IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') instance_fields) in
strip_offset off' typ' strip_offset off' typ'
with Not_found -> None) with Not_found -> None)
| (Sil.Off_index _):: off', Sil.Tarray (typ', _) -> | (Sil.Off_index _):: off', Sil.Tarray (typ', _) ->
@ -947,7 +948,7 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
nullable_obj_str := Some (Sil.pvar_to_string pvar); nullable_obj_str := Some (Sil.pvar_to_string pvar);
(* it's ok for a non-nullable local to point to deref_exp *) (* it's ok for a non-nullable local to point to deref_exp *)
is_nullable || Sil.pvar_is_local pvar is_nullable || Sil.pvar_is_local pvar
| Sil.Hpointsto (_, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) -> | Sil.Hpointsto (_, Sil.Estruct (flds, _), Sil.Sizeof (typ, _)) ->
let fld_is_nullable fld = let fld_is_nullable fld =
match Annotations.get_field_type_and_annotation fld typ with match Annotations.get_field_type_and_annotation fld typ with
| Some (_, annot) -> Annotations.ia_is_nullable annot | Some (_, annot) -> Annotations.ia_is_nullable annot

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

@ -56,7 +56,7 @@ let create_serializer (key : key) : 'a serializer =
let from_string (str : string) : 'a option = let from_string (str : string) : 'a option =
try try
match_data (Marshal.from_string str 0) "string" match_data (Marshal.from_string str 0) "string"
with Sys_error s -> None in with Sys_error _ -> None in
let from_file (_fname : DB.filename) : 'a option = let from_file (_fname : DB.filename) : 'a option =
let read () = let read () =
try try
@ -66,7 +66,7 @@ let create_serializer (key : key) : 'a serializer =
close_in inc; close_in inc;
value_option value_option
with with
| Sys_error s -> None in | Sys_error _ -> None in
let timeout = 1.0 in let timeout = 1.0 in
let catch_exn = function let catch_exn = function
| End_of_file -> true | End_of_file -> true

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

@ -67,7 +67,7 @@ let pp_annotation fmt annotation = F.fprintf fmt "@@%s" annotation.class_name
(** Pretty print an item annotation. *) (** Pretty print an item annotation. *)
let pp_item_annotation fmt item_annotation = let pp_item_annotation fmt item_annotation =
let pp fmt (a, v) = pp_annotation fmt a in let pp fmt (a, _) = pp_annotation fmt a in
F.fprintf fmt "<%a>" (pp_seq pp) item_annotation F.fprintf fmt "<%a>" (pp_seq pp) item_annotation
let item_annotation_to_string ann = let item_annotation_to_string ann =
@ -80,12 +80,9 @@ let pp_method_annotation s fmt (ia, ial) =
(** Return the value of the FA_sentinel attribute in [attr_list] if it is found *) (** Return the value of the FA_sentinel attribute in [attr_list] if it is found *)
let get_sentinel_func_attribute_value attr_list = let get_sentinel_func_attribute_value attr_list =
(* Sentinel is the only kind of attributes *) match attr_list with
let is_sentinel a = true in | FA_sentinel (sentinel, null_pos) :: _ -> Some (sentinel, null_pos)
try | [] -> None
match IList.find is_sentinel attr_list with
| FA_sentinel (sentinel, null_pos) -> Some (sentinel, null_pos)
with Not_found -> None
(** Kind of global variables *) (** Kind of global variables *)
type pvar_kind = type pvar_kind =
@ -306,7 +303,7 @@ module Subtype = struct
let compare t1 t2 = let compare t1 t2 =
pair_compare compare_subt compare_flag t1 t2 pair_compare compare_subt compare_flag t1 t2
let equal_modulo_flag (st1, flag1) (st2, flag2) = let equal_modulo_flag (st1, _) (st2, _) =
compare_subt st1 st2 = 0 compare_subt st1 st2 = 0
let update_flag c1 c2 flag flag' = let update_flag c1 c2 flag flag' =
@ -409,16 +406,16 @@ module Subtype = struct
else (None, Some st1) in else (None, Some st1) in
(normalize_subtypes pos_st c1 c2 flag1 flag2), (normalize_subtypes neg_st c1 c2 flag1 flag2) (normalize_subtypes pos_st c1 c2 flag1 flag2), (normalize_subtypes neg_st c1 c2 flag1 flag2)
let case_analysis_basic (c1, st) (c2, (st2, flag2)) f = let case_analysis_basic (c1, st) (c2, (_, flag2)) f =
let (pos_st, neg_st) = let (pos_st, neg_st) =
if f c1 c2 then (Some st, None) if f c1 c2 then (Some st, None)
else if f c2 c1 then else if f c2 c1 then
match st with match st with
| Exact, flag -> | Exact, _ ->
if Typename.equal c1 c2 if Typename.equal c1 c2
then (Some st, None) then (Some st, None)
else (None, Some st) else (None, Some st)
| Subtypes _ , flag -> | Subtypes _ , _ ->
if Typename.equal c1 c2 if Typename.equal c1 c2
then (Some st, None) then (Some st, None)
else (Some st, Some st) else (Some st, Some st)
@ -490,11 +487,11 @@ end = struct
if area unsigned i = 3 then None (* not representable as signed *) if area unsigned i = 3 then None (* not representable as signed *)
else Some (false, i, ptr) else Some (false, i, ptr)
let compare (unsigned1, i1, ptr1) (unsigned2, i2, ptr2) = let compare (unsigned1, i1, _) (unsigned2, i2, _) =
let n = bool_compare unsigned1 unsigned2 in let n = bool_compare unsigned1 unsigned2 in
if n <> 0 then n else Int64.compare i1 i2 if n <> 0 then n else Int64.compare i1 i2
let compare_value (unsigned1, i1, ptr1) (unsigned2, i2, ptr2) = let compare_value (unsigned1, i1, _) (unsigned2, i2, _) =
let area1 = area unsigned1 i1 in let area1 = area unsigned1 i1 in
let area2 = area unsigned2 i2 in let area2 = area unsigned2 i2 in
let n = int_compare area1 area2 in let n = int_compare area1 area2 in
@ -511,18 +508,18 @@ end = struct
let of_int32 i = of_int64 (Int64.of_int32 i) let of_int32 i = of_int64 (Int64.of_int32 i)
let of_int64_unsigned i unsigned = (unsigned, i, false) let of_int64_unsigned i unsigned = (unsigned, i, false)
let of_int i = of_int64 (Int64.of_int i) let of_int i = of_int64 (Int64.of_int i)
let to_int (large, i, ptr) = Int64.to_int i let to_int (_, i, _) = Int64.to_int i
let null = (false, 0L, true) let null = (false, 0L, true)
let zero = of_int 0 let zero = of_int 0
let one = of_int 1 let one = of_int 1
let two = of_int 2 let two = of_int 2
let minus_one = of_int (-1) let minus_one = of_int (-1)
let isone (_, i, ptr) = i = 1L let isone (_, i, _) = i = 1L
let iszero (_, i, ptr) = i = 0L let iszero (_, i, _) = i = 0L
let isnull (_, i, ptr) = i = 0L && ptr let isnull (_, i, ptr) = i = 0L && ptr
let isminusone (unsigned, i, ptr) = not unsigned && i = -1L let isminusone (unsigned, i, _) = not unsigned && i = -1L
let isnegative (unsigned, i, ptr) = not unsigned && i < 0L let isnegative (unsigned, i, _) = not unsigned && i < 0L
let neg (unsigned, i, ptr) = (unsigned, Int64.neg i, ptr) let neg (unsigned, i, ptr) = (unsigned, Int64.neg i, ptr)
@ -834,7 +831,7 @@ let objc_ref_counter_field =
(** {2 Comparision and Inspection Functions} *) (** {2 Comparision and Inspection Functions} *)
let is_objc_ref_counter_field (fld, t, a) = let is_objc_ref_counter_field (fld, _, a) =
Ident.fieldname_is_hidden fld && (item_annotation_compare a objc_ref_counter_annot = 0) Ident.fieldname_is_hidden fld && (item_annotation_compare a objc_ref_counter_annot = 0)
let has_objc_ref_counter hpred = let has_objc_ref_counter hpred =
@ -886,7 +883,7 @@ let pvar_get_simplified_name pv =
match string_split_character s '.' with match string_split_character s '.' with
| Some s1, s2 -> | Some s1, s2 ->
(match string_split_character s1 '.' with (match string_split_character s1 '.' with
| Some s3, s4 -> s4 ^ "." ^ s2 | Some _, s4 -> s4 ^ "." ^ s2
| _ -> s) | _ -> s)
| _ -> s | _ -> s
@ -937,7 +934,7 @@ let mk_static_local_name pname vname =
let is_static_local_name pname pvar = (* local static name is of the form procname_varname *) let is_static_local_name pname pvar = (* local static name is of the form procname_varname *)
let var_name = Mangled.to_string(pvar_get_name pvar) in let var_name = Mangled.to_string(pvar_get_name pvar) in
match Str.split_delim (Str.regexp_string pname) var_name with match Str.split_delim (Str.regexp_string pname) var_name with
| [s1; s2] -> true | [_; _] -> true
| _ -> false | _ -> false
let rec pv_kind_compare k1 k2 = match k1, k2 with let rec pv_kind_compare k1 k2 = match k1, k2 with
@ -1511,13 +1508,13 @@ let lseg_kind_equal k1 k2 =
let rec strexp_compare se1 se2 = let rec strexp_compare se1 se2 =
if se1 == se2 then 0 if se1 == se2 then 0
else match se1, se2 with else match se1, se2 with
| Eexp (e1, inst1), Eexp (e2, inst2) -> exp_compare e1 e2 | Eexp (e1, _), Eexp (e2, _) -> exp_compare e1 e2
| Eexp _, _ -> - 1 | Eexp _, _ -> - 1
| _, Eexp _ -> 1 | _, Eexp _ -> 1
| Estruct (fel1, inst1), Estruct (fel2, inst2) -> fld_strexp_list_compare fel1 fel2 | Estruct (fel1, _), Estruct (fel2, _) -> fld_strexp_list_compare fel1 fel2
| Estruct _, _ -> - 1 | Estruct _, _ -> - 1
| _, Estruct _ -> 1 | _, Estruct _ -> 1
| Earray (e1, esel1, inst1), Earray (e2, esel2, inst2) -> | Earray (e1, esel1, _), Earray (e2, esel2, _) ->
let n = exp_compare e1 e2 in let n = exp_compare e1 e2 in
if n <> 0 then n else exp_strexp_list_compare esel1 esel2 if n <> 0 then n else exp_strexp_list_compare esel1 esel2
@ -1683,11 +1680,11 @@ let pp_seq_diff pp pe0 f =
let rec doit = function let rec doit = function
| [] -> () | [] -> ()
| [x] -> | [x] ->
let pe, changed = color_pre_wrapper pe0 f x in let _, changed = color_pre_wrapper pe0 f x in
F.fprintf f "%a" pp x; F.fprintf f "%a" pp x;
color_post_wrapper changed pe0 f color_post_wrapper changed pe0 f
| x :: l -> | x :: l ->
let pe, changed = color_pre_wrapper pe0 f x in let _, changed = color_pre_wrapper pe0 f x in
F.fprintf f "%a" pp x; F.fprintf f "%a" pp x;
color_post_wrapper changed pe0 f; color_post_wrapper changed pe0 f;
F.fprintf f ", "; F.fprintf f ", ";
@ -1769,15 +1766,15 @@ let rec _pp_pvar f pv =
let pp_pvar_latex f pv = let pp_pvar_latex f pv =
let name = pv.pv_name in let name = pv.pv_name in
match pv.pv_kind with match pv.pv_kind with
| Local_var n -> | Local_var _ ->
Latex.pp_string Latex.Roman f (Mangled.to_string name) Latex.pp_string Latex.Roman f (Mangled.to_string name)
| Callee_var n -> | Callee_var _ ->
F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
(Latex.pp_string Latex.Roman) "callee" (Latex.pp_string Latex.Roman) "callee"
| Abducted_retvar (n, l) -> | Abducted_retvar _ ->
F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
(Latex.pp_string Latex.Roman) "abductedRetvar" (Latex.pp_string Latex.Roman) "abductedRetvar"
| Abducted_ref_param (n, pv, l) -> | Abducted_ref_param _ ->
F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name)
(Latex.pp_string Latex.Roman) "abductedRefParam" (Latex.pp_string Latex.Roman) "abductedRefParam"
| Global_var -> | Global_var ->
@ -1852,7 +1849,7 @@ let rec dexp_to_string = function
Procname.to_simplified_string pn Procname.to_simplified_string pn
| Dconst c -> exp_to_string (Const c) | Dconst c -> exp_to_string (Const c)
| Dderef de -> "*" ^ dexp_to_string de | Dderef de -> "*" ^ dexp_to_string de
| Dfcall (fun_dexp, args, loc, { cf_virtual = isvirtual }) -> | Dfcall (fun_dexp, args, _, { cf_virtual = isvirtual }) ->
let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in
let pp_args fmt des = let pp_args fmt des =
if eradicate_java () if eradicate_java ()
@ -1882,7 +1879,7 @@ let rec dexp_to_string = function
if Ident.fieldname_is_hidden f then dexp_to_string de if Ident.fieldname_is_hidden f then dexp_to_string de
else if java() then dexp_to_string de ^ "." ^ Ident.fieldname_to_flat_string f else if java() then dexp_to_string de ^ "." ^ Ident.fieldname_to_flat_string f
else dexp_to_string de ^ "->" ^ Ident.fieldname_to_string f else dexp_to_string de ^ "->" ^ Ident.fieldname_to_string f
| Ddot (Dpvar pv, fe) when eradicate_java () -> (* static field access *) | Ddot (Dpvar _, fe) when eradicate_java () -> (* static field access *)
Ident.fieldname_to_simplified_string fe Ident.fieldname_to_simplified_string fe
| Ddot (de, f) -> | Ddot (de, f) ->
if Ident.fieldname_is_hidden f then "&" ^ dexp_to_string de if Ident.fieldname_is_hidden f then "&" ^ dexp_to_string de
@ -1898,18 +1895,18 @@ let rec dexp_to_string = function
else "&" in else "&" in
ampersand ^ s ampersand ^ s
| Dunop (op, de) -> str_unop op ^ dexp_to_string de | Dunop (op, de) -> str_unop op ^ dexp_to_string de
| Dsizeof (typ, sub) -> pp_to_string (pp_typ_full pe_text) typ | Dsizeof (typ, _) -> pp_to_string (pp_typ_full pe_text) typ
| Dunknown -> "unknown" | Dunknown -> "unknown"
| Dretcall (de, _, _, _) -> | Dretcall (de, _, _, _) ->
"returned by " ^ (dexp_to_string de) "returned by " ^ (dexp_to_string de)
(** Pretty print a dexp. *) (** Pretty print a dexp. *)
and pp_dexp pe fmt de = F.fprintf fmt "%s" (dexp_to_string de) and pp_dexp fmt de = F.fprintf fmt "%s" (dexp_to_string de)
(** Pretty print a value path *) (** Pretty print a value path *)
and pp_vpath pe fmt vpath = and pp_vpath pe fmt vpath =
let pp fmt = function let pp fmt = function
| Some de -> pp_dexp pe fmt de | Some de -> pp_dexp fmt de
| None -> () in | None -> () in
if pe.pe_kind == PP_HTML then if pe.pe_kind == PP_HTML then
F.fprintf fmt " %a{vpath: %a}%a" Io_infer.Html.pp_start_color Orange pp vpath Io_infer.Html.pp_end_color () F.fprintf fmt " %a{vpath: %a}%a" Io_infer.Html.pp_start_color Orange pp vpath Io_infer.Html.pp_end_color ()
@ -1952,7 +1949,7 @@ and attribute_to_string pe = function
| Auntaint -> "UNTAINTED" | Auntaint -> "UNTAINTED"
| Alocked -> "LOCKED" | Alocked -> "LOCKED"
| Aunlocked -> "UNLOCKED" | Aunlocked -> "UNLOCKED"
| Adiv0 (pn, nd_id) -> "DIV0" | Adiv0 (_, _) -> "DIV0"
| Aobjc_null exp -> | Aobjc_null exp ->
let info_s = let info_s =
match exp with match exp with
@ -1975,7 +1972,7 @@ and pp_const pe f = function
| Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att) | Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att)
| Cexn e -> F.fprintf f "EXN %a" (pp_exp pe) e | Cexn e -> F.fprintf f "EXN %a" (pp_exp pe) e
| Cclass c -> F.fprintf f "%a" Ident.pp_name c | Cclass c -> F.fprintf f "%a" Ident.pp_name c
| Cptr_to_fld (fn, typ) -> F.fprintf f "__fld_%a" Ident.pp_fieldname fn | Cptr_to_fld (fn, _) -> F.fprintf f "__fld_%a" Ident.pp_fieldname fn
| Ctuple el -> F.fprintf f "(%a)" (pp_comma_seq (pp_exp pe)) el | Ctuple el -> F.fprintf f "(%a)" (pp_comma_seq (pp_exp pe)) el
(** Pretty print a type. Do nothing by default. *) (** Pretty print a type. Do nothing by default. *)
@ -2003,7 +2000,7 @@ and pp_type_decl pe pp_base pp_size f = function
F.fprintf f "%s %a {%a} %a" F.fprintf f "%s %a {%a} %a"
(Csu.name struct_typ.csu) (Csu.name struct_typ.csu)
Mangled.pp name Mangled.pp name
(pp_seq (fun f (fld, t, ann) -> (pp_seq (fun f (fld, t, _) ->
F.fprintf f "%a %a" F.fprintf f "%a %a"
(pp_typ_full pe) t (pp_typ_full pe) t
Ident.pp_fieldname fld)) struct_typ.instance_fields Ident.pp_fieldname fld)) struct_typ.instance_fields
@ -2016,7 +2013,7 @@ and pp_type_decl pe pp_base pp_size f = function
| Tstruct ({struct_name = None} as struct_typ) -> | Tstruct ({struct_name = None} as struct_typ) ->
F.fprintf f "%s {%a} %a" F.fprintf f "%s {%a} %a"
(Csu.name struct_typ.csu) (Csu.name struct_typ.csu)
(pp_seq (fun f (fld, t, ann) -> (pp_seq (fun f (fld, t, _) ->
F.fprintf f "%a %a" F.fprintf f "%a %a"
(pp_typ_full pe) t (pp_typ_full pe) t
Ident.pp_fieldname fld)) struct_typ.instance_fields Ident.pp_fieldname fld)) struct_typ.instance_fields
@ -2029,7 +2026,7 @@ and pp_type_decl pe pp_base pp_size f = function
(pp_seq (fun f (n, e) -> F.fprintf f " (%a, %a) " Mangled.pp n (pp_const pe) e)) econsts (pp_seq (fun f (n, e) -> F.fprintf f " (%a, %a) " Mangled.pp n (pp_const pe) e)) econsts
(** Pretty print a type with all the details, using the C syntax. *) (** Pretty print a type with all the details, using the C syntax. *)
and pp_typ_full pe = pp_type_decl pe (fun fmt () -> ()) pp_exp_full and pp_typ_full pe = pp_type_decl pe (fun _ () -> ()) pp_exp_full
(** Pretty print an expression. *) (** Pretty print an expression. *)
and _pp_exp pe0 pp_t f e0 = and _pp_exp pe0 pp_t f e0 =
@ -2060,7 +2057,7 @@ and _pp_exp pe0 pp_t f e0 =
| BinOp (op, Const c, e2) when !Config.smt_output -> print_binop_stm_output (Const c) op e2 | BinOp (op, Const c, e2) when !Config.smt_output -> print_binop_stm_output (Const c) op e2
| BinOp (op, e1, e2) -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 | BinOp (op, e1, e2) -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2
| Lvar pv -> pp_pvar pe f pv | Lvar pv -> pp_pvar pe f pv
| Lfield (e, fld, typ) -> F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld | Lfield (e, fld, _) -> F.fprintf f "%a.%a" pp_exp e Ident.pp_fieldname fld
| Lindex (e1, e2) -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 | Lindex (e1, e2) -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2
| Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s | Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s
end); end);
@ -2108,7 +2105,7 @@ let d_texp_full (te: exp) = L.add_print_action (L.PTtexp_full, Obj.repr te)
(** Pretty print an offset *) (** Pretty print an offset *)
let pp_offset pe f = function let pp_offset pe f = function
| Off_fld (fld, typ) -> F.fprintf f "%a" Ident.pp_fieldname fld | Off_fld (fld, _) -> F.fprintf f "%a" Ident.pp_fieldname fld
| Off_index exp -> F.fprintf f "%a" (pp_exp pe) exp | Off_index exp -> F.fprintf f "%a" (pp_exp pe) exp
(** dump an offset. *) (** dump an offset. *)
@ -2184,7 +2181,7 @@ let pp_instr pe0 f instr =
(pp_typ pe) t (pp_typ pe) t
(pp_exp pe) e2 (pp_exp pe) e2
Location.pp loc Location.pp loc
| Prune (cond, loc, true_branch, ik) -> | Prune (cond, loc, true_branch, _) ->
F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch Location.pp loc F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch Location.pp loc
| Call (ret_ids, e, arg_ts, loc, cf) -> | Call (ret_ids, e, arg_ts, loc, cf) ->
(match ret_ids with (match ret_ids with
@ -2209,7 +2206,7 @@ let pp_instr pe0 f instr =
F.fprintf f "STACKOP.%s; %a" s Location.pp loc F.fprintf f "STACKOP.%s; %a" s Location.pp loc
| Declare_locals (ptl, loc) -> | Declare_locals (ptl, loc) ->
(* let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a:%a" (pp_pvar pe) pvar (pp_typ_full pe) typ in *) (* let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a:%a" (pp_pvar pe) pvar (pp_typ_full pe) typ in *)
let pp_pvar_typ fmt (pvar, typ) = F.fprintf fmt "%a" (pp_pvar pe) pvar in let pp_pvar_typ fmt (pvar, _) = F.fprintf fmt "%a" (pp_pvar pe) pvar in
F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl Location.pp loc F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl Location.pp loc
| Goto_node (e, loc) -> | Goto_node (e, loc) ->
F.fprintf f "Goto_node %a %a" (pp_exp pe) e Location.pp loc F.fprintf f "Goto_node %a %a" (pp_exp pe) e Location.pp loc
@ -2218,7 +2215,7 @@ let pp_instr pe0 f instr =
let has_block_prefix s = let has_block_prefix s =
match Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) s with match Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) s with
| s1:: s2:: _ -> true | _ :: _ :: _ -> true
| _ -> false | _ -> false
(** Check if a pvar is a local pointing to a block in objc *) (** Check if a pvar is a local pointing to a block in objc *)
@ -2239,20 +2236,20 @@ let rec typ_iter_types (f : typ -> unit) typ =
| Tvoid | Tvoid
| Tfun _ -> | Tfun _ ->
() ()
| Tptr (t', pk) -> | Tptr (t', _) ->
typ_iter_types f t' typ_iter_types f t'
| Tstruct struct_typ -> | Tstruct struct_typ ->
IList.iter (fun (_, t, _) -> typ_iter_types f t) struct_typ.instance_fields IList.iter (fun (_, t, _) -> typ_iter_types f t) struct_typ.instance_fields
| Tarray (t, e) -> | Tarray (t, e) ->
typ_iter_types f t; typ_iter_types f t;
exp_iter_types f e exp_iter_types f e
| Tenum econsts -> | Tenum _ ->
() ()
(** Iterate over all the subtypes in the type (including the type itself) *) (** Iterate over all the subtypes in the type (including the type itself) *)
and exp_iter_types f e = and exp_iter_types f e =
match e with match e with
| Var id -> () | Var _ -> ()
| Const (Cexn e1) -> | Const (Cexn e1) ->
exp_iter_types f e1 exp_iter_types f e1
| Const (Ctuple el) -> | Const (Ctuple el) ->
@ -2262,48 +2259,48 @@ and exp_iter_types f e =
| Cast (t, e1) -> | Cast (t, e1) ->
typ_iter_types f t; typ_iter_types f t;
exp_iter_types f e1 exp_iter_types f e1
| UnOp (op, e1, typo) -> | UnOp (_, e1, typo) ->
exp_iter_types f e1; exp_iter_types f e1;
(match typo with (match typo with
| Some t -> typ_iter_types f t | Some t -> typ_iter_types f t
| None -> ()) | None -> ())
| BinOp (op, e1, e2) -> | BinOp (_, e1, e2) ->
exp_iter_types f e1; exp_iter_types f e1;
exp_iter_types f e2 exp_iter_types f e2
| Lvar id -> | Lvar _ ->
() ()
| Lfield (e1, fld, typ) -> | Lfield (e1, _, typ) ->
exp_iter_types f e1; exp_iter_types f e1;
typ_iter_types f typ typ_iter_types f typ
| Lindex (e1, e2) -> | Lindex (e1, e2) ->
exp_iter_types f e1; exp_iter_types f e1;
exp_iter_types f e2 exp_iter_types f e2
| Sizeof (t, s) -> | Sizeof (t, _) ->
typ_iter_types f t typ_iter_types f t
(** Iterate over all the types (and subtypes) in the instruction *) (** Iterate over all the types (and subtypes) in the instruction *)
let instr_iter_types f instr = match instr with let instr_iter_types f instr = match instr with
| Letderef (id, e, t, loc) -> | Letderef (_, e, t, _) ->
exp_iter_types f e; exp_iter_types f e;
typ_iter_types f t typ_iter_types f t
| Set (e1, t, e2, loc) -> | Set (e1, t, e2, _) ->
exp_iter_types f e1; exp_iter_types f e1;
typ_iter_types f t; typ_iter_types f t;
exp_iter_types f e2 exp_iter_types f e2
| Prune (cond, loc, true_branch, ik) -> | Prune (cond, _, _, _) ->
exp_iter_types f cond exp_iter_types f cond
| Call (ret_ids, e, arg_ts, loc, cf) -> | Call (_, e, arg_ts, _, _) ->
exp_iter_types f e; exp_iter_types f e;
IList.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) -> | Nullify (_, _, _) ->
() ()
| Abstract loc -> | Abstract _ ->
() ()
| Remove_temps (temps, loc) -> | Remove_temps (_, _) ->
() ()
| Stackop (stackop, loc) -> | Stackop (_, _) ->
() ()
| Declare_locals (ptl, loc) -> | Declare_locals (ptl, _) ->
IList.iter (fun (_, t) -> typ_iter_types f t) ptl IList.iter (fun (_, t) -> typ_iter_types f t) ptl
| Goto_node _ -> | Goto_node _ ->
() ()
@ -2334,8 +2331,8 @@ let pp_atom pe0 f a =
F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2 F.fprintf f "%a = %a" (pp_exp pe) e1 (pp_exp pe) e2
| PP_LATEX -> | PP_LATEX ->
F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2) F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2)
| Aneq ((Const (Cattribute a) as ea), e) | Aneq ((Const (Cattribute _) as ea), e)
| Aneq (e, (Const (Cattribute a) as ea)) -> | Aneq (e, (Const (Cattribute _) as ea)) ->
F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e
| Aneq (e1, e2) -> | Aneq (e1, e2) ->
(match pe.pe_kind with (match pe.pe_kind with
@ -2435,9 +2432,9 @@ end = struct
let rec process_sexp env = function let rec process_sexp env = function
| Eexp _ -> () | Eexp _ -> ()
| Earray (_, esel, _) -> | Earray (_, esel, _) ->
IList.iter (fun (e, se) -> process_sexp env se) esel IList.iter (fun (_, se) -> process_sexp env se) esel
| Estruct (fsel, _) -> | Estruct (fsel, _) ->
IList.iter (fun (f, se) -> process_sexp env se) fsel IList.iter (fun (_, se) -> process_sexp env se) fsel
(** Process one hpred, updating env *) (** Process one hpred, updating env *)
let rec process_hpred env = function let rec process_hpred env = function
@ -2504,15 +2501,15 @@ let inst_new_loc loc inst = match inst with
| Iabstraction -> inst | Iabstraction -> inst
| Iactual_precondition -> inst | Iactual_precondition -> inst
| Ialloc -> inst | Ialloc -> inst
| Iformal (zf, ncf) -> inst | Iformal _ -> inst
| Iinitial -> inst | Iinitial -> inst
| Ilookup -> inst | Ilookup -> inst
| Inone -> inst | Inone -> inst
| Inullify -> inst | Inullify -> inst
| Irearrange (zf, ncf, n, pos) -> Irearrange (zf, ncf, loc.Location.line, pos) | Irearrange (zf, ncf, _, pos) -> Irearrange (zf, ncf, loc.Location.line, pos)
| Itaint -> inst | Itaint -> inst
| Iupdate (zf, ncf, n, pos) -> Iupdate (zf, ncf, loc.Location.line, pos) | Iupdate (zf, ncf, _, pos) -> Iupdate (zf, ncf, loc.Location.line, pos)
| Ireturn_from_call n -> Ireturn_from_call loc.Location.line | Ireturn_from_call _ -> Ireturn_from_call loc.Location.line
(** return a string representing the inst *) (** return a string representing the inst *)
let inst_to_string inst = let inst_to_string inst =
@ -2560,14 +2557,14 @@ let inst_zero_flag = function
| Iabstraction -> None | Iabstraction -> None
| Iactual_precondition -> None | Iactual_precondition -> None
| Ialloc -> None | Ialloc -> None
| Iformal (zf, ncf) -> zf | Iformal (zf, _) -> zf
| Iinitial -> None | Iinitial -> None
| Ilookup -> None | Ilookup -> None
| Inone -> None | Inone -> None
| Inullify -> None | Inullify -> None
| Irearrange (zf, ncf, n, _) -> zf | Irearrange (zf, _, _, _) -> zf
| Itaint -> None | Itaint -> None
| Iupdate (zf, ncf, n, _) -> zf | Iupdate (zf, _, _, _) -> zf
| Ireturn_from_call _ -> None | Ireturn_from_call _ -> None
(** Set the null case flag of the inst. *) (** Set the null case flag of the inst. *)
@ -2652,7 +2649,7 @@ and pp_hpred_env pe0 envo f hpred =
begin match hpred with begin match hpred with
| Hpointsto (e, se, te) -> | Hpointsto (e, se, te) ->
let pe' = match (e, se) with let pe' = match (e, se) with
| Lvar pvar, Eexp (Var id, inst) when not (pvar_is_global pvar) -> | Lvar pvar, Eexp (Var _, _) when not (pvar_is_global pvar) ->
{ pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *) { pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *)
| _ -> pe in | _ -> pe in
(match pe'.pe_kind with (match pe'.pe_kind with
@ -2844,7 +2841,7 @@ let unsome_typ s = function
If not a sizeof, return the default type if given, otherwise raise an exception *) If not a sizeof, return the default type if given, otherwise raise an exception *)
let texp_to_typ default_opt = function let texp_to_typ default_opt = function
| Sizeof (t, _) -> t | Sizeof (t, _) -> t
| t -> | _ ->
unsome_typ "texp_to_typ" default_opt unsome_typ "texp_to_typ" default_opt
(** If a struct type with field f, return the type of f. (** If a struct type with field f, return the type of f.
@ -2853,8 +2850,8 @@ let struct_typ_fld default_opt f =
let def () = unsome_typ "struct_typ_fld" default_opt in let def () = unsome_typ "struct_typ_fld" default_opt in
function function
| Tstruct struct_typ -> | Tstruct struct_typ ->
(try (fun (x, y, z) -> y) (try (fun (_, y, _) -> y)
(IList.find (fun (_f, t, ann) -> (IList.find (fun (_f, _, _) ->
Ident.fieldname_equal _f f) struct_typ.instance_fields) Ident.fieldname_equal _f f) struct_typ.instance_fields)
with Not_found -> def ()) with Not_found -> def ())
| _ -> def () | _ -> def ()
@ -2863,14 +2860,14 @@ let struct_typ_fld default_opt f =
If not, return the default type if given, otherwise raise an exception *) If not, return the default type if given, otherwise raise an exception *)
let array_typ_elem default_opt = function let array_typ_elem default_opt = function
| Tarray (t_el, _) -> t_el | Tarray (t_el, _) -> t_el
| t -> | _ ->
unsome_typ "array_typ_elem" default_opt unsome_typ "array_typ_elem" default_opt
(** Return the root of [lexp]. *) (** Return the root of [lexp]. *)
let rec root_of_lexp lexp = match lexp with let rec root_of_lexp lexp = match lexp with
| Var _ -> lexp | Var _ -> lexp
| Const _ -> lexp | Const _ -> lexp
| Cast (t, e) -> root_of_lexp e | Cast (_, e) -> root_of_lexp e
| UnOp _ | BinOp _ -> lexp | UnOp _ | BinOp _ -> lexp
| Lvar _ -> lexp | Lvar _ -> lexp
| Lfield(e, _, _) -> root_of_lexp e | Lfield(e, _, _) -> root_of_lexp e
@ -2928,7 +2925,7 @@ let exp_lt e1 e2 =
(** {2 Functions for computing program variables} *) (** {2 Functions for computing program variables} *)
let rec exp_fpv = function let rec exp_fpv = function
| Var id -> [] | Var _ -> []
| Const (Cexn e) -> exp_fpv e | Const (Cexn e) -> exp_fpv e
| Const (Ctuple el) -> exp_list_fpv el | Const (Ctuple el) -> exp_list_fpv el
| Const _ -> [] | Const _ -> []
@ -2946,11 +2943,11 @@ let atom_fpv = function
| Aneq (e1, e2) -> exp_fpv e1 @ exp_fpv e2 | Aneq (e1, e2) -> exp_fpv e1 @ exp_fpv e2
let rec strexp_fpv = function let rec strexp_fpv = function
| Eexp (e, inst) -> exp_fpv e | Eexp (e, _) -> exp_fpv e
| Estruct (fld_se_list, inst) -> | Estruct (fld_se_list, _) ->
let f (_, se) = strexp_fpv se in let f (_, se) = strexp_fpv se in
IList.flatten (IList.map f fld_se_list) IList.flatten (IList.map f fld_se_list)
| Earray (size, idx_se_list, inst) -> | Earray (size, idx_se_list, _) ->
let fpv_in_size = exp_fpv size in let fpv_in_size = exp_fpv size in
let f (idx, se) = exp_fpv idx @ strexp_fpv se in let f (idx, se) = exp_fpv idx @ strexp_fpv se in
fpv_in_size @ IList.flatten (IList.map f idx_se_list) fpv_in_size @ IList.flatten (IList.map f idx_se_list)
@ -3096,7 +3093,7 @@ let rec exp_fav_add fav = function
| Const _ -> () | Const _ -> ()
| Cast (_, e) | UnOp (_, e, _) -> exp_fav_add fav e | Cast (_, e) | UnOp (_, e, _) -> exp_fav_add fav e
| BinOp (_, e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2 | BinOp (_, e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2
| Lvar id -> () (* do nothing since we only count non-program variables *) | Lvar _ -> () (* do nothing since we only count non-program variables *)
| Lfield (e, _, _) -> exp_fav_add fav e | Lfield (e, _, _) -> exp_fav_add fav e
| Lindex (e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2 | Lindex (e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2
| Sizeof _ -> () | Sizeof _ -> ()
@ -3121,25 +3118,20 @@ let atom_fav =
(** Atoms do not contain binders *) (** Atoms do not contain binders *)
let atom_av_add = atom_fav_add let atom_av_add = atom_fav_add
let hpara_fav_add fav para = () (* Global invariant: hpara is closed *)
let hpara_dll_fav_add fav para = () (* Global invariant: hpara_dll is closed *)
let rec strexp_fav_add fav = function let rec strexp_fav_add fav = function
| Eexp (e, inst) -> exp_fav_add fav e | Eexp (e, _) -> exp_fav_add fav e
| Estruct (fld_se_list, inst) -> | Estruct (fld_se_list, _) ->
IList.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) -> | Earray (size, idx_se_list, _) ->
exp_fav_add fav size; exp_fav_add fav size;
IList.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 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 | Hpointsto (base, sexp, te) -> exp_fav_add fav base; strexp_fav_add fav sexp; exp_fav_add fav te
| Hlseg (_, para, e1, e2, elist) -> | Hlseg (_, _, e1, e2, elist) ->
hpara_fav_add fav para;
exp_fav_add fav e1; exp_fav_add fav e2; exp_fav_add fav e1; exp_fav_add fav e2;
IList.iter (exp_fav_add fav) elist IList.iter (exp_fav_add fav) elist
| Hdllseg (_, para, e1, e2, e3, e4, elist) -> | Hdllseg (_, _, 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 e1; exp_fav_add fav e2;
exp_fav_add fav e3; exp_fav_add fav e4; exp_fav_add fav e3; exp_fav_add fav e4;
IList.iter (exp_fav_add fav) elist IList.iter (exp_fav_add fav) elist
@ -3387,7 +3379,7 @@ let rec typ_sub (subst: subst) typ =
Tptr (typ_sub subst t', pk) Tptr (typ_sub subst t', pk)
| Tarray (t, e) -> | Tarray (t, e) ->
Tarray (typ_sub subst t, exp_sub subst e) Tarray (typ_sub subst t, exp_sub subst e)
| Tenum econsts -> | Tenum _ ->
typ typ
and exp_sub (subst: subst) e = and exp_sub (subst: subst) e =
@ -3418,7 +3410,7 @@ and exp_sub (subst: subst) e =
let e1' = exp_sub subst e1 in let e1' = exp_sub subst e1 in
let e2' = exp_sub subst e2 in let e2' = exp_sub subst e2 in
BinOp (op, e1', e2') BinOp (op, e1', e2')
| Lvar id -> | Lvar _ ->
e e
| Lfield (e1, fld, typ) -> | Lfield (e1, fld, typ) ->
let e1' = exp_sub subst e1 in let e1' = exp_sub subst e1 in
@ -3447,13 +3439,13 @@ let instr_sub (subst: subst) instr =
| Call (ret_ids, e, arg_ts, loc, cf) -> | Call (ret_ids, e, arg_ts, loc, cf) ->
let arg_s (e, t) = (exp_s e, typ_s t) in let arg_s (e, t) = (exp_s e, typ_s t) in
Call (IList.map id_s ret_ids, exp_s e, IList.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) -> | Nullify _ ->
instr instr
| Abstract loc -> | Abstract _ ->
instr instr
| Remove_temps (temps, loc) -> | Remove_temps (temps, loc) ->
Remove_temps (IList.map id_s temps, loc) Remove_temps (IList.map id_s temps, loc)
| Stackop (stackop, loc) -> | Stackop _ ->
instr instr
| Declare_locals (ptl, loc) -> | Declare_locals (ptl, loc) ->
let pt_s (pv, t) = (pv, typ_s t) in let pt_s (pv, t) = (pv, typ_s t) in
@ -3546,7 +3538,7 @@ let rec exp_compare_structural e1 e2 exp_map =
(* assume e1 and e2 equal, enforce by adding to [exp_map] *) (* assume e1 and e2 equal, enforce by adding to [exp_map] *)
0, ExpMap.add e1 e2 exp_map in 0, ExpMap.add e1 e2 exp_map in
match (e1, e2) with match (e1, e2) with
| Var id1, Var id2 -> compare_exps_with_map e1 e2 exp_map | Var _, Var _ -> compare_exps_with_map e1 e2 exp_map
| UnOp (o1, e1, to1), UnOp (o2, e2, to2) -> | UnOp (o1, e1, to1), UnOp (o2, e2, to2) ->
let n = unop_compare o1 o2 in let n = unop_compare o1 o2 in
if n <> 0 then n, exp_map if n <> 0 then n, exp_map
@ -3563,7 +3555,7 @@ let rec exp_compare_structural e1 e2 exp_map =
| Cast (t1, e1), Cast(t2, e2) -> | Cast (t1, e1), Cast(t2, e2) ->
let n, exp_map = exp_compare_structural e1 e2 exp_map in let n, exp_map = exp_compare_structural e1 e2 exp_map in
(if n <> 0 then n else typ_compare t1 t2), exp_map (if n <> 0 then n else typ_compare t1 t2), exp_map
| Lvar i1, Lvar i2 -> compare_exps_with_map e1 e2 exp_map | Lvar _, Lvar _ -> compare_exps_with_map e1 e2 exp_map
| Lfield (e1, f1, t1), Lfield (e2, f2, t2) -> | Lfield (e1, f1, t1), Lfield (e2, f2, t2) ->
let n, exp_map = exp_compare_structural e1 e2 exp_map in let n, exp_map = exp_compare_structural e1 e2 exp_map in
(if n <> 0 then n (if n <> 0 then n
@ -3596,26 +3588,26 @@ let instr_compare_structural instr1 instr2 exp_map =
ids1 ids1
ids2 in ids2 in
match instr1, instr2 with match instr1, instr2 with
| Letderef (id1, e1, t1, loc1), Letderef (id2, e2, t2, loc2) -> | Letderef (id1, e1, t1, _), Letderef (id2, e2, t2, _) ->
let n, exp_map = exp_compare_structural (Var id1) (Var id2) exp_map in let n, exp_map = exp_compare_structural (Var id1) (Var id2) exp_map in
if n <> 0 then n, exp_map if n <> 0 then n, exp_map
else else
let n, exp_map = exp_compare_structural e1 e2 exp_map in let n, exp_map = exp_compare_structural e1 e2 exp_map in
(if n <> 0 then n else typ_compare t1 t2), exp_map (if n <> 0 then n else typ_compare t1 t2), exp_map
| Set (e11, t1, e21, loc1), Set (e12, t2, e22, loc2) -> | Set (e11, t1, e21, _), Set (e12, t2, e22, _) ->
let n, exp_map = exp_compare_structural e11 e12 exp_map in let n, exp_map = exp_compare_structural e11 e12 exp_map in
if n <> 0 then n, exp_map if n <> 0 then n, exp_map
else else
let n = typ_compare t1 t2 in let n = typ_compare t1 t2 in
if n <> 0 then n, exp_map if n <> 0 then n, exp_map
else exp_compare_structural e21 e22 exp_map else exp_compare_structural e21 e22 exp_map
| Prune (cond1, loc1, true_branch1, ik1), Prune (cond2, loc2, true_branch2, ik2) -> | Prune (cond1, _, true_branch1, ik1), Prune (cond2, _, true_branch2, ik2) ->
let n, exp_map = exp_compare_structural cond1 cond2 exp_map in let n, exp_map = exp_compare_structural cond1 cond2 exp_map in
(if n <> 0 then n (if n <> 0 then n
else let n = bool_compare true_branch1 true_branch2 in else let n = bool_compare true_branch1 true_branch2 in
if n <> 0 then n if n <> 0 then n
else Pervasives.compare ik1 ik2), 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) -> | Call (ret_ids1, e1, arg_ts1, _, cf1), Call (ret_ids2, e2, arg_ts2, _, cf2) ->
let args_compare_structural args1 args2 exp_map = let args_compare_structural args1 args2 exp_map =
let n = Pervasives.compare (IList.length args1) (IList.length args2) in let n = Pervasives.compare (IList.length args1) (IList.length args2) in
if n <> 0 then n, exp_map if n <> 0 then n, exp_map
@ -3634,15 +3626,15 @@ let instr_compare_structural instr1 instr2 exp_map =
else else
let n, exp_map = args_compare_structural arg_ts1 arg_ts2 exp_map in let n, exp_map = args_compare_structural arg_ts1 arg_ts2 exp_map in
(if n <> 0 then n else call_flags_compare cf1 cf2), exp_map (if n <> 0 then n else call_flags_compare cf1 cf2), exp_map
| Nullify (pvar1, loc1, deallocate1), Nullify (pvar2, loc2, deallocate2) -> | Nullify (pvar1, _, deallocate1), Nullify (pvar2, _, deallocate2) ->
let n, exp_map = exp_compare_structural (Lvar pvar1) (Lvar pvar2) exp_map in let n, exp_map = exp_compare_structural (Lvar pvar1) (Lvar pvar2) exp_map in
(if n <> 0 then n else bool_compare deallocate1 deallocate2), exp_map (if n <> 0 then n else bool_compare deallocate1 deallocate2), exp_map
| Abstract loc1, Abstract loc2 -> 0, exp_map | Abstract _, Abstract _ -> 0, exp_map
| Remove_temps (temps1, loc1), Remove_temps (temps2, loc2) -> | Remove_temps (temps1, _), Remove_temps (temps2, _) ->
id_list_compare_structural temps1 temps2 exp_map id_list_compare_structural temps1 temps2 exp_map
| Stackop (stackop1, loc1), Stackop (stackop2, loc2) -> | Stackop (stackop1, _), Stackop (stackop2, _) ->
Pervasives.compare stackop1 stackop2, exp_map Pervasives.compare stackop1 stackop2, exp_map
| Declare_locals (ptl1, loc1), Declare_locals (ptl2, loc2) -> | Declare_locals (ptl1, _), Declare_locals (ptl2, _) ->
let n = Pervasives.compare (IList.length ptl1) (IList.length ptl2) in let n = Pervasives.compare (IList.length ptl1) (IList.length ptl2) in
if n <> 0 then n, exp_map if n <> 0 then n, exp_map
else else
@ -3655,7 +3647,7 @@ let instr_compare_structural instr1 instr2 exp_map =
(0, exp_map) (0, exp_map)
ptl1 ptl1
ptl2 ptl2
| Goto_node (e1, loc1), Goto_node (e2, loc2) -> | Goto_node (e1, _), Goto_node (e2, _) ->
exp_compare_structural e1 e2 exp_map exp_compare_structural e1 e2 exp_map
| _ -> instr_compare instr1 instr2, exp_map | _ -> instr_compare instr1 instr2, exp_map
@ -3666,8 +3658,6 @@ let hpred_sub subst =
let f (e, inst_opt) = (exp_sub subst e, inst_opt) in let f (e, inst_opt) = (exp_sub subst e, inst_opt) in
hpred_expmap f hpred_expmap f
let hpara_sub subst para = para
(** {2 Functions for replacing occurrences of expressions.} *) (** {2 Functions for replacing occurrences of expressions.} *)
let exp_replace_exp epairs e = let exp_replace_exp epairs e =
@ -3888,7 +3878,7 @@ let pvar_to_callee pname pvar = match pvar.pv_kind with
let exp_get_offsets exp = let exp_get_offsets exp =
let rec f offlist_past e = match e with let rec f offlist_past e = match e with
| Var _ | Const _ | UnOp _ | BinOp _ | Lvar _ | Sizeof _ -> offlist_past | Var _ | Const _ | UnOp _ | BinOp _ | Lvar _ | Sizeof _ -> offlist_past
| Cast(t, sub_exp) -> f offlist_past sub_exp | Cast(_, sub_exp) -> f offlist_past sub_exp
| Lfield(sub_exp, fldname, typ) -> f (Off_fld (fldname, typ):: offlist_past) sub_exp | Lfield(sub_exp, fldname, typ) -> f (Off_fld (fldname, typ):: offlist_past) sub_exp
| Lindex(sub_exp, e) -> f (Off_index e :: offlist_past) sub_exp in | Lindex(sub_exp, e) -> f (Off_index e :: offlist_past) sub_exp in
f [] exp f [] exp
@ -3927,7 +3917,7 @@ let hpara_instantiate para e1 e2 elist =
try (IList.map2 g para.svars elist) try (IList.map2 g para.svars elist)
with Invalid_argument _ -> assert false in with Invalid_argument _ -> assert false in
let ids_evars = let ids_evars =
let g id = Ident.create_fresh Ident.kprimed in let g _ = Ident.create_fresh Ident.kprimed in
IList.map g para.evars in IList.map g para.evars in
let subst_for_evars = let subst_for_evars =
let g id id' = (id, Var id') in let g id id' = (id, Var id') in
@ -3946,7 +3936,7 @@ let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist =
try (IList.map2 g para.svars_dll elist) try (IList.map2 g para.svars_dll elist)
with Invalid_argument _ -> assert false in with Invalid_argument _ -> assert false in
let ids_evars = let ids_evars =
let g id = Ident.create_fresh Ident.kprimed in let g _ = Ident.create_fresh Ident.kprimed in
IList.map g para.evars_dll in IList.map g para.evars_dll in
let subst_for_evars = let subst_for_evars =
let g id id' = (id, Var id') in let g id id' = (id, Var id') in

6
infer/src/backend/sil.mli
Unescape View File

@ -852,7 +852,7 @@ val attribute_to_string : printenv -> attribute -> string
val dexp_to_string : dexp -> string val dexp_to_string : dexp -> string
(** Pretty print a dexp. *) (** Pretty print a dexp. *)
val pp_dexp : printenv -> Format.formatter -> dexp -> unit val pp_dexp : Format.formatter -> dexp -> unit
(** Pretty print an expression. *) (** Pretty print an expression. *)
val pp_exp : printenv -> Format.formatter -> exp -> unit val pp_exp : printenv -> Format.formatter -> exp -> unit
@ -1151,8 +1151,6 @@ val hpred_fav_add : fav -> hpred -> unit
val hpred_fav : hpred -> fav val hpred_fav : hpred -> fav
val hpara_fav_add : fav -> hpara -> unit
(** Variables in hpara, excluding bound vars in the body *) (** Variables in hpara, excluding bound vars in the body *)
val hpara_shallow_av : hpara -> fav val hpara_shallow_av : hpara -> fav
@ -1271,8 +1269,6 @@ val instr_sub : subst -> instr -> instr
val hpred_sub : subst -> hpred -> hpred val hpred_sub : subst -> hpred -> hpred
val hpara_sub : subst -> hpara -> hpara
(** {2 Functions for replacing occurrences of expressions.} *) (** {2 Functions for replacing occurrences of expressions.} *)
(** The first parameter should define a partial function. (** The first parameter should define a partial function.

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

@ -113,12 +113,12 @@ module Jprop = struct
let filter (f: 'a t -> 'b option) jpl = let filter (f: 'a t -> 'b option) jpl =
let rec do_filter acc = function let rec do_filter acc = function
| [] -> acc | [] -> acc
| (Prop (_, p) as jp) :: jpl -> | (Prop _ as jp) :: jpl ->
(match f jp with (match f jp with
| Some x -> | Some x ->
do_filter (x:: acc) jpl do_filter (x:: acc) jpl
| None -> do_filter acc jpl) | None -> do_filter acc jpl)
| (Joined (_, p, jp1, jp2) as jp) :: jpl -> | (Joined (_, _, jp1, jp2) as jp) :: jpl ->
(match f jp with (match f jp with
| Some x -> | Some x ->
do_filter (x:: acc) jpl do_filter (x:: acc) jpl
@ -142,13 +142,13 @@ end
module Visitedset = module Visitedset =
Set.Make (struct Set.Make (struct
type t = int * int list type t = int * int list
let compare (node_id1, line1) (node_id2, line2) = int_compare node_id1 node_id2 let compare (node_id1, _) (node_id2, _) = int_compare node_id1 node_id2
end) end)
let visited_str vis = let visited_str vis =
let s = ref "" in let s = ref "" in
let lines = ref IntSet.empty in let lines = ref IntSet.empty in
let do_one (node, ns) = let do_one (_, ns) =
(* if IList.length ns > 1 then (* if IList.length ns > 1 then
begin begin
let ss = ref "" in let ss = ref "" in
@ -180,7 +180,7 @@ end = struct
let spec_fav (spec: Prop.normal spec) : Sil.fav = let spec_fav (spec: Prop.normal spec) : Sil.fav =
let fav = Sil.fav_new () in let fav = Sil.fav_new () in
Jprop.fav_add_dfs fav spec.pre; Jprop.fav_add_dfs fav spec.pre;
IList.iter (fun (p, path) -> Prop.prop_fav_add_dfs fav p) spec.posts; IList.iter (fun (p, _) -> Prop.prop_fav_add_dfs fav p) spec.posts;
fav fav
let spec_sub sub spec = let spec_sub sub spec =
@ -432,7 +432,7 @@ let pp_summary_no_stats_specs fmt summary =
F.fprintf fmt "%a@\n" pp_pair (describe_phase summary); F.fprintf fmt "%a@\n" pp_pair (describe_phase summary);
F.fprintf fmt "Dependency_map: @[%a@]@\n" pp_dependency_map summary.dependency_map F.fprintf fmt "Dependency_map: @[%a@]@\n" pp_dependency_map summary.dependency_map
let pp_stats_html err_log fmt stats = let pp_stats_html err_log fmt =
Errlog.pp_html [] fmt err_log Errlog.pp_html [] fmt err_log
let get_specs_from_payload summary = let get_specs_from_payload summary =
@ -452,7 +452,7 @@ let pp_summary pe whole_seconds fmt summary =
Io_infer.Html.pp_start_color fmt Black; Io_infer.Html.pp_start_color fmt Black;
F.fprintf fmt "@\n%a" pp_summary_no_stats_specs summary; F.fprintf fmt "@\n%a" pp_summary_no_stats_specs summary;
Io_infer.Html.pp_end_color fmt (); Io_infer.Html.pp_end_color fmt ();
pp_stats_html err_log fmt summary.stats; pp_stats_html err_log fmt;
Io_infer.Html.pp_hline fmt (); Io_infer.Html.pp_hline fmt ();
F.fprintf fmt "<LISTING>@\n"; F.fprintf fmt "<LISTING>@\n";
pp_specs pe fmt (get_specs_from_payload summary); pp_specs pe fmt (get_specs_from_payload summary);
@ -466,7 +466,9 @@ let pp_summary pe whole_seconds fmt summary =
(** Print the spec table *) (** Print the spec table *)
let pp_spec_table pe whole_seconds fmt () = let pp_spec_table pe whole_seconds fmt () =
Procname.Hash.iter (fun proc_name (summ, orig) -> F.fprintf fmt "PROC %a@\n%a@\n" Procname.pp proc_name (pp_summary pe whole_seconds) summ) spec_tbl Procname.Hash.iter (fun proc_name (summ, _) ->
F.fprintf fmt "PROC %a@\n%a@\n" Procname.pp proc_name (pp_summary pe whole_seconds) summ
) spec_tbl
let empty_stats calls in_out_calls_opt = let empty_stats calls in_out_calls_opt =
{ stats_time = 0.0; { stats_time = 0.0;
@ -752,7 +754,7 @@ let get_specs proc_name =
let get_phase proc_name = let get_phase proc_name =
match get_summary_origin proc_name with match get_summary_origin proc_name with
| None -> raise (Failure ("Specs.get_phase: " ^ (Procname.to_string proc_name) ^ " Not_found")) | None -> raise (Failure ("Specs.get_phase: " ^ (Procname.to_string proc_name) ^ " Not_found"))
| Some (summary, origin) -> summary.phase | Some (summary, _) -> summary.phase
(** Set the current status for the proc *) (** Set the current status for the proc *)
let set_status proc_name status = let set_status proc_name status =
@ -766,7 +768,7 @@ let mk_initial_dependency_map proc_list : dependency_map_t =
(** Re-initialize a dependency map *) (** Re-initialize a dependency map *)
let re_initialize_dependency_map dependency_map = let re_initialize_dependency_map dependency_map =
Procname.Map.map (fun dep_proc -> - 1) dependency_map Procname.Map.map (fun _ -> - 1) dependency_map
(** Update the dependency map of [proc_name] with the current (** Update the dependency map of [proc_name] with the current
timestamps of the dependents *) timestamps of the dependents *)
@ -778,7 +780,7 @@ let update_dependency_map proc_name =
| Some (summary, origin) -> | Some (summary, origin) ->
let current_dependency_map = let current_dependency_map =
Procname.Map.mapi Procname.Map.mapi
(fun dep_proc old_stamp -> get_timestamp summary) (fun _ _ -> get_timestamp summary)
summary.dependency_map in summary.dependency_map in
set_summary_origin proc_name { summary with dependency_map = current_dependency_map } origin set_summary_origin proc_name { summary with dependency_map = current_dependency_map } origin

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

@ -61,7 +61,7 @@ type t = {
} }
let initial () = { let initial () = {
const_map = (fun node exp -> None); const_map = (fun _ _ -> None);
diverging_states_node = Paths.PathSet.empty; diverging_states_node = Paths.PathSet.empty;
diverging_states_proc = Paths.PathSet.empty; diverging_states_proc = Paths.PathSet.empty;
goto_node = None; goto_node = None;
@ -184,7 +184,7 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
let module S = (* set of nodes with normalized insructions *) let module S = (* set of nodes with normalized insructions *)
Set.Make(struct Set.Make(struct
type t = Cfg.Node.t * Sil.instr list type t = Cfg.Node.t * Sil.instr list
let compare (n1, instrs1) (n2, instrs2) = let compare (n1, _) (n2, _) =
Cfg.Node.compare n1 n2 Cfg.Node.compare n1 n2
end) in end) in
@ -221,7 +221,7 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
try try
let s = M.find (get_key node) map in let s = M.find (get_key node) map in
let elements = S.elements s in let elements = S.elements s in
let (_, node_normalized_instrs), others = let (_, node_normalized_instrs), _ =
let filter (node', _) = Cfg.Node.equal node node' in let filter (node', _) = Cfg.Node.equal node node' in
match IList.partition filter elements with match IList.partition filter elements with
| [this], others -> this, others | [this], others -> this, others
@ -325,11 +325,11 @@ type log_issue =
unit unit
let process_execution_failures (log_issue : log_issue) pname = let process_execution_failures (log_issue : log_issue) pname =
let do_failure node fs = let do_failure _ fs =
(* L.err "Node:%a node_ok:%d node_fail:%d@." Cfg.Node.pp node fs.node_ok fs.node_fail; *) (* L.err "Node:%a node_ok:%d node_fail:%d@." Cfg.Node.pp node fs.node_ok fs.node_fail; *)
match fs.node_ok, fs.first_failure with match fs.node_ok, fs.first_failure with
| 0, Some (loc, key, session, loc_trace, pre_opt, exn) -> | 0, Some (loc, key, _, loc_trace, pre_opt, exn) ->
let ex_name, desc, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in let ex_name, _, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in
let desc' = Localise.verbatim_desc ("exception: " ^ Localise.to_string ex_name) in let desc' = Localise.verbatim_desc ("exception: " ^ Localise.to_string ex_name) in
let exn' = Exceptions.Analysis_stops (desc', ml_loc_opt) in let exn' = Exceptions.Analysis_stops (desc', ml_loc_opt) in
log_issue log_issue

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

@ -15,7 +15,7 @@ module F = Format
let rec fldlist_assoc fld = function let rec fldlist_assoc fld = function
| [] -> raise Not_found | [] -> raise Not_found
| (fld', x, a):: l -> if Sil.fld_equal fld fld' then x else fldlist_assoc fld l | (fld', x, _):: l -> if Sil.fld_equal fld fld' then x else fldlist_assoc fld l
let rec unroll_type tenv typ off = let rec unroll_type tenv typ off =
match (typ, off) with match (typ, off) with
@ -127,7 +127,7 @@ let rec apply_offlist
let offlist' = (Sil.Off_index Sil.exp_zero):: offlist in let offlist' = (Sil.Off_index Sil.exp_zero):: offlist in
apply_offlist apply_offlist
pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst lookup_inst pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst lookup_inst
| (Sil.Off_fld (fld, _)):: offlist', Sil.Earray _ -> | (Sil.Off_fld _):: _, Sil.Earray _ ->
let offlist_new = Sil.Off_index(Sil.exp_zero) :: offlist in let offlist_new = Sil.Off_index(Sil.exp_zero) :: offlist in
apply_offlist apply_offlist
pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist_new f inst lookup_inst pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist_new f inst lookup_inst
@ -183,7 +183,7 @@ let rec apply_offlist
let res_e' = Sil.Var (Ident.create_fresh Ident.kprimed) in let res_e' = Sil.Var (Ident.create_fresh Ident.kprimed) in
(res_e', strexp, typ, None) (res_e', strexp, typ, None)
end end
| (Sil.Off_index idx):: offlist', _ -> | (Sil.Off_index _):: _, _ ->
pp_error(); pp_error();
raise (Exceptions.Internal_error (Localise.verbatim_desc "Array out of bounds in Symexec")) raise (Exceptions.Internal_error (Localise.verbatim_desc "Array out of bounds in Symexec"))
(* This case should not happen. The rearrangement should (* This case should not happen. The rearrangement should
@ -318,7 +318,7 @@ let rec execute_nullify_se = function
| Sil.Estruct (fsel, _) -> | Sil.Estruct (fsel, _) ->
let fsel' = IList.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.Estruct (fsel', Sil.inst_nullify)
| Sil.Earray (size, esel, inst) -> | Sil.Earray (size, esel, _) ->
let esel' = IList.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) Sil.Earray (size, esel', Sil.inst_nullify)
@ -510,7 +510,7 @@ let check_already_dereferenced pname cond prop =
| None -> | None ->
None in None in
match dereferenced_line with match dereferenced_line with
| Some (id, (n, pos)) -> | Some (id, (n, _)) ->
let desc = Errdesc.explain_null_test_after_dereference (Sil.Var id) (State.get_node ()) n (State.get_loc ()) in let desc = Errdesc.explain_null_test_after_dereference (Sil.Var id) (State.get_node ()) n (State.get_loc ()) in
let exn = let exn =
(Exceptions.Null_test_after_dereference (desc, __POS__)) in (Exceptions.Null_test_after_dereference (desc, __POS__)) in
@ -581,7 +581,7 @@ let resolve_method tenv class_name proc_name =
Some right_proc_name Some right_proc_name
else else
(match superclasses with (match superclasses with
| super_classname:: interfaces -> | super_classname:: _ ->
if not (Typename.Set.mem super_classname !visited) if not (Typename.Set.mem super_classname !visited)
then resolve super_classname then resolve super_classname
else None else None
@ -636,7 +636,7 @@ let lookup_java_typ_from_string tenv typ_str =
(** If the dynamic type of the receiver actual T_actual is a subtype of the reciever type T_formal (** If the dynamic type of the receiver actual T_actual is a subtype of the reciever type T_formal
in the signature of [pname], resolve [pname] to T_actual.[pname]. *) in the signature of [pname], resolve [pname] to T_actual.[pname]. *)
let resolve_virtual_pname cfg tenv prop actuals callee_pname call_flags : Procname.t list = let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Procname.t list =
let resolve receiver_exp pname prop = match resolve_typename prop receiver_exp with let resolve receiver_exp pname prop = match resolve_typename prop receiver_exp with
| Some class_name -> resolve_method tenv class_name pname | Some class_name -> resolve_method tenv class_name pname
| None -> pname in | None -> pname in
@ -704,7 +704,7 @@ let redirect_shared_ptr tenv cfg pname actual_params =
| Sil.Tstruct { Sil.csu = Csu.Class _; struct_name = Some cl_name } -> | Sil.Tstruct { Sil.csu = Csu.Class _; struct_name = Some cl_name } ->
let name = Mangled.to_string cl_name in let name = Mangled.to_string cl_name in
name = "shared_ptr" || name = "__shared_ptr" name = "shared_ptr" || name = "__shared_ptr"
| t -> false | _ -> false
with exn when exn_not_failure exn -> false in with exn when exn_not_failure exn -> false in
(* We pattern match over some specific library function, *) (* We pattern match over some specific library function, *)
(* so we make precise matching to distinghuis between *) (* so we make precise matching to distinghuis between *)
@ -732,7 +732,7 @@ let redirect_shared_ptr tenv cfg pname actual_params =
Procname.from_string_c_fun "__infer_shared_ptr_eqeq" Procname.from_string_c_fun "__infer_shared_ptr_eqeq"
| ("operator->" | "operator*"),[(_, t1)] when ptr_to_shared_ptr t1 -> | ("operator->" | "operator*"),[(_, t1)] when ptr_to_shared_ptr t1 ->
Procname.from_string_c_fun "__infer_shared_ptr_arrow" Procname.from_string_c_fun "__infer_shared_ptr_arrow"
| "~shared_ptr",[(_, t1)] -> | "~shared_ptr",[_] ->
Procname.from_string_c_fun "__infer_shared_ptr_destructor" Procname.from_string_c_fun "__infer_shared_ptr_destructor"
| _ -> pname in | _ -> pname in
if Procname.equal pname pname' then pname if Procname.equal pname pname' then pname
@ -780,7 +780,7 @@ let call_constructor_url_update_args pname actual_params =
| [this; (Sil.Const (Sil.Cstr s), atype)] -> | [this; (Sil.Const (Sil.Cstr s), atype)] ->
let parts = Str.split (Str.regexp_string "://") s in let parts = Str.split (Str.regexp_string "://") s in
(match parts with (match parts with
| frst:: parts -> | frst:: _ ->
if (frst = "http") || (frst = "ftp") || (frst = "https") || (frst = "mailto") || (frst = "jar") then if (frst = "http") || (frst = "ftp") || (frst = "https") || (frst = "mailto") || (frst = "jar") then
[this; (Sil.Const (Sil.Cstr frst), atype)] [this; (Sil.Const (Sil.Cstr frst), atype)]
else actual_params else actual_params
@ -800,7 +800,7 @@ let handle_special_cases_call tenv cfg pname actual_params =
(* This method handles ObjC method calls, in particular the fact that calling a method with nil *) (* This method handles ObjC method calls, in particular the fact that calling a method with nil *)
(* returns nil. The exec_call function is either standard call execution or execution of ObjC *) (* returns nil. The exec_call function is either standard call execution or execution of ObjC *)
(* getters and setters using a builtin. *) (* getters and setters using a builtin. *)
let handle_objc_method_call actual_pars actual_params pre tenv cfg ret_ids pdesc callee_pname loc let handle_objc_method_call actual_pars actual_params pre tenv ret_ids pdesc callee_pname loc
path exec_call = path exec_call =
let path_description = "Message "^(Procname.to_simplified_string callee_pname)^" with receiver nil returns nil." in let path_description = "Message "^(Procname.to_simplified_string callee_pname)^" with receiver nil returns nil." in
let receiver = (match actual_pars with let receiver = (match actual_pars with
@ -826,7 +826,7 @@ let handle_objc_method_call actual_pars actual_params pre tenv cfg ret_ids pdesc
(* can keep track of how this object became null, so that in a NPE we can separate it into a different error type *) (* can keep track of how this object became null, so that in a NPE we can separate it into a different error type *)
[(add_objc_null_attribute_or_nullify_result pre, path)] [(add_objc_null_attribute_or_nullify_result pre, path)]
else else
let res = exec_call tenv cfg ret_ids pdesc callee_pname loc actual_params pre path in let res = exec_call tenv ret_ids pdesc callee_pname loc actual_params pre path in
let is_undef = let is_undef =
Option.is_some (Prop.get_undef_attribute pre receiver) in Option.is_some (Prop.get_undef_attribute pre receiver) in
if !Config.footprint && not is_undef then if !Config.footprint && not is_undef then
@ -911,7 +911,7 @@ let add_constraints_on_retval pdesc prop ret_exp typ callee_pname callee_loc =
else add_ret_non_null ret_exp typ prop else add_ret_non_null ret_exp typ prop
let execute_letderef ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc prop_ = let execute_letderef ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc prop_ =
let execute_letderef_ pdesc tenv id rhs_exp loc acc_in iter = let execute_letderef_ pdesc tenv id loc acc_in iter =
let iter_ren = Prop.prop_iter_make_id_primed id iter in let iter_ren = Prop.prop_iter_make_id_primed id iter in
let prop_ren = Prop.prop_iter_to_prop iter_ren in let prop_ren = Prop.prop_iter_to_prop iter_ren in
match Prop.prop_iter_current iter_ren with match Prop.prop_iter_current iter_ren with
@ -944,7 +944,7 @@ let execute_letderef ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ
assert false in assert false in
try try
let n_rhs_exp, prop = exp_norm_check_arith pname prop_ rhs_exp in let n_rhs_exp, prop = exp_norm_check_arith pname prop_ rhs_exp in
let n_rhs_exp' = Prop.exp_collapse_consecutive_indices_prop prop typ n_rhs_exp in let n_rhs_exp' = Prop.exp_collapse_consecutive_indices_prop typ n_rhs_exp in
match check_constant_string_dereference n_rhs_exp' with match check_constant_string_dereference n_rhs_exp' with
| Some value -> | Some value ->
[Prop.conjoin_eq (Sil.Var id) value prop] [Prop.conjoin_eq (Sil.Var id) value prop]
@ -964,7 +964,7 @@ let execute_letderef ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ
else prop in else prop in
let iter_list = let iter_list =
Rearrange.rearrange ~report_deref_errors pdesc tenv n_rhs_exp' typ prop' loc in Rearrange.rearrange ~report_deref_errors pdesc tenv n_rhs_exp' typ prop' loc in
IList.rev (IList.fold_left (execute_letderef_ pdesc tenv id n_rhs_exp' loc) [] iter_list) IList.rev (IList.fold_left (execute_letderef_ pdesc tenv id loc) [] iter_list)
with Rearrange.ARRAY_ACCESS -> with Rearrange.ARRAY_ACCESS ->
if (!Config.array_level = 0) then assert false if (!Config.array_level = 0) then assert false
else else
@ -993,7 +993,7 @@ let execute_set ?(report_deref_errors=true) pname pdesc tenv lhs_exp typ rhs_exp
let n_lhs_exp, _prop' = exp_norm_check_arith pname prop_ lhs_exp in let n_lhs_exp, _prop' = exp_norm_check_arith pname prop_ lhs_exp in
let n_rhs_exp, prop = exp_norm_check_arith pname _prop' rhs_exp in let n_rhs_exp, prop = exp_norm_check_arith pname _prop' rhs_exp in
let prop = Prop.replace_objc_null prop n_lhs_exp n_rhs_exp in 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 n_lhs_exp' = Prop.exp_collapse_consecutive_indices_prop typ n_lhs_exp in
let iter_list = Rearrange.rearrange ~report_deref_errors pdesc tenv n_lhs_exp' typ prop loc in let iter_list = Rearrange.rearrange ~report_deref_errors pdesc tenv n_lhs_exp' typ prop loc in
IList.rev (IList.fold_left (execute_set_ pdesc tenv n_rhs_exp) [] iter_list) IList.rev (IList.fold_left (execute_set_ pdesc tenv n_rhs_exp) [] iter_list)
with Rearrange.ARRAY_ACCESS -> with Rearrange.ARRAY_ACCESS ->
@ -1021,9 +1021,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
Specs.CallStats.trace Specs.CallStats.trace
summary.Specs.stats.Specs.call_stats callee_pname loc summary.Specs.stats.Specs.call_stats callee_pname loc
(Specs.CallStats.CR_skip) !Config.footprint); (Specs.CallStats.CR_skip) !Config.footprint);
call_unknown_or_scan call_unknown_or_scan false pdesc prop path ret_ids ret_typ_opt actual_args callee_pname loc in
false cfg pdesc tenv prop path
ret_ids ret_typ_opt actual_args callee_pname loc in
let instr = match _instr with let instr = match _instr with
| Sil.Call (ret, exp, par, loc, call_flags) -> | Sil.Call (ret, exp, par, loc, call_flags) ->
let exp' = Prop.exp_normalize_prop _prop exp in let exp' = Prop.exp_normalize_prop _prop exp in
@ -1091,7 +1089,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
check_condition_always_true_false (); check_condition_always_true_false ();
let n_cond, prop = exp_norm_check_arith pname _prop cond in let n_cond, prop = exp_norm_check_arith pname _prop cond in
ret_old_path (Propset.to_proplist (prune_prop n_cond prop)) ret_old_path (Propset.to_proplist (prune_prop n_cond prop))
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), args, loc, call_flags) | Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), args, loc, _)
when function_is_builtin callee_pname -> when function_is_builtin callee_pname ->
let sym_exe_builtin = Builtin.get_sym_exe_builtin callee_pname in let sym_exe_builtin = Builtin.get_sym_exe_builtin callee_pname in
sym_exe_builtin cfg pdesc instr tenv _prop path ret_ids args callee_pname loc sym_exe_builtin cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
@ -1102,7 +1100,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
let url_handled_args = let url_handled_args =
call_constructor_url_update_args callee_pname norm_args in call_constructor_url_update_args callee_pname norm_args in
let resolved_pnames = let resolved_pnames =
resolve_virtual_pname cfg tenv norm_prop url_handled_args callee_pname call_flags in resolve_virtual_pname tenv norm_prop url_handled_args callee_pname call_flags in
let exec_one_pname pname = let exec_one_pname pname =
if !Config.ondemand_enabled then if !Config.ondemand_enabled then
Ondemand.do_analysis pdesc pname; Ondemand.do_analysis pdesc pname;
@ -1127,7 +1125,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
let (prop_r, _n_actual_params) = normalize_params pname _prop actual_params in let (prop_r, _n_actual_params) = normalize_params pname _prop actual_params in
let fn, n_actual_params = handle_special_cases_call tenv cfg callee_pname _n_actual_params in let fn, n_actual_params = handle_special_cases_call tenv cfg callee_pname _n_actual_params in
let resolved_pname = let resolved_pname =
match resolve_virtual_pname cfg tenv prop_r n_actual_params fn call_flags with match resolve_virtual_pname tenv prop_r n_actual_params fn call_flags with
| resolved_pname :: _ -> resolved_pname | resolved_pname :: _ -> resolved_pname
| [] -> fn in | [] -> fn in
if !Config.ondemand_enabled then if !Config.ondemand_enabled then
@ -1155,7 +1153,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
match objc_property_accessor with match objc_property_accessor with
| Some objc_property_accessor -> | Some objc_property_accessor ->
handle_objc_method_call handle_objc_method_call
n_actual_params n_actual_params prop tenv cfg ret_ids pdesc callee_pname loc path n_actual_params n_actual_params prop tenv ret_ids pdesc callee_pname loc path
(sym_exec_objc_accessor objc_property_accessor ret_typ_opt) (sym_exec_objc_accessor objc_property_accessor ret_typ_opt)
| None -> | None ->
skip_call prop path resolved_pname loc ret_ids ret_typ_opt n_actual_params skip_call prop path resolved_pname loc ret_ids ret_typ_opt n_actual_params
@ -1173,10 +1171,9 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
end else begin end else begin
L.d_str "Unknown function pointer "; Sil.d_exp fun_exp; L.d_strln ", returning undefined value."; L.d_str "Unknown function pointer "; Sil.d_exp fun_exp; L.d_strln ", returning undefined value.";
let callee_pname = Procname.from_string_c_fun "__function_pointer__" in let callee_pname = Procname.from_string_c_fun "__function_pointer__" in
call_unknown_or_scan call_unknown_or_scan false pdesc prop_r path ret_ids None n_actual_params callee_pname loc
false cfg pdesc tenv prop_r path ret_ids None n_actual_params callee_pname loc
end end
| Sil.Nullify (pvar, loc, deallocate) -> | Sil.Nullify (pvar, _, deallocate) ->
begin begin
let eprop = Prop.expose _prop in let eprop = Prop.expose _prop in
match IList.partition match IList.partition
@ -1193,7 +1190,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
ret_old_path [Prop.normalize eprop_res] ret_old_path [Prop.normalize eprop_res]
| _ -> assert false | _ -> assert false
end end
| Sil.Abstract loc -> | Sil.Abstract _ ->
let node = State.get_node () in let node = State.get_node () in
let blocks_nullified = get_nullified_block node in let blocks_nullified = get_nullified_block node in
IList.iter (check_block_retain_cycle cfg tenv pname _prop) blocks_nullified; IList.iter (check_block_retain_cycle cfg tenv pname _prop) blocks_nullified;
@ -1203,9 +1200,9 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
else else
ret_old_path [Abs.remove_redundant_array_elements pname tenv ret_old_path [Abs.remove_redundant_array_elements pname tenv
(Abs.abstract pname tenv _prop)] (Abs.abstract pname tenv _prop)]
| Sil.Remove_temps (temps, loc) -> | Sil.Remove_temps (temps, _) ->
ret_old_path [Prop.exist_quantify (Sil.fav_from_list temps) _prop] ret_old_path [Prop.exist_quantify (Sil.fav_from_list temps) _prop]
| Sil.Declare_locals (ptl, loc) -> | Sil.Declare_locals (ptl, _) ->
let sigma_locals = let sigma_locals =
let add_None (x, y) = (x, Sil.Sizeof (y, Sil.Subtype.exact), None) in let add_None (x, y) = (x, Sil.Sizeof (y, Sil.Subtype.exact), None) in
let fp_mode = !Config.footprint in let fp_mode = !Config.footprint in
@ -1221,7 +1218,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
ret_old_path [prop'] ret_old_path [prop']
| Sil.Stackop _ -> (* this should be handled at the propset level *) | Sil.Stackop _ -> (* this should be handled at the propset level *)
assert false assert false
| Sil.Goto_node (node_e, loc) -> | Sil.Goto_node (node_e, _) ->
let n_node_e, prop = exp_norm_check_arith pname _prop node_e in let n_node_e, prop = exp_norm_check_arith pname _prop node_e in
begin begin
match n_node_e with match n_node_e with
@ -1296,7 +1293,7 @@ and add_constraints_on_actuals_by_ref prop actuals_by_ref callee_pname callee_lo
let filtered_sigma = let filtered_sigma =
IList.filter IList.filter
(function (function
| Sil.Hpointsto (lhs, _, typ_exp) when Sil.exp_equal lhs actual -> | Sil.Hpointsto (lhs, _, _) when Sil.exp_equal lhs actual ->
false false
| _ -> true) | _ -> true)
(Prop.get_sigma prop) in (Prop.get_sigma prop) in
@ -1341,10 +1338,10 @@ and check_untainted exp caller_pname callee_pname prop =
else prop else prop
(** execute a call for an unknown or scan function *) (** execute a call for an unknown or scan function *)
and call_unknown_or_scan is_scan cfg pdesc tenv pre path and call_unknown_or_scan is_scan pdesc pre path
ret_ids ret_type_option actual_pars callee_pname loc = ret_ids ret_type_option actual_pars callee_pname loc =
let remove_file_attribute prop = let remove_file_attribute prop =
let do_exp p (e, t) = let do_exp p (e, _) =
let do_attribute q = function let do_attribute q = function
| Sil.Aresource res_action as res | Sil.Aresource res_action as res
when res_action.Sil.ra_res = Sil.Rfile -> when res_action.Sil.ra_res = Sil.Rfile ->
@ -1445,7 +1442,7 @@ and sym_exe_check_variadic_sentinel_if_present
cfg pdesc tenv prop path (IList.length formals) cfg pdesc tenv prop path (IList.length formals)
actual_params sentinel_arg callee_pname loc actual_params sentinel_arg callee_pname loc
and sym_exec_objc_getter field_name ret_typ_opt tenv cfg ret_ids pdesc pname loc args prop = and sym_exec_objc_getter field_name ret_typ_opt tenv ret_ids pdesc pname loc args prop =
L.d_strln ("No custom getter found. Executing the ObjC builtin getter with ivar "^ L.d_strln ("No custom getter found. Executing the ObjC builtin getter with ivar "^
(Ident.fieldname_to_string field_name)^"."); (Ident.fieldname_to_string field_name)^".");
let ret_id = let ret_id =
@ -1467,7 +1464,7 @@ and sym_exec_objc_getter field_name ret_typ_opt tenv cfg ret_ids pdesc pname loc
~report_deref_errors:false pname pdesc tenv ret_id field_access_exp ret_typ loc prop ~report_deref_errors:false pname pdesc tenv ret_id field_access_exp ret_typ loc prop
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
and sym_exec_objc_setter field_name ret_typ_opt tenv cfg ret_ids pdesc pname loc args prop = and sym_exec_objc_setter field_name _ tenv _ pdesc pname loc args prop =
L.d_strln ("No custom setter found. Executing the ObjC builtin setter with ivar "^ L.d_strln ("No custom setter found. Executing the ObjC builtin setter with ivar "^
(Ident.fieldname_to_string field_name)^"."); (Ident.fieldname_to_string field_name)^".");
match args with match args with
@ -1480,8 +1477,8 @@ and sym_exec_objc_setter field_name ret_typ_opt tenv cfg ret_ids pdesc pname loc
execute_set ~report_deref_errors:false pname pdesc tenv field_access_exp typ2 lexp2 loc prop execute_set ~report_deref_errors:false pname pdesc tenv field_access_exp typ2 lexp2 loc prop
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
and sym_exec_objc_accessor property_accesor ret_typ_opt tenv cfg ret_ids pdesc callee_pname loc args and sym_exec_objc_accessor property_accesor ret_typ_opt tenv ret_ids pdesc _ loc args prop path
prop path : Builtin.ret_typ = : Builtin.ret_typ =
let f_accessor = let f_accessor =
match property_accesor with match property_accesor with
| ProcAttributes.Objc_getter field_name -> sym_exec_objc_getter field_name | ProcAttributes.Objc_getter field_name -> sym_exec_objc_getter field_name
@ -1489,7 +1486,7 @@ and sym_exec_objc_accessor property_accesor ret_typ_opt tenv cfg ret_ids pdesc c
(* we want to execute in the context of the current procedure, not in the context of callee_pname, (* we want to execute in the context of the current procedure, not in the context of callee_pname,
since this is the procname of the setter/getter method *) since this is the procname of the setter/getter method *)
let cur_pname = Cfg.Procdesc.get_proc_name pdesc in let cur_pname = Cfg.Procdesc.get_proc_name pdesc in
f_accessor ret_typ_opt tenv cfg ret_ids pdesc cur_pname loc args prop f_accessor ret_typ_opt tenv ret_ids pdesc cur_pname loc args prop
|> IList.map (fun p -> (p, path)) |> IList.map (fun p -> (p, path))
(** Perform symbolic execution for a function call *) (** Perform symbolic execution for a function call *)
@ -1519,7 +1516,7 @@ and sym_exec_call cfg pdesc tenv pre path ret_ids actual_pars summary loc =
let rec comb actual_pars formal_types = let rec comb actual_pars formal_types =
match actual_pars, formal_types with match actual_pars, formal_types with
| [], [] -> actual_pars | [], [] -> actual_pars
| (e, t_e):: etl', t:: tl' -> | (e, t_e):: etl', _:: tl' ->
(e, t_e) :: comb etl' tl' (e, t_e) :: comb etl' tl'
| _,[] -> | _,[] ->
Errdesc.warning_err Errdesc.warning_err
@ -1545,11 +1542,11 @@ and sym_exec_call cfg pdesc tenv pre path ret_ids actual_pars summary loc =
(* were the receiver is null and the semantics of the call is nop*) (* were the receiver is null and the semantics of the call is nop*)
if (!Config.curr_language <> Config.Java) && !Config.objc_method_call_semantics && if (!Config.curr_language <> Config.Java) && !Config.objc_method_call_semantics &&
(Specs.get_attributes summary).ProcAttributes.is_objc_instance_method then (Specs.get_attributes summary).ProcAttributes.is_objc_instance_method then
handle_objc_method_call actual_pars actual_params pre tenv cfg ret_ids pdesc callee_pname loc handle_objc_method_call actual_pars actual_params pre tenv ret_ids pdesc callee_pname loc
path Tabulation.exe_function_call path Tabulation.exe_function_call
else (* non-objective-c method call. Standard tabulation *) else (* non-objective-c method call. Standard tabulation *)
Tabulation.exe_function_call Tabulation.exe_function_call
tenv cfg ret_ids pdesc callee_pname loc actual_params pre path tenv ret_ids pdesc callee_pname loc actual_params pre path
end end
(** perform symbolic execution for a single prop, and check for junk *) (** perform symbolic execution for a single prop, and check for junk *)
@ -1665,10 +1662,10 @@ module ModelBuiltins = struct
[(prop, path)] [(prop, path)]
(** model va_arg as always returning 0 *) (** model va_arg as always returning 0 *)
let execute___builtin_va_arg cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute___builtin_va_arg cfg pdesc _ tenv prop path ret_ids args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [(lexp1, typ1); (lexp2, typ2); (lexp3, typ3)], _ -> | [_; _; (lexp3, typ3)], _ ->
let instr' = Sil.Set (lexp3, typ3, Sil.exp_zero, loc) in let instr' = Sil.Set (lexp3, typ3, Sil.exp_zero, loc) in
sym_exec_generated true cfg tenv pdesc [instr'] [(prop, path)] sym_exec_generated true cfg tenv pdesc [instr'] [(prop, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
@ -1693,7 +1690,7 @@ module ModelBuiltins = struct
| [ret_id] -> Prop.conjoin_eq e (Sil.Var ret_id) prop | [ret_id] -> Prop.conjoin_eq e (Sil.Var ret_id) prop
| _ -> prop | _ -> prop
let execute___get_array_size cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___get_array_size _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp, typ)] when IList.length ret_ids <= 1 -> | [(lexp, typ)] when IList.length ret_ids <= 1 ->
@ -1706,7 +1703,7 @@ module ModelBuiltins = struct
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in | _ -> false) (Prop.get_sigma prop) in
match hpred with match hpred with
| Sil.Hpointsto(e, Sil.Earray(size, _, _), _) -> | Sil.Hpointsto(_, Sil.Earray(size, _, _), _) ->
[(return_result_for_array_size size prop ret_ids, path)] [(return_result_for_array_size size prop ret_ids, path)]
| _ -> [] | _ -> []
with Not_found -> with Not_found ->
@ -1726,7 +1723,7 @@ module ModelBuiltins = struct
end end
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___set_array_size cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___set_array_size _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [(lexp, typ); (size, _)], [] -> | [(lexp, typ); (size, _)], [] ->
@ -1736,7 +1733,7 @@ module ModelBuiltins = struct
begin begin
try try
let hpred, sigma' = IList.partition (function let hpred, sigma' = IList.partition (function
| Sil.Hpointsto(e, _, t) -> Sil.exp_equal e n_lexp | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in | _ -> false) (Prop.get_sigma prop) in
match hpred with match hpred with
| [Sil.Hpointsto(e, Sil.Earray(_, esel, inst), t)] -> | [Sil.Hpointsto(e, Sil.Earray(_, esel, inst), t)] ->
@ -1762,11 +1759,11 @@ module ModelBuiltins = struct
end end
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___print_value cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute___print_value _ pdesc _ _ prop path _ args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
L.err "__print_value: "; L.err "__print_value: ";
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let do_arg (lexp, typ) = let do_arg (lexp, _) =
let n_lexp, _ = exp_norm_check_arith pname prop lexp in let n_lexp, _ = exp_norm_check_arith pname prop lexp in
L.err "%a " (Sil.pp_exp pe_text) n_lexp in L.err "%a " (Sil.pp_exp pe_text) n_lexp in
IList.iter do_arg args; IList.iter do_arg args;
@ -1796,7 +1793,7 @@ module ModelBuiltins = struct
let texp = Sil.Sizeof (typ'', Sil.Subtype.subtypes) in let texp = Sil.Sizeof (typ'', Sil.Subtype.subtypes) in
let hpred = Prop.mk_ptsto n_lexp sexp texp in let hpred = Prop.mk_ptsto n_lexp sexp texp in
Some hpred Some hpred
| Sil.Tarray (typ', _) -> | Sil.Tarray _ ->
let size = Sil.Var(Ident.create_fresh Ident.kfootprint) in let size = Sil.Var(Ident.create_fresh Ident.kfootprint) in
let sexp = mk_empty_array size in let sexp = mk_empty_array size in
let texp = Sil.Sizeof (typ, Sil.Subtype.subtypes) in let texp = Sil.Sizeof (typ, Sil.Subtype.subtypes) in
@ -1827,7 +1824,7 @@ module ModelBuiltins = struct
non_null_case non_null_case
else null_case @ 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 let execute___get_type_of _ pdesc _ tenv _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp, typ)] when IList.length ret_ids <= 1 -> | [(lexp, typ)] when IList.length ret_ids <= 1 ->
@ -1841,7 +1838,7 @@ module ModelBuiltins = struct
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp | Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in | _ -> false) (Prop.get_sigma prop) in
match hpred with match hpred with
| Sil.Hpointsto(e, _, texp) -> | Sil.Hpointsto(_, _, texp) ->
(return_result texp prop ret_ids), path (return_result texp prop ret_ids), path
| _ -> assert false | _ -> assert false
with Not_found -> (return_result Sil.exp_zero prop ret_ids), path with Not_found -> (return_result Sil.exp_zero prop ret_ids), path
@ -1865,23 +1862,22 @@ module ModelBuiltins = struct
let prop''= Prop.replace_sigma_footprint (process_sigma sigma_fp) prop' in let prop''= Prop.replace_sigma_footprint (process_sigma sigma_fp) prop' in
Prop.normalize prop'' Prop.normalize prop''
let execute___instanceof_cast let execute___instanceof_cast _ pdesc _ tenv _prop path ret_ids args _ _ instof
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc instof
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(_val1, typ1); (_texp2, typ2)] when IList.length ret_ids <= 1 -> | [(_val1, typ1); (_texp2, _)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let val1, __prop = exp_norm_check_arith pname _prop _val1 in let val1, __prop = exp_norm_check_arith pname _prop _val1 in
let texp2, prop = exp_norm_check_arith pname __prop _texp2 in let texp2, prop = exp_norm_check_arith pname __prop _texp2 in
let is_cast_to_reference = let is_cast_to_reference =
match typ1 with match typ1 with
| Sil.Tptr (base_typ, Sil.Pk_reference) -> true | Sil.Tptr (_, Sil.Pk_reference) -> true
| _ -> false in | _ -> false in
(* In Java, we throw an exception, in C++ we return 0 in case of a cast to a pointer, *) (* In Java, we throw an exception, in C++ we return 0 in case of a cast to a pointer, *)
(* and throw an exception in case of a cast to a reference. *) (* and throw an exception in case of a cast to a reference. *)
let should_throw_exception = let should_throw_exception =
!Config.curr_language = Config.Java || is_cast_to_reference in !Config.curr_language = Config.Java || is_cast_to_reference in
let deal_with_failed_cast val1 typ1 texp1 texp2 = let deal_with_failed_cast val1 _ texp1 texp2 =
Tabulation.raise_cast_exception Tabulation.raise_cast_exception
__POS__ None texp1 texp2 val1 in __POS__ None texp1 texp2 val1 in
let exe_one_prop prop = let exe_one_prop prop =
@ -1921,7 +1917,7 @@ module ModelBuiltins = struct
begin begin
match pos_type_opt with match pos_type_opt with
| None -> deal_with_failed_cast val1 typ1 texp1 texp2 | None -> deal_with_failed_cast val1 typ1 texp1 texp2
| Some texp1' -> mk_res pos_type_opt val1 | Some _ -> mk_res pos_type_opt val1
end end
else (* !Config.footprint = false *) else (* !Config.footprint = false *)
begin begin
@ -1962,61 +1958,60 @@ module ModelBuiltins = struct
[(prop', path)] [(prop', path)]
(** Set the attibute of the value as file *) (** Set the attibute of the value as file *)
let execute___set_file_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___set_file_attribute _ pdesc _ _ _prop path ret_ids args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [(lexp, typ)], _ -> | [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
set_resource_attribute prop path n_lexp loc Sil.Rfile set_resource_attribute prop path n_lexp loc Sil.Rfile
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Set the attibute of the value as lock *) (** Set the attibute of the value as lock *)
let execute___set_lock_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___set_lock_attribute _ pdesc _ _ _prop path ret_ids args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [(lexp, typ)], _ -> | [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
set_resource_attribute prop path n_lexp loc Sil.Rlock set_resource_attribute prop path n_lexp loc Sil.Rlock
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Set the resource attribute of the first real argument of method as ignore, the first argument is assumed to be "this" *) (** Set the resource attribute of the first real argument of method as ignore, the first argument is assumed to be "this" *)
let execute___method_set_ignore_attribute let execute___method_set_ignore_attribute _ pdesc _ _ _prop path ret_ids args _ loc
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [_ ; (lexp, typ)], _ -> | [_ ; (lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
set_resource_attribute prop path n_lexp loc Sil.Rignore set_resource_attribute prop path n_lexp loc Sil.Rignore
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Set the attibute of the value as memory *) (** Set the attibute of the value as memory *)
let execute___set_mem_attribute cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___set_mem_attribute _ pdesc _ _ _prop path ret_ids args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [(lexp, typ)], _ -> | [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
set_resource_attribute prop path n_lexp loc (Sil.Rmemory Sil.Mnew) set_resource_attribute prop path n_lexp loc (Sil.Rmemory Sil.Mnew)
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** report an error if [lexp] is tainted; otherwise, add untained([lexp]) as a precondition *) (** report an error if [lexp] is tainted; otherwise, add untained([lexp]) as a precondition *)
let execute___check_untainted cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute___check_untainted _ pdesc _ _ prop path ret_ids args callee_pname _
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [(lexp, typ)], _ -> | [(lexp, _)], _ ->
let caller_pname = Cfg.Procdesc.get_proc_name pdesc in let caller_pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith caller_pname prop lexp in let n_lexp, prop = exp_norm_check_arith caller_pname prop lexp in
[(check_untainted n_lexp caller_pname callee_pname prop, path)] [(check_untainted n_lexp caller_pname callee_pname prop, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** take a pointer to a struct, and return the value of a hidden field in the struct *) (** take a pointer to a struct, and return the value of a hidden field in the struct *)
let execute___get_hidden_field cfg pdesc instr tenv _prop path ret_ids args callee_name loc let execute___get_hidden_field _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp, typ)] -> | [(lexp, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
let ret_val = ref None in let ret_val = ref None in
@ -2033,7 +2028,8 @@ module ModelBuiltins = struct
let se = Sil.Eexp(foot_e, Sil.inst_none) in let se = Sil.Eexp(foot_e, Sil.inst_none) in
let fsel' = (Ident.fieldname_hidden, se) :: fsel in let fsel' = (Ident.fieldname_hidden, se) :: fsel in
Sil.Hpointsto(e, Sil.Estruct (fsel', inst), texp) 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 -> | Sil.Hpointsto(e, Sil.Estruct (fsel, _), _)
when Sil.exp_equal e n_lexp && not in_foot && has_fld_hidden fsel ->
let set_ret_val () = let set_ret_val () =
match IList.find filter_fld_hidden fsel with match IList.find filter_fld_hidden fsel with
| _, Sil.Eexp(e, _) -> ret_val := Some e | _, Sil.Eexp(e, _) -> ret_val := Some e
@ -2049,10 +2045,10 @@ module ModelBuiltins = struct
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** take a pointer to a struct and a value, and set a hidden field in the struct to the given value *) (** take a pointer to a struct and a value, and set a hidden field in the struct to the given value *)
let execute___set_hidden_field cfg pdesc instr tenv _prop path ret_ids args callee_name loc let execute___set_hidden_field _ pdesc _ _ _prop path _ args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp1, typ1); (lexp2, typ2)] -> | [(lexp1, _); (lexp2, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp1, _prop1 = exp_norm_check_arith pname _prop lexp1 in let n_lexp1, _prop1 = exp_norm_check_arith pname _prop lexp1 in
let n_lexp2, prop = exp_norm_check_arith pname _prop1 lexp2 in let n_lexp2, prop = exp_norm_check_arith pname _prop1 lexp2 in
@ -2080,7 +2076,7 @@ module ModelBuiltins = struct
(* Update the objective-c hidden counter by applying the operation op and the operand delta.*) (* Update the objective-c hidden counter by applying the operation op and the operand delta.*)
(* Eg. op=+/- delta is an integer *) (* Eg. op=+/- delta is an integer *)
let execute___objc_counter_update let execute___objc_counter_update
suppress_npe_report op delta cfg pdesc instr tenv _prop path ret_ids args callee_name loc suppress_npe_report op delta cfg pdesc _ tenv _prop path _ args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp, typ)] -> | [(lexp, typ)] ->
@ -2114,7 +2110,7 @@ module ModelBuiltins = struct
: Builtin.ret_typ = : Builtin.ret_typ =
let suppress_npe_report, args' = get_suppress_npe_flag args in let suppress_npe_report, args' = get_suppress_npe_flag args in
match args' with match args' with
| [(lexp, typ)] -> | [(lexp, _)] ->
let prop = return_result lexp _prop ret_ids in let prop = return_result lexp _prop ret_ids in
execute___objc_counter_update suppress_npe_report (Sil.PlusA) (Sil.Int.one) execute___objc_counter_update suppress_npe_report (Sil.PlusA) (Sil.Int.one)
cfg pdesc instr tenv prop path ret_ids args' callee_name loc cfg pdesc instr tenv prop path ret_ids args' callee_name loc
@ -2147,11 +2143,10 @@ module ModelBuiltins = struct
execute___objc_release_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc execute___objc_release_impl cfg pdesc instr tenv _prop path ret_ids args callee_name loc
(** Set the attibute of the value as objc autoreleased *) (** Set the attibute of the value as objc autoreleased *)
let execute___set_autorelease_attribute let execute___set_autorelease_attribute _ pdesc _ _ _prop path ret_ids args _ _
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args, ret_ids with match args, ret_ids with
| [(lexp, typ)], _ -> | [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let prop = return_result lexp _prop ret_ids in let prop = return_result lexp _prop ret_ids in
if !Config.objc_memory_model_on then if !Config.objc_memory_model_on then
@ -2162,8 +2157,7 @@ module ModelBuiltins = struct
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Release all the objects in the pool *) (** Release all the objects in the pool *)
let execute___release_autorelease_pool let execute___release_autorelease_pool cfg pdesc instr tenv _prop path ret_ids _ callee_pname loc
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
: Builtin.ret_typ = : Builtin.ret_typ =
if !Config.objc_memory_model_on then if !Config.objc_memory_model_on then
let autoreleased_objects = Prop.get_atoms_with_attribute Sil.Aautorelease _prop in let autoreleased_objects = Prop.get_atoms_with_attribute Sil.Aautorelease _prop in
@ -2176,7 +2170,7 @@ module ModelBuiltins = struct
| Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 exp | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 exp
| _ -> false) (Prop.get_sigma _prop) in | _ -> false) (Prop.get_sigma _prop) in
match hpred with match hpred with
| Sil.Hpointsto(_, _, Sil.Sizeof (typ, st)) -> | Sil.Hpointsto(_, _, Sil.Sizeof (typ, _)) ->
let res1 = let res1 =
execute___objc_release cfg pdesc instr tenv prop path ret_ids execute___objc_release cfg pdesc instr tenv prop path ret_ids
[(exp, typ)] callee_pname loc in [(exp, typ)] callee_pname loc in
@ -2188,10 +2182,10 @@ module ModelBuiltins = struct
else execute___no_op _prop path else execute___no_op _prop path
(** Set attibute att *) (** Set attibute att *)
let execute___set_attr att cfg pdesc instr tenv _prop path ret_ids args callee_name loc let execute___set_attr att _ pdesc _ _ _prop path _ args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp, typ)] -> | [(lexp, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
[(Prop.add_or_replace_exp_attribute prop n_lexp att, path)] [(Prop.add_or_replace_exp_attribute prop n_lexp att, path)]
@ -2204,10 +2198,10 @@ module ModelBuiltins = struct
execute___set_attr (Sil.Ataint pname) execute___set_attr (Sil.Ataint pname)
cfg pdesc instr tenv _prop path ret_ids args callee_name loc cfg pdesc instr tenv _prop path ret_ids args callee_name loc
let execute___objc_cast cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___objc_cast _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(_val1, typ1); (_texp2, typ2)] when IList.length ret_ids <= 1 -> | [(_val1, _); (_texp2, _)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let val1, __prop = exp_norm_check_arith pname _prop _val1 in let val1, __prop = exp_norm_check_arith pname _prop _val1 in
let texp2, prop = exp_norm_check_arith pname __prop _texp2 in let texp2, prop = exp_norm_check_arith pname __prop _texp2 in
@ -2216,26 +2210,26 @@ module ModelBuiltins = struct
| Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1 | Sil.Hpointsto(e1, _, _) -> Sil.exp_equal e1 val1
| _ -> false) (Prop.get_sigma prop) in | _ -> false) (Prop.get_sigma prop) in
match hpred, texp2 with match hpred, texp2 with
| Sil.Hpointsto(val1, _, texp1), Sil.Sizeof (typ, st) -> | Sil.Hpointsto(val1, _, _), Sil.Sizeof (_, _) ->
let prop' = replace_ptsto_texp prop val1 texp2 in let prop' = replace_ptsto_texp prop val1 texp2 in
[(return_result val1 prop' ret_ids, path)] [(return_result val1 prop' ret_ids, path)]
| _ -> [(return_result val1 prop ret_ids, path)] | _ -> [(return_result val1 prop ret_ids, path)]
with Not_found -> [(return_result val1 prop ret_ids, path)]) with Not_found -> [(return_result val1 prop ret_ids, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_abort cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute_abort _ _ _ _ _ _ _ _ callee_pname _
: Builtin.ret_typ = : Builtin.ret_typ =
raise raise
(Exceptions.Precondition_not_found (Exceptions.Precondition_not_found
(Localise.verbatim_desc (Procname.to_string callee_pname), __POS__)) (Localise.verbatim_desc (Procname.to_string callee_pname), __POS__))
let execute_exit cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute_exit _ _ _ _ prop path _ _ _ _
: Builtin.ret_typ = : Builtin.ret_typ =
execute_diverge prop path execute_diverge prop path
let _execute_free tenv mk loc acc iter = let _execute_free mk loc acc iter =
match Prop.prop_iter_current iter with match Prop.prop_iter_current iter with
| (Sil.Hpointsto(lexp, se, _), []) -> | (Sil.Hpointsto(lexp, _, _), []) ->
let prop = Prop.prop_iter_remove_curr_then_to_prop iter in let prop = Prop.prop_iter_remove_curr_then_to_prop iter in
let pname = Sil.mem_dealloc_pname mk in let pname = Sil.mem_dealloc_pname mk in
let ra = { Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk; Sil.ra_pname = pname; Sil.ra_loc = loc; Sil.ra_vpath = None } in let ra = { Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk; Sil.ra_pname = pname; Sil.ra_loc = loc; Sil.ra_vpath = None } in
@ -2247,10 +2241,10 @@ module ModelBuiltins = struct
lexp lexp
(Sil.Aresource ra) in (Sil.Aresource ra) in
p_res :: acc p_res :: acc
| (Sil.Hpointsto _, o :: os) -> assert false (* alignment error *) | (Sil.Hpointsto _, _ :: _) -> assert false (* alignment error *)
| _ -> assert false (* should not happen *) | _ -> assert false (* should not happen *)
let _execute_free_nonzero mk pdesc tenv instr prop path lexp typ loc = let _execute_free_nonzero mk pdesc tenv instr prop lexp typ loc =
try try
begin begin
match Prover.is_root prop lexp lexp with match Prover.is_root prop lexp lexp with
@ -2259,7 +2253,7 @@ module ModelBuiltins = struct
assert false assert false
| Some _ -> | Some _ ->
let prop_list = let prop_list =
IList.fold_left (_execute_free tenv mk loc) [] IList.fold_left (_execute_free mk loc) []
(Rearrange.rearrange pdesc tenv lexp typ prop loc) in (Rearrange.rearrange pdesc tenv lexp typ prop loc) in
IList.rev prop_list IList.rev prop_list
end end
@ -2272,7 +2266,7 @@ module ModelBuiltins = struct
raise (Exceptions.Array_of_pointsto __POS__) raise (Exceptions.Array_of_pointsto __POS__)
end end
let execute_free mk cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute_free mk _ pdesc instr tenv _prop path _ args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp, typ)] -> | [(lexp, typ)] ->
@ -2286,13 +2280,13 @@ module ModelBuiltins = struct
let plist = let plist =
prop_zero @ (* model: if 0 then skip else _execute_free_nonzero *) prop_zero @ (* model: if 0 then skip else _execute_free_nonzero *)
IList.flatten (IList.map (fun p -> IList.flatten (IList.map (fun p ->
_execute_free_nonzero mk pdesc tenv instr p path _execute_free_nonzero mk pdesc tenv instr p
(Prop.exp_normalize_prop p lexp) typ loc) prop_nonzero) in (Prop.exp_normalize_prop p lexp) typ loc) prop_nonzero) in
IList.map (fun p -> (p, path)) plist IList.map (fun p -> (p, path)) plist
end end
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_alloc mk can_return_null cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute_alloc mk can_return_null _ pdesc _ tenv _prop path ret_ids args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let rec evaluate_char_sizeof e = match e with let rec evaluate_char_sizeof e = match e with
@ -2338,10 +2332,10 @@ module ModelBuiltins = struct
[(prop_alloc, path); (prop_null, path)] [(prop_alloc, path); (prop_null, path)]
else [(prop_alloc, path)] else [(prop_alloc, path)]
let execute_pthread_create cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute_pthread_create cfg pdesc _ tenv prop path ret_ids args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [thread; attr; start_routine; arg] -> | [_; _; start_routine; arg] ->
let routine_name = Prop.exp_normalize_prop prop (fst start_routine) in let routine_name = Prop.exp_normalize_prop prop (fst start_routine) in
let routine_arg = Prop.exp_normalize_prop prop (fst arg) in let routine_arg = Prop.exp_normalize_prop prop (fst arg) in
(match routine_name, (snd start_routine) with (match routine_name, (snd start_routine) with
@ -2361,20 +2355,19 @@ module ModelBuiltins = struct
[(prop, path)]) [(prop, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_skip cfg pdesc instr tenv prop path ret_ids args callee_pname loc : Builtin.ret_typ = let execute_skip _ _ _ _ prop path _ _ _ _ : Builtin.ret_typ =
[(prop, path)] [(prop, path)]
let execute_scan_function let execute_scan_function skip_n_arguments _ pdesc _ _ prop path ret_ids args callee_pname loc
skip_n_arguments cfg pdesc instr tenv prop path ret_ids args callee_pname loc
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| _ when IList.length args >= skip_n_arguments -> | _ when IList.length args >= skip_n_arguments ->
let varargs = ref args in let varargs = ref args in
for _ = 1 to skip_n_arguments do varargs := IList.tl !varargs done; for _ = 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 call_unknown_or_scan true pdesc prop path ret_ids None !varargs callee_pname loc
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute__unwrap_exception cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute__unwrap_exception _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(ret_exn, _)] -> | [(ret_exn, _)] ->
@ -2389,7 +2382,7 @@ module ModelBuiltins = struct
end end
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_return_first_argument cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute_return_first_argument _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| (_arg1, _):: _ -> | (_arg1, _):: _ ->
@ -2399,13 +2392,13 @@ module ModelBuiltins = struct
[(prop', path)] [(prop', path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___split_get_nth cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___split_get_nth _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp1, _); (lexp2, _); (lexp3, _)] -> | [(lexp1, _); (lexp2, _); (lexp3, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp1, prop = exp_norm_check_arith pname _prop lexp1 in let n_lexp1, _ = exp_norm_check_arith pname _prop lexp1 in
let n_lexp2, prop = exp_norm_check_arith pname _prop lexp2 in let n_lexp2, _ = exp_norm_check_arith pname _prop lexp2 in
let n_lexp3, prop = exp_norm_check_arith pname _prop lexp3 in let n_lexp3, prop = exp_norm_check_arith pname _prop lexp3 in
(match n_lexp1, n_lexp2, n_lexp3 with (match n_lexp1, n_lexp2, n_lexp3 with
| Sil.Const (Sil.Cstr str1), Sil.Const (Sil.Cstr str2), Sil.Const (Sil.Cint n_sil) -> | Sil.Const (Sil.Cstr str1), Sil.Const (Sil.Cstr str2), Sil.Const (Sil.Cint n_sil) ->
@ -2419,13 +2412,13 @@ module ModelBuiltins = struct
| _ -> [(prop, path)]) | _ -> [(prop, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___create_tuple cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute___create_tuple _ _ _ _ prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
let el = IList.map fst args in let el = IList.map fst args in
let res = Sil.Const (Sil.Ctuple el) in let res = Sil.Const (Sil.Ctuple el) in
[(return_result res prop ret_ids, path)] [(return_result res prop ret_ids, path)]
let execute___tuple_get_nth cfg pdesc instr tenv _prop path ret_ids args callee_pname loc let execute___tuple_get_nth _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp1, _); (lexp2, _)] -> | [(lexp1, _); (lexp2, _)] ->
@ -2442,17 +2435,17 @@ module ModelBuiltins = struct
(* forces the expression passed as parameter to be assumed true at the point where this (* forces the expression passed as parameter to be assumed true at the point where this
builtin is called, blocks if this causes an inconsistency *) builtin is called, blocks if this causes an inconsistency *)
let execute___infer_assume let execute___infer_assume _ _ _ _ prop path _ args _ _
cfg pdesc instr tenv prop path ret_ids args callee_pname loc: Builtin.ret_typ = : Builtin.ret_typ =
match args with match args with
| [(lexp, typ)] -> | [(lexp, _)] ->
let prop_assume = Prop.conjoin_eq lexp (Sil.exp_bool true) prop in let prop_assume = Prop.conjoin_eq lexp (Sil.exp_bool true) prop in
if Prover.check_inconsistency prop_assume then execute_diverge prop_assume path if Prover.check_inconsistency prop_assume then execute_diverge prop_assume path
else [(prop_assume, path)] else [(prop_assume, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__) | _ -> raise (Exceptions.Wrong_argument_number __POS__)
(* creates a named error state *) (* creates a named error state *)
let execute___infer_fail cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute___infer_fail cfg pdesc _ tenv prop path _ args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
let error_str = let error_str =
match args with match args with
@ -2469,7 +2462,7 @@ module ModelBuiltins = struct
sym_exec_generated true cfg tenv pdesc [set_instr] [(prop, path)] sym_exec_generated true cfg tenv pdesc [set_instr] [(prop, path)]
(* translate builtin assertion failure *) (* translate builtin assertion failure *)
let execute___assert_fail cfg pdesc instr tenv prop path ret_ids args callee_pname loc let execute___assert_fail cfg pdesc _ tenv prop path _ args _ loc
: Builtin.ret_typ = : Builtin.ret_typ =
let error_str = let error_str =
match args with match args with
@ -2575,12 +2568,13 @@ module ModelBuiltins = struct
let nsarray_typ = Sil.expand_type tenv nsarray_typ in let nsarray_typ = Sil.expand_type tenv nsarray_typ in
execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsarray_typ loc execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsarray_typ loc
let execute_NSArray_arrayWithObjects_count cfg pdesc instr tenv prop path ret_ids args callee_pname loc = let execute_NSArray_arrayWithObjects_count
cfg pdesc _ tenv prop path ret_ids args callee_pname loc =
let n_formals = 1 in let n_formals = 1 in
let res' = sym_exe_check_variadic_sentinel ~fails_on_nil: true cfg pdesc tenv prop path n_formals args (0,1) callee_pname loc in let res' = sym_exe_check_variadic_sentinel ~fails_on_nil: true cfg pdesc tenv prop path n_formals args (0,1) callee_pname loc in
execute_objc_NSArray_alloc_no_fail cfg pdesc tenv res' ret_ids loc execute_objc_NSArray_alloc_no_fail cfg pdesc tenv res' ret_ids loc
let execute_NSArray_arrayWithObjects cfg pdesc instr tenv prop path ret_ids args callee_pname loc = let execute_NSArray_arrayWithObjects cfg pdesc _ tenv prop path ret_ids args callee_pname loc =
let n_formals = 1 in let n_formals = 1 in
let res' = sym_exe_check_variadic_sentinel cfg pdesc tenv prop path n_formals args (0,1) callee_pname loc in let res' = sym_exe_check_variadic_sentinel cfg pdesc tenv prop path n_formals args (0,1) callee_pname loc in
execute_objc_NSArray_alloc_no_fail cfg pdesc tenv res' ret_ids loc execute_objc_NSArray_alloc_no_fail cfg pdesc tenv res' ret_ids loc
@ -2603,7 +2597,7 @@ module ModelBuiltins = struct
Sil.expand_type tenv nsdictionary_typ in Sil.expand_type tenv nsdictionary_typ in
execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsdictionary_typ loc execute_objc_alloc_no_fail cfg pdesc tenv symb_state ret_ids nsdictionary_typ loc
let execute___objc_dictionary_literal cfg pdesc instr tenv prop path ret_ids args callee_pname loc = let execute___objc_dictionary_literal cfg pdesc _ tenv prop path ret_ids args callee_pname loc =
let n_formals = 1 in let n_formals = 1 in
let res' = let res' =
sym_exe_check_variadic_sentinel ~fails_on_nil: true cfg pdesc tenv prop path sym_exe_check_variadic_sentinel ~fails_on_nil: true cfg pdesc tenv prop path

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

@ -88,7 +88,7 @@ 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 | 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 let fav = Sil.fav_new () in
Specs.Jprop.fav_add fav spec.Specs.pre; Specs.Jprop.fav_add fav spec.Specs.pre;
IList.iter (fun (p, path) -> Prop.prop_fav_add fav p) spec.Specs.posts; IList.iter (fun (p, _) -> Prop.prop_fav_add fav p) spec.Specs.posts;
let ids = Sil.fav_to_list fav in let ids = Sil.fav_to_list fav in
let ids' = IList.map (fun i -> (i, Ident.create_fresh Ident.kprimed)) 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 ren_sub = Sil.sub_of_list (IList.map (fun (i, i') -> (i, Sil.Var i')) ids') in
@ -211,7 +211,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
false false
end end
else match hpred with else match hpred with
| Sil.Hpointsto(Sil.Var id, _, _) -> true | Sil.Hpointsto(Sil.Var _, _, _) -> true
| Sil.Hpointsto(Sil.Lvar pvar, _, _) -> Sil.pvar_is_global pvar | Sil.Hpointsto(Sil.Lvar pvar, _, _) -> Sil.pvar_is_global pvar
| _ -> | _ ->
L.d_warning "Missing fields in complex pred: "; Sil.d_hpred hpred; L.d_ln (); L.d_warning "Missing fields in complex pred: "; Sil.d_hpred hpred; L.d_ln ();
@ -336,7 +336,7 @@ let check_path_errors_in_post caller_pname post post_path =
else current_path, None in (* position not found, only use the path up to the callee *) else current_path, None in (* position not found, only use the path up to the callee *)
State.set_path new_path path_pos_opt; State.set_path new_path path_pos_opt;
let exn = Exceptions.Divide_by_zero (desc, __POS__) in let exn = Exceptions.Divide_by_zero (desc, __POS__) in
let pre_opt = State.get_normalized_pre (fun te p -> p) (* Abs.abstract_no_symop *) in let pre_opt = State.get_normalized_pre (fun _ p -> p) (* Abs.abstract_no_symop *) in
Reporting.log_warning caller_pname ~pre: pre_opt exn Reporting.log_warning caller_pname ~pre: pre_opt exn
| _ -> () in | _ -> () in
IList.iter check_attr (Prop.get_all_attributes post) IList.iter check_attr (Prop.get_all_attributes post)
@ -350,8 +350,8 @@ let post_process_post
| Some (Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease })) -> true | Some (Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease })) -> true
| _ -> false in | _ -> false in
let atom_update_alloc_attribute = function let atom_update_alloc_attribute = function
| Sil.Aneq (e , Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra)))) | Sil.Aneq (e , Sil.Const (Sil.Cattribute (Sil.Aresource ra)))
| Sil.Aneq (Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra))), e) | Sil.Aneq (Sil.Const (Sil.Cattribute (Sil.Aresource ra)), e)
when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *) when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *)
let vpath, _ = Errdesc.vpath_find post e in let vpath, _ = Errdesc.vpath_find post e in
let ra' = { ra with Sil.ra_pname = callee_pname; Sil.ra_loc = loc; Sil.ra_vpath = vpath } in let ra' = { ra with Sil.ra_pname = callee_pname; Sil.ra_loc = loc; Sil.ra_vpath = vpath } in
@ -409,9 +409,9 @@ and sexp_star_fld se1 se2 : Sil.strexp =
match se1, se2 with match se1, se2 with
| Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, inst2) -> | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, inst2) ->
Sil.Estruct (fsel_star_fld fsel1 fsel2, inst2) Sil.Estruct (fsel_star_fld fsel1 fsel2, inst2)
| Sil.Earray (size1, esel1, _), Sil.Earray (size2, esel2, inst2) -> | Sil.Earray (size1, esel1, _), Sil.Earray (_, esel2, inst2) ->
Sil.Earray (size1, esel_star_fld esel1 esel2, inst2) Sil.Earray (size1, esel_star_fld esel1 esel2, inst2)
| Sil.Eexp (e1, inst1), Sil.Earray (size2, esel2, _) -> | Sil.Eexp (_, inst1), Sil.Earray (size2, esel2, _) ->
let esel1 = [(Sil.exp_zero, se1)] in let esel1 = [(Sil.exp_zero, se1)] in
Sil.Earray (size2, esel_star_fld esel1 esel2, inst1) Sil.Earray (size2, esel_star_fld esel1 esel2, inst1)
| _ -> | _ ->
@ -424,7 +424,7 @@ let texp_star texp1 texp2 =
let rec ftal_sub ftal1 ftal2 = match ftal1, ftal2 with let rec ftal_sub ftal1 ftal2 = match ftal1, ftal2 with
| [], _ -> true | [], _ -> true
| _, [] -> false | _, [] -> false
| (f1, t1, a1):: ftal1', (f2, t2, a2):: ftal2' -> | (f1, _, _):: ftal1', (f2, _, _):: ftal2' ->
begin match Ident.fieldname_compare f1 f2 with begin match Ident.fieldname_compare f1 f2 with
| n when n < 0 -> false | n when n < 0 -> false
| 0 -> ftal_sub ftal1' ftal2' | 0 -> ftal_sub ftal1' ftal2'
@ -453,7 +453,7 @@ let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpr
(* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *) (* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *)
let rec star sg1 sg2 : Sil.hpred list = let rec star sg1 sg2 : Sil.hpred list =
match sg1, sg2 with match sg1, sg2 with
| [], sigma2 -> [] | [], _ -> []
| sigma1,[] -> sigma1 | sigma1,[] -> sigma1
| hpred1:: sigma1', hpred2:: sigma2' -> | hpred1:: sigma1', hpred2:: sigma2' ->
begin begin
@ -470,13 +470,13 @@ let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpr
L.d_ln (); L.d_ln ();
raise (Prop.Cannot_star __POS__) raise (Prop.Cannot_star __POS__)
let hpred_typing_lhs_compare hpred1 (e2, te2) = match hpred1 with let hpred_typing_lhs_compare hpred1 (e2, _) = match hpred1 with
| Sil.Hpointsto(e1, _, _) -> Sil.exp_compare e1 e2 | Sil.Hpointsto(e1, _, _) -> Sil.exp_compare e1 e2
| _ -> - 1 | _ -> - 1
let hpred_star_typing (hpred1 : Sil.hpred) (e2, te2) : Sil.hpred = let hpred_star_typing (hpred1 : Sil.hpred) (_, te2) : Sil.hpred =
match hpred1 with match hpred1 with
| Sil.Hpointsto(e1, se1, te1) -> Sil.Hpointsto (e1, se1, te2) | Sil.Hpointsto(e1, se1, _) -> Sil.Hpointsto (e1, se1, te2)
| _ -> assert false | _ -> assert false
(** Implementation of [*] between predicates and typings *) (** Implementation of [*] between predicates and typings *)
@ -620,7 +620,7 @@ let include_subtrace callee_pname =
(** combine the spec's post with a splitting and actual precondition *) (** combine the spec's post with a splitting and actual precondition *)
let combine let combine
cfg ret_ids (posts: ('a Prop.t * Paths.Path.t) list) ret_ids (posts: ('a Prop.t * Paths.Path.t) list)
actual_pre path_pre split actual_pre path_pre split
caller_pdesc callee_pname loc = caller_pdesc callee_pname loc =
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in
@ -688,29 +688,30 @@ let combine
| None -> post_p2 | None -> post_p2
| Some iter -> | Some iter ->
let filter = function let filter = function
| Sil.Hpointsto (e, se, t) when Sil.exp_equal e callee_ret_pvar -> Some () | Sil.Hpointsto (e, _, _) when Sil.exp_equal e callee_ret_pvar -> Some ()
| _ -> None in | _ -> None in
match Prop.prop_iter_find iter filter with match Prop.prop_iter_find iter filter with
| None -> post_p2 | None -> post_p2
| Some iter' -> | Some iter' ->
match fst (Prop.prop_iter_current iter') with match fst (Prop.prop_iter_current iter') with
| Sil.Hpointsto (e, Sil.Eexp (e', inst), t) when exp_is_exn e' -> (* resuls is an exception: set in caller *) | Sil.Hpointsto (_, Sil.Eexp (e', inst), _) when exp_is_exn e' ->
(* resuls is an exception: set in caller *)
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
prop_set_exn caller_pname p (Sil.Eexp (e', inst)) prop_set_exn caller_pname p (Sil.Eexp (e', inst))
| Sil.Hpointsto (e, Sil.Eexp (e', inst), t) when IList.length ret_ids = 1 -> | Sil.Hpointsto (_, Sil.Eexp (e', _), _) when IList.length ret_ids = 1 ->
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
Prop.conjoin_eq e' (Sil.Var (IList.hd ret_ids)) p Prop.conjoin_eq e' (Sil.Var (IList.hd ret_ids)) p
| Sil.Hpointsto (e, Sil.Estruct (ftl, _), t) | Sil.Hpointsto (_, Sil.Estruct (ftl, _), _)
when IList.length ftl = IList.length ret_ids -> when IList.length ftl = IList.length ret_ids ->
let rec do_ftl_ids p = function let rec do_ftl_ids p = function
| [], [] -> p | [], [] -> p
| (f, Sil.Eexp (e', inst')):: ftl', ret_id:: ret_ids' -> | (_, Sil.Eexp (e', _)):: ftl', ret_id:: ret_ids' ->
let p' = Prop.conjoin_eq e' (Sil.Var ret_id) p in let p' = Prop.conjoin_eq e' (Sil.Var ret_id) p in
do_ftl_ids p' (ftl', ret_ids') do_ftl_ids p' (ftl', ret_ids')
| _ -> p in | _ -> p in
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
do_ftl_ids p (ftl, ret_ids) do_ftl_ids p (ftl, ret_ids)
| Sil.Hpointsto (e, _, t) -> (** returning nothing or unexpected sexp, turning into nondet *) | Sil.Hpointsto _ -> (** returning nothing or unexpected sexp, turning into nondet *)
Prop.prop_iter_remove_curr_then_to_prop iter' Prop.prop_iter_remove_curr_then_to_prop iter'
| _ -> assert false in | _ -> assert false in
let post_p4 = let post_p4 =
@ -848,7 +849,7 @@ let inconsistent_actualpre_missing actual_pre split_opt =
(* perform the taint analysis check by comparing the taint atoms in [calling_pi] with the untaint (* perform the taint analysis check by comparing the taint atoms in [calling_pi] with the untaint
atoms required by the [missing_pi] computed during abduction *) atoms required by the [missing_pi] computed during abduction *)
let do_taint_check caller_pname callee_pname calling_pi missing_pi sub prop = let do_taint_check caller_pname callee_pname calling_pi missing_pi sub =
(* get a version of [missing_pi] whose var names match the names in calling pi *) (* get a version of [missing_pi] whose var names match the names in calling pi *)
let missing_pi_sub = Prop.pi_sub sub missing_pi in let missing_pi_sub = Prop.pi_sub sub missing_pi in
let combined_pi = calling_pi @ missing_pi_sub in let combined_pi = calling_pi @ missing_pi_sub in
@ -923,7 +924,7 @@ let check_uninitialize_dangling_deref callee_pname actual_pre sub formal_params
(** Perform symbolic execution for a single spec *) (** Perform symbolic execution for a single spec *)
let exe_spec let exe_spec
tenv cfg ret_ids (n, nspecs) caller_pdesc callee_pname loc prop path_pre tenv ret_ids (n, nspecs) caller_pdesc callee_pname loc prop path_pre
(spec : Prop.exposed Specs.spec) actual_params formal_params : abduction_res = (spec : Prop.exposed Specs.spec) actual_params formal_params : abduction_res =
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in
let posts = mk_posts ret_ids prop callee_pname spec.Specs.posts in let posts = mk_posts ret_ids prop callee_pname spec.Specs.posts in
@ -944,12 +945,12 @@ let exe_spec
let do_split () = let do_split () =
let missing_pi' = let missing_pi' =
if !Config.taint_analysis then if !Config.taint_analysis then
do_taint_check caller_pname callee_pname (Prop.get_pi actual_pre) missing_pi sub2 prop do_taint_check caller_pname callee_pname (Prop.get_pi actual_pre) missing_pi sub2
else missing_pi in else missing_pi in
process_splitting actual_pre sub1 sub2 frame missing_pi' missing_sigma frame_fld missing_fld frame_typ missing_typ in process_splitting actual_pre sub1 sub2 frame missing_pi' missing_sigma frame_fld missing_fld frame_typ missing_typ in
let report_valid_res split = let report_valid_res split =
match combine match combine
cfg ret_ids posts ret_ids posts
actual_pre path_pre split actual_pre path_pre split
caller_pdesc callee_pname loc with caller_pdesc callee_pname loc with
| None -> Invalid_res Cannot_combine | None -> Invalid_res Cannot_combine
@ -1033,7 +1034,7 @@ let prop_pure_to_footprint (p: 'a Prop.t) : Prop.normal Prop.t =
Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p) Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p)
(** post-process the raw result of a function call *) (** post-process the raw result of a function call *)
let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop results = let exe_call_postprocess ret_ids trace_call callee_pname loc results =
let filter_valid_res = function let filter_valid_res = function
| Invalid_res _ -> false | Invalid_res _ -> false
| Valid_res _ -> true in | Valid_res _ -> true in
@ -1042,10 +1043,10 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
let valid_res = let valid_res =
IList.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 = let invalid_res =
IList.map (function Valid_res cr -> assert false | Invalid_res ir -> ir) invalid_res0 in IList.map (function Valid_res _ -> assert false | Invalid_res ir -> ir) invalid_res0 in
let valid_res_miss_pi, valid_res_no_miss_pi = let valid_res_miss_pi, valid_res_no_miss_pi =
IList.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 = let _, valid_res_cons_pre_missing =
IList.partition (fun vr -> vr.incons_pre_missing) valid_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 deref_errors = IList.filter (function Dereference_error _ -> true | _ -> false) invalid_res in
let print_pi pi = let print_pi pi =
@ -1082,11 +1083,11 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
else if Localise.is_field_not_null_checked_desc desc then else if Localise.is_field_not_null_checked_desc desc then
raise (Exceptions.Field_not_null_checked (desc, __POS__)) raise (Exceptions.Field_not_null_checked (desc, __POS__))
else raise (Exceptions.Null_dereference (desc, __POS__)) else raise (Exceptions.Null_dereference (desc, __POS__))
| Dereference_error (Deref_freed ra, desc, path_opt) -> | Dereference_error (Deref_freed _, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met; trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None; extend_path path_opt None;
raise (Exceptions.Use_after_free (desc, __POS__)) raise (Exceptions.Use_after_free (desc, __POS__))
| Dereference_error (Deref_undef (s, loc, pos), desc, path_opt) -> | Dereference_error (Deref_undef (_, _, pos), desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met; trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos); extend_path path_opt (Some pos);
raise (Exceptions.Skip_pointer_dereference (desc, __POS__)) raise (Exceptions.Skip_pointer_dereference (desc, __POS__))
@ -1156,7 +1157,7 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
| _ -> res | _ -> res
(** Execute the function call and return the list of results with return value *) (** Execute the function call and return the list of results with return value *)
let exe_function_call tenv cfg ret_ids caller_pdesc callee_pname loc actual_params prop path = let exe_function_call tenv ret_ids caller_pdesc callee_pname loc actual_params prop path =
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in
let trace_call res = let trace_call res =
match Specs.get_summary caller_pname with match Specs.get_summary caller_pname with
@ -1169,9 +1170,11 @@ let exe_function_call tenv cfg ret_ids caller_pdesc callee_pname loc actual_para
L.d_strln ("Found " ^ string_of_int nspecs ^ " specs for function " ^ Procname.to_string callee_pname); 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"); L.d_strln ("START EXECUTING SPECS FOR " ^ Procname.to_string callee_pname ^ " from state");
Prop.d_prop prop; L.d_ln (); 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 exe_one_spec (n, spec) =
exe_spec tenv ret_ids (n, nspecs) caller_pdesc callee_pname loc prop path
spec actual_params formal_params in
let results = IList.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 exe_call_postprocess ret_ids trace_call callee_pname loc results
(* (*
let check_splitting_precondition sub1 sub2 = let check_splitting_precondition sub1 sub2 =

2
infer/src/backend/tabulation.mli
Unescape View File

@ -40,7 +40,7 @@ val d_splitting : splitting -> unit
(** Execute the function call and return the list of results with return value *) (** Execute the function call and return the list of results with return value *)
val exe_function_call: val exe_function_call:
Sil.tenv -> Cfg.cfg -> Ident.t list -> Cfg.Procdesc.t -> Procname.t -> Location.t -> Sil.tenv -> Ident.t list -> Cfg.Procdesc.t -> Procname.t -> Location.t ->
(Sil.exp * Sil.typ) list -> Prop.normal Prop.t -> Paths.Path.t -> (Sil.exp * Sil.typ) list -> Prop.normal Prop.t -> Paths.Path.t ->
(Prop.normal Prop.t * Paths.Path.t) list (Prop.normal Prop.t * Paths.Path.t) list

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

@ -112,13 +112,13 @@ type printenv = {
} }
(** Create a colormap of a given color *) (** Create a colormap of a given color *)
let colormap_from_color color (o: Obj.t) = color let colormap_from_color color (_: Obj.t) = color
(** standard colormap: black *) (** standard colormap: black *)
let colormap_black (o: Obj.t) = Black let colormap_black (_: Obj.t) = Black
(** red colormap *) (** red colormap *)
let colormap_red (o: Obj.t) = Red let colormap_red (_: Obj.t) = Red
(** Default text print environment *) (** Default text print environment *)
let pe_text = let pe_text =
@ -552,9 +552,9 @@ module FileNormalize = struct
let rec normalize done_l todo_l = match done_l, todo_l with let rec normalize done_l todo_l = match done_l, todo_l with
| _, y :: tl when y = Filename.current_dir_name -> (* path/. --> path *) | _, y :: tl when y = Filename.current_dir_name -> (* path/. --> path *)
normalize done_l tl normalize done_l tl
| [root], y :: tl when y = Filename.parent_dir_name -> (* /.. --> / *) | [_], y :: tl when y = Filename.parent_dir_name -> (* /.. --> / *)
normalize done_l tl normalize done_l tl
| x :: dl, y :: tl when y = Filename.parent_dir_name -> (* path/x/.. --> path *) | _ :: dl, y :: tl when y = Filename.parent_dir_name -> (* path/x/.. --> path *)
normalize dl tl normalize dl tl
| _, y :: tl -> normalize (y :: done_l) tl | _, y :: tl -> normalize (y :: done_l) tl
| _, [] -> IList.rev done_l | _, [] -> IList.rev done_l

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

@ -37,7 +37,7 @@ let get_field_type_and_annotation fn = function
| Sil.Tptr (Sil.Tstruct struct_typ, _) | Sil.Tptr (Sil.Tstruct struct_typ, _)
| Sil.Tstruct struct_typ -> | Sil.Tstruct struct_typ ->
(try (try
let (_, t, a) = IList.find (fun (f, t, a) -> let (_, t, a) = IList.find (fun (f, _, _) ->
Sil.fld_equal f fn) Sil.fld_equal f fn)
(struct_typ.Sil.instance_fields @ struct_typ.Sil.static_fields) in (struct_typ.Sil.instance_fields @ struct_typ.Sil.static_fields) in
Some (t, a) Some (t, a)
@ -45,7 +45,7 @@ let get_field_type_and_annotation fn = function
| _ -> None | _ -> None
let ia_iter f = let ia_iter f =
let ann_iter (a, b) = f a in let ann_iter (a, _) = f a in
IList.iter ann_iter IList.iter ann_iter
let ma_iter f ((ia, ial) : Sil.method_annotation) = let ma_iter f ((ia, ial) : Sil.method_annotation) =

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

@ -67,7 +67,7 @@ let callback_checker_main
Typename.TN_csu Typename.TN_csu
(Csu.Class Csu.Java, Mangled.from_string (Procname.java_get_class proc_name)) in (Csu.Class Csu.Java, Mangled.from_string (Procname.java_get_class proc_name)) in
match Sil.tenv_lookup tenv typename with match Sil.tenv_lookup tenv typename with
| Some (Sil.Tstruct { Sil.csu; struct_name = Some class_name; def_methods } as typ) -> | Some (Sil.Tstruct { struct_name = Some _; def_methods } as typ) ->
let lifecycle_typs = get_or_create_lifecycle_typs tenv in let lifecycle_typs = get_or_create_lifecycle_typs tenv in
let proc_belongs_to_lifecycle_typ = IList.exists let proc_belongs_to_lifecycle_typ = IList.exists
(fun lifecycle_typ -> AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv) (fun lifecycle_typ -> AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv)
@ -88,7 +88,7 @@ let callback_checker_main
else Procname.Set.add callback_proc callback_procs) else Procname.Set.add callback_proc callback_procs)
callback_procs callback_procs
def_methods' def_methods'
| typ -> callback_procs) | _ -> callback_procs)
!registered_callback_procs !registered_callback_procs
registered_callback_typs in registered_callback_typs in
registered_callback_procs := registered_callback_procs'; registered_callback_procs := registered_callback_procs';

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

@ -65,7 +65,7 @@ let report_error description pn pd loc =
(** Check the final state at the end of the analysis. *) (** Check the final state at the end of the analysis. *)
let check_final_state proc_name proc_desc exit_node final_s = let check_final_state proc_name proc_desc final_s =
let proc_nodes = Cfg.Procdesc.get_nodes proc_desc in let proc_nodes = Cfg.Procdesc.get_nodes proc_desc in
let tot_nodes = IList.length proc_nodes in let tot_nodes = IList.length proc_nodes in
let tot_visited = State.num_visited final_s in let tot_visited = State.num_visited final_s in
@ -94,7 +94,7 @@ let callback_check_dead_code { Callbacks.proc_desc; proc_name } =
let equal = State.equal let equal = State.equal
let join = State.join let join = State.join
let do_node = do_node let do_node = do_node
let proc_throws pn = DontKnow let proc_throws _ = DontKnow
end) in end) in
let do_check () = let do_check () =
@ -105,7 +105,7 @@ let callback_check_dead_code { Callbacks.proc_desc; proc_name } =
match transitions exit_node with match transitions exit_node with
| DFDead.Transition (pre_final_s, _, _) -> | DFDead.Transition (pre_final_s, _, _) ->
let final_s = State.add_visited exit_node pre_final_s in let final_s = State.add_visited exit_node pre_final_s in
check_final_state proc_name proc_desc exit_node final_s check_final_state proc_name proc_desc final_s
| DFDead.Dead_state -> () | DFDead.Dead_state -> ()
end in end in

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

@ -170,7 +170,7 @@ let report_calls_and_accesses callback node instr =
(Format.sprintf "field access %s.%s:%s in %s@." bt fn ft callee) (Format.sprintf "field access %s.%s:%s in %s@." bt fn ft callee)
| None -> | None ->
match PatternMatch.get_java_method_call_formal_signature instr with match PatternMatch.get_java_method_call_formal_signature instr with
| Some (bt, fn, ats, rt) -> | Some (bt, fn, _, rt) ->
ST.report_error ST.report_error
proc_name proc_name
proc_desc proc_desc
@ -184,7 +184,7 @@ let callback_check_access { Callbacks.proc_desc } =
Cfg.Procdesc.iter_instrs (report_calls_and_accesses "PROC") proc_desc Cfg.Procdesc.iter_instrs (report_calls_and_accesses "PROC") proc_desc
(** Report all field accesses and method calls of a class. *) (** Report all field accesses and method calls of a class. *)
let callback_check_cluster_access all_procs get_proc_desc proc_definitions = let callback_check_cluster_access all_procs get_proc_desc _ =
IList.iter IList.iter
(Option.may (fun d -> Cfg.Procdesc.iter_instrs (report_calls_and_accesses "CLUSTER") d)) (Option.may (fun d -> Cfg.Procdesc.iter_instrs (report_calls_and_accesses "CLUSTER") d))
(IList.map get_proc_desc all_procs) (IList.map get_proc_desc all_procs)
@ -211,7 +211,7 @@ let callback_check_write_to_parcel { Callbacks.proc_desc; proc_name; idenv; get_
IList.filter is_parcel_constructor def_methods IList.filter is_parcel_constructor def_methods
| _ -> [] in | _ -> [] in
let check r_name r_desc w_name w_desc = let check r_desc w_desc =
let is_serialization_node node = let is_serialization_node node =
match Cfg.Node.get_callees node with match Cfg.Node.get_callees node with
@ -246,25 +246,24 @@ let callback_check_write_to_parcel { Callbacks.proc_desc; proc_name; idenv; get_
L.stdout "Serialization missmatch in %a for %a and %a@." Procname.pp proc_name Procname.pp rc Procname.pp wc L.stdout "Serialization missmatch in %a for %a and %a@." Procname.pp proc_name Procname.pp rc Procname.pp wc
else else
check_match (rcs, wcs) check_match (rcs, wcs)
| rc:: rcs, [] -> | rc:: _, [] ->
L.stdout "Missing write in %a: for %a@." Procname.pp proc_name Procname.pp rc L.stdout "Missing write in %a: for %a@." Procname.pp proc_name Procname.pp rc
| _, wc:: wcs -> | _, wc:: _ ->
L.stdout "Missing read in %a: for %a@." Procname.pp proc_name Procname.pp wc L.stdout "Missing read in %a: for %a@." Procname.pp proc_name Procname.pp wc
| _ -> () in | _ -> () in
check_match (r_call_descs, w_call_descs) in check_match (r_call_descs, w_call_descs) in
let do_instr node instr = match instr with let do_instr _ instr = match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (_this_exp, this_type):: args, loc, cf) -> | Sil.Call (_, Sil.Const (Sil.Cfun _), (_this_exp, this_type):: _, _, _) ->
let this_exp = Idenv.expand_expr idenv _this_exp in let this_exp = Idenv.expand_expr idenv _this_exp in
if is_write_to_parcel this_exp this_type then begin if is_write_to_parcel this_exp this_type then begin
if !verbose then L.stdout "Serialization check for %a@." Procname.pp proc_name; if !verbose then L.stdout "Serialization check for %a@." Procname.pp proc_name;
try try
match parcel_constructors this_type with match parcel_constructors this_type with
| x :: xs -> | x :: _ ->
(match get_proc_desc x with (match get_proc_desc x with
| Some x_proc_desc -> | Some x_proc_desc -> check x_proc_desc proc_desc
check x x_proc_desc proc_name proc_desc
| None -> raise Not_found) | None -> raise Not_found)
| _ -> L.stdout "No parcel constructor found for %a@." Procname.pp proc_name | _ -> L.stdout "No parcel constructor found for %a@." Procname.pp proc_name
with Not_found -> if !verbose then L.stdout "Methods not available@." with Not_found -> if !verbose then L.stdout "Methods not available@."
@ -330,8 +329,8 @@ let callback_monitor_nullcheck { Callbacks.proc_desc; idenv; proc_name } =
L.stdout "%a@." (PP.pp_loc_range linereader 10 10) loc L.stdout "%a@." (PP.pp_loc_range linereader 10 10) loc
end in end in
let do_instr node instr = match instr with let do_instr _ instr = match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (_arg1, t1):: arg_ts, loc, cf) when is_nullcheck pn -> | Sil.Call (_, Sil.Const (Sil.Cfun pn), (_arg1, _):: _, _, _) when is_nullcheck pn ->
let arg1 = Idenv.expand_expr idenv _arg1 in let arg1 = Idenv.expand_expr idenv _arg1 in
if is_formal_param arg1 then handle_check_of_formal arg1; if is_formal_param arg1 then handle_check_of_formal arg1;
if !verbose then L.stdout "call in %s %s: %a with first arg: %a@." (Procname.java_get_class proc_name) (Procname.java_get_method proc_name) (Sil.pp_instr pe_text) instr (Sil.pp_exp pe_text) arg1 if !verbose then L.stdout "call in %s %s: %a with first arg: %a@." (Procname.java_get_class proc_name) (Procname.java_get_method proc_name) (Sil.pp_instr pe_text) instr (Sil.pp_exp pe_text) arg1
@ -386,30 +385,30 @@ let callback_find_deserialization { Callbacks.proc_desc; get_proc_desc; idenv; p
| None -> "?" in | None -> "?" in
let get_actual_arguments node instr = match instr with let get_actual_arguments node instr = match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> | Sil.Call (_, Sil.Const (Sil.Cfun _), _:: args, _, _) ->
(try (try
let find_const exp typ = let find_const exp =
let expanded = Idenv.expand_expr idenv exp in let expanded = Idenv.expand_expr idenv exp in
match expanded with match expanded with
| Sil.Const (Sil.Cclass n) -> Ident.name_to_string n | Sil.Const (Sil.Cclass n) -> Ident.name_to_string n
| Sil.Lvar p -> ( | Sil.Lvar _ -> (
let is_call_instr set call = match set, call with let is_call_instr set call = match set, call with
| Sil.Set (_, _, Sil.Var (i1), _), Sil.Call (i2::[], _, _, _, _) | Sil.Set (_, _, Sil.Var (i1), _), Sil.Call (i2::[], _, _, _, _)
when Ident.equal i1 i2 -> true when Ident.equal i1 i2 -> true
| _ -> false in | _ -> false in
let is_set_instr = function let is_set_instr = function
| Sil.Set (e1, t, e2, l) when Sil.exp_equal expanded e1 -> true | Sil.Set (e1, _, _, _) when Sil.exp_equal expanded e1 -> true
| _ -> false in | _ -> false in
match reverse_find_instr is_set_instr node with match reverse_find_instr is_set_instr node with
(** Look for ivar := tmp *) (** Look for ivar := tmp *)
| Some s -> ( | Some s -> (
match reverse_find_instr (is_call_instr s) node with match reverse_find_instr (is_call_instr s) node with
(** Look for tmp := foo() *) (** Look for tmp := foo() *)
| Some (Sil.Call (_, Sil.Const (Sil.Cfun pn), _, l, _)) -> get_return_const pn | Some (Sil.Call (_, Sil.Const (Sil.Cfun pn), _, _, _)) -> get_return_const pn
| _ -> "?") | _ -> "?")
| _ -> "?") | _ -> "?")
| _ -> "?" in | _ -> "?" in
let arg_name (exp, typ) = find_const exp typ in let arg_name (exp, _) = find_const exp in
Some (IList.map arg_name args) Some (IList.map arg_name args)
with _ -> None) with _ -> None)
| _ -> None in | _ -> None in
@ -459,7 +458,7 @@ let callback_check_field_access { Callbacks.proc_desc } =
| Sil.Cast (_, e) -> | Sil.Cast (_, e) ->
do_exp is_read e do_exp is_read e
| Sil.Lvar _ -> () | Sil.Lvar _ -> ()
| Sil.Lfield (e, fn, t) -> | Sil.Lfield (e, fn, _) ->
if not (Ident.java_fieldname_is_outer_instance fn) then if not (Ident.java_fieldname_is_outer_instance fn) then
L.stdout "field %s %s@." (Ident.fieldname_to_string fn) (if is_read then "reading" else "writing"); L.stdout "field %s %s@." (Ident.fieldname_to_string fn) (if is_read then "reading" else "writing");
do_exp is_read e do_exp is_read e
@ -469,7 +468,7 @@ let callback_check_field_access { Callbacks.proc_desc } =
| Sil.Sizeof _ -> () in | Sil.Sizeof _ -> () in
let do_read_exp = do_exp true in let do_read_exp = do_exp true in
let do_write_exp = do_exp false in let do_write_exp = do_exp false in
let do_instr node = function let do_instr _ = function
| Sil.Letderef (_, e, _, _) -> | Sil.Letderef (_, e, _, _) ->
do_read_exp e do_read_exp e
| Sil.Set (e1, _, e2, _) -> | Sil.Set (e1, _, e2, _) ->
@ -492,7 +491,7 @@ let callback_check_field_access { Callbacks.proc_desc } =
(** Print c method calls. *) (** Print c method calls. *)
let callback_print_c_method_calls { Callbacks.proc_desc; proc_name } = let callback_print_c_method_calls { Callbacks.proc_desc; proc_name } =
let do_instr node = function let do_instr node = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (e, t):: args, loc, cf) | Sil.Call (_, Sil.Const (Sil.Cfun pn), (e, _):: _, loc, _)
when Procname.is_c_method pn -> when Procname.is_c_method pn ->
let receiver = match Errdesc.exp_rv_dexp node e with let receiver = match Errdesc.exp_rv_dexp node e with
| Some de -> Sil.dexp_to_string de | Some de -> Sil.dexp_to_string de

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

@ -100,7 +100,7 @@ module Match = struct
| CodeQueryAst.Null, Vval e -> Sil.exp_equal e Sil.exp_zero | CodeQueryAst.Null, Vval e -> Sil.exp_equal e Sil.exp_zero
| CodeQueryAst.Null, _ -> false | CodeQueryAst.Null, _ -> false
| CodeQueryAst.ConstString s, (Vfun pn) -> string_contains s (Procname.to_string pn) | CodeQueryAst.ConstString s, (Vfun pn) -> string_contains s (Procname.to_string pn)
| CodeQueryAst.ConstString s, _ -> false | CodeQueryAst.ConstString _, _ -> false
| CodeQueryAst.Ident id, x -> | CodeQueryAst.Ident id, x ->
env_add env id x env_add env id x
@ -158,7 +158,7 @@ module Match = struct
| Some s -> s in | Some s -> s in
Err.add_error_to_spec proc_name err_name node loc Err.add_error_to_spec proc_name err_name node loc
let rec match_query show env idenv node caller_pn (rule, action) proc_name node instr = let rec match_query show env idenv caller_pn (rule, action) proc_name node instr =
match rule, instr with match rule, instr with
| CodeQueryAst.Call (ae1, ae2), Sil.Call (_, Sil.Const (Sil.Cfun pn), _, loc, _) -> | CodeQueryAst.Call (ae1, ae2), Sil.Call (_, Sil.Const (Sil.Cfun pn), _, loc, _) ->
if exp_match env ae1 (Vfun caller_pn) && exp_match env ae2 (Vfun pn) then if exp_match env ae1 (Vfun caller_pn) && exp_match env ae2 (Vfun pn) then
@ -168,9 +168,10 @@ module Match = struct
end end
else false else false
| CodeQueryAst.Call _, _ -> false | CodeQueryAst.Call _, _ -> false
| CodeQueryAst.MethodCall (ae1, ae2, ael_opt), Sil.Call (_, Sil.Const (Sil.Cfun pn), (_e1, t1):: params, loc, { Sil.cf_virtual = true }) -> | CodeQueryAst.MethodCall (ae1, ae2, ael_opt),
Sil.Call (_, Sil.Const (Sil.Cfun pn), (_e1, _):: params, loc, { Sil.cf_virtual = true }) ->
let e1 = Idenv.expand_expr idenv _e1 in let e1 = Idenv.expand_expr idenv _e1 in
let vl = IList.map (function _e, t -> Vval (Idenv.expand_expr idenv _e)) params in let vl = IList.map (function _e, _ -> 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 if exp_match env ae1 (Vval e1) && exp_match env ae2 (Vfun pn) && opt_match exp_list_match env ael_opt vl then
begin begin
if show then print_action env action proc_name node loc; if show then print_action env action proc_name node loc;
@ -178,13 +179,14 @@ module Match = struct
end end
else false else false
| CodeQueryAst.MethodCall _, _ -> false | CodeQueryAst.MethodCall _, _ -> false
| CodeQueryAst.If (ae1, op, ae2, body_rule), Sil.Prune (cond, loc, true_branch, ik) -> | CodeQueryAst.If (ae1, op, ae2, body_rule), Sil.Prune (cond, loc, true_branch, _) ->
if true_branch && cond_match env idenv cond (ae1, op, ae2) then if true_branch && cond_match env idenv cond (ae1, op, ae2) then
begin begin
let found = ref false in let found = ref false in
let iter (node', instr') = let iter (_, instr') =
let env' = env_copy env in let env' = env_copy env in
if not !found && match_query false env' idenv node' caller_pn (body_rule, action) proc_name node instr' if not !found
&& match_query false env' idenv caller_pn (body_rule, action) proc_name node instr'
then found := true in then found := true in
iter_succ_nodes node iter; iter_succ_nodes node iter;
let line_contains_null () = let line_contains_null () =
@ -206,7 +208,8 @@ end
let code_query_callback { Callbacks.proc_desc; idenv; proc_name } = let code_query_callback { Callbacks.proc_desc; idenv; proc_name } =
let do_instr node instr = let do_instr node instr =
let env = Match.init_env () in let env = Match.init_env () in
let _found = Match.match_query true env idenv node proc_name (Lazy.force query_ast) proc_name node instr in let _found =
Match.match_query true env idenv proc_name (Lazy.force query_ast) proc_name node instr in
() in () in
if verbose then L.stdout "code_query_callback on %a@." Procname.pp proc_name; if verbose then L.stdout "code_query_callback on %a@." Procname.pp proc_name;
Cfg.Procdesc.iter_instrs do_instr proc_desc; Cfg.Procdesc.iter_instrs do_instr proc_desc;

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

@ -14,7 +14,7 @@ let string_widening_limit = 1000
let verbose = false let verbose = false
(* Merge two constant maps by adding keys as necessary *) (* Merge two constant maps by adding keys as necessary *)
let merge_values key c1_opt c2_opt = let merge_values _ c1_opt c2_opt =
match c1_opt, c2_opt with match c1_opt, c2_opt with
| Some (Some c1), Some (Some c2) when Sil.const_equal c1 c2 -> Some (Some c1) | Some (Some c1), Some (Some c2) when Sil.const_equal c1 c2 -> Some (Some c1)
| Some c, None | Some c, None
@ -43,7 +43,7 @@ module ConstantFlow = Dataflow.MakeDF(struct
let join = ConstantMap.merge merge_values let join = ConstantMap.merge merge_values
let proc_throws pn = Dataflow.DontKnow let proc_throws _ = Dataflow.DontKnow
let do_node node constants = let do_node node constants =

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

@ -46,15 +46,15 @@ let node_throws node (proc_throws : Procname.t -> throws) : throws =
let ret_pvar = Cfg.Procdesc.get_ret_var pdesc in let ret_pvar = Cfg.Procdesc.get_ret_var pdesc in
Sil.pvar_equal pvar ret_pvar in Sil.pvar_equal pvar ret_pvar in
match instr with match instr with
| Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar -> | Sil.Set (Sil.Lvar pvar, _, Sil.Const (Sil.Cexn _), _) when pvar_is_return pvar ->
(* assignment to return variable is an artifact of a throw instruction *) (* assignment to return variable is an artifact of a throw instruction *)
Throws Throws
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), args, loc, _) | Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), _, _, _)
when SymExec.function_is_builtin callee_pn -> when SymExec.function_is_builtin callee_pn ->
if Procname.equal callee_pn SymExec.ModelBuiltins.__cast if Procname.equal callee_pn SymExec.ModelBuiltins.__cast
then DontKnow then DontKnow
else DoesNotThrow else DoesNotThrow
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), args, loc, _) -> | Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), _, _, _) ->
proc_throws callee_pn proc_throws callee_pn
| _ -> | _ ->
DoesNotThrow in DoesNotThrow in
@ -173,11 +173,11 @@ let callback_test_dataflow { Callbacks.proc_desc } =
let do_node n s = let do_node n s =
if verbose then L.stdout "visiting node %a with state %d@." Cfg.Node.pp n s; if verbose then L.stdout "visiting node %a with state %d@." Cfg.Node.pp n s;
[s + 1], [s + 1] [s + 1], [s + 1]
let proc_throws pn = DoesNotThrow let proc_throws _ = DoesNotThrow
end) in end) in
let transitions = DFCount.run proc_desc 0 in let transitions = DFCount.run proc_desc 0 in
let do_node node = let do_node node =
match transitions node with match transitions node with
| DFCount.Transition (pre_state, _, _) -> () | DFCount.Transition _ -> ()
| DFCount.Dead_state -> () in | DFCount.Dead_state -> () in
IList.iter do_node (Cfg.Procdesc.get_nodes proc_desc) IList.iter do_node (Cfg.Procdesc.get_nodes proc_desc)

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

@ -13,10 +13,10 @@
type t = (Sil.exp Ident.IdentHash.t) Lazy.t * Cfg.cfg type t = (Sil.exp Ident.IdentHash.t) Lazy.t * Cfg.cfg
let _create cfg proc_desc = let _create proc_desc =
let map = Ident.IdentHash.create 1 in let map = Ident.IdentHash.create 1 in
let do_instr node = function let do_instr _ = function
| Sil.Letderef (id, e, t, loc) -> | Sil.Letderef (id, e, _, _) ->
Ident.IdentHash.add map id e Ident.IdentHash.add map id e
| _ -> () in | _ -> () in
Cfg.Procdesc.iter_instrs do_instr proc_desc; Cfg.Procdesc.iter_instrs do_instr proc_desc;
@ -24,12 +24,12 @@ let _create cfg proc_desc =
(* lazy implementation, only create when used *) (* lazy implementation, only create when used *)
let create cfg proc_desc = let create cfg proc_desc =
let map = lazy (_create cfg proc_desc) in let map = lazy (_create proc_desc) in
map, cfg map, cfg
(* create an idenv for another procedure *) (* create an idenv for another procedure *)
let create_from_idenv (_, cfg) proc_desc = let create_from_idenv (_, cfg) proc_desc =
let map = lazy (_create cfg proc_desc) in let map = lazy (_create proc_desc) in
map, cfg map, cfg
let lookup (_map, _) id = let lookup (_map, _) id =

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

@ -33,7 +33,7 @@ let is_direct_subtype_of this_type super_type_name =
(** The type the method is invoked on *) (** The type the method is invoked on *)
let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals with let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals with
| (n, t):: args -> Some t | (_, t):: _ -> Some t
| _ -> None | _ -> None
let type_get_direct_supertypes = function let type_get_direct_supertypes = function
@ -137,7 +137,7 @@ let get_vararg_type_names
(Sil.pvar_equal ivar iv && Ident.equal t1 t2 && (Sil.pvar_equal ivar iv && Ident.equal t1 t2 &&
Procname.equal pn (Procname.from_string_c_fun "__new_array")) Procname.equal pn (Procname.from_string_c_fun "__new_array"))
|| initializes_array is || initializes_array is
| i:: is -> initializes_array is | _:: is -> initializes_array is
| _ -> false in | _ -> false in
(* Get the type name added to ivar or None *) (* Get the type name added to ivar or None *)
@ -146,10 +146,10 @@ let get_vararg_type_names
match instrs with match instrs with
| Sil.Letderef (nv, Sil.Lfield (_, id, t), _, _):: _ | Sil.Letderef (nv, Sil.Lfield (_, id, t), _, _):: _
when Ident.equal nv nvar -> get_field_type_name t id when Ident.equal nv nvar -> get_field_type_name t id
| Sil.Letderef (nv, e, t, _):: _ | Sil.Letderef (nv, _, t, _):: _
when Ident.equal nv nvar -> when Ident.equal nv nvar ->
Some (get_type_name t) Some (get_type_name t)
| i:: is -> nvar_type_name nvar is | _:: is -> nvar_type_name nvar is
| _ -> None in | _ -> None in
let rec added_nvar array_nvar instrs = let rec added_nvar array_nvar instrs =
match instrs with match instrs with
@ -157,14 +157,14 @@ let get_vararg_type_names
when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node) when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node)
| Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Const c, _):: _ | Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Const c, _):: _
when Ident.equal iv array_nvar -> Some (java_get_const_type_name c) when Ident.equal iv array_nvar -> Some (java_get_const_type_name c)
| i:: is -> added_nvar array_nvar is | _:: is -> added_nvar array_nvar is
| _ -> None in | _ -> None in
let rec array_nvar instrs = let rec array_nvar instrs =
match instrs with match instrs with
| Sil.Letderef (nv, Sil.Lvar iv, _, _):: _ | Sil.Letderef (nv, Sil.Lvar iv, _, _):: _
when Sil.pvar_equal iv ivar -> when Sil.pvar_equal iv ivar ->
added_nvar nv instrs added_nvar nv instrs
| i:: is -> array_nvar is | _:: is -> array_nvar is
| _ -> None in | _ -> None in
array_nvar (Cfg.Node.get_instrs node) in array_nvar (Cfg.Node.get_instrs node) in
@ -181,7 +181,7 @@ let get_vararg_type_names
IList.rev (type_names call_node) IList.rev (type_names call_node)
let has_formal_proc_argument_type_names proc_desc proc_name argument_type_names = let has_formal_proc_argument_type_names proc_desc argument_type_names =
let formals = Cfg.Procdesc.get_formals proc_desc in 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 let equal_formal_arg (_, typ) arg_type_name = get_type_name typ = arg_type_name in
IList.length formals = IList.length argument_type_names IList.length formals = IList.length argument_type_names
@ -189,7 +189,7 @@ let has_formal_proc_argument_type_names proc_desc proc_name argument_type_names
let has_formal_method_argument_type_names cfg proc_name argument_type_names = let has_formal_method_argument_type_names cfg proc_name argument_type_names =
has_formal_proc_argument_type_names has_formal_proc_argument_type_names
cfg proc_name ((Procname.java_get_class proc_name):: argument_type_names) cfg ((Procname.java_get_class proc_name):: argument_type_names)
let is_getter proc_name = let is_getter proc_name =
Str.string_match (Str.regexp "get*") (Procname.java_get_method proc_name) 0 Str.string_match (Str.regexp "get*") (Procname.java_get_method proc_name) 0
@ -199,16 +199,16 @@ let is_setter proc_name =
(** Returns the signature of a field access (class name, field name, field type name) *) (** Returns the signature of a field access (class name, field name, field type name) *)
let get_java_field_access_signature = function let get_java_field_access_signature = function
| Sil.Letderef (id, Sil.Lfield (e, fn, ft), bt, loc) -> | Sil.Letderef (_, Sil.Lfield (_, fn, ft), bt, _) ->
Some (get_type_name bt, Ident.java_fieldname_get_field fn, get_type_name ft) Some (get_type_name bt, Ident.java_fieldname_get_field fn, get_type_name ft)
| _ -> None | _ -> None
(** Returns the formal signature (class name, method name, (** Returns the formal signature (class name, method name,
argument type names and return type name) *) argument type names and return type name) *)
let get_java_method_call_formal_signature = function let get_java_method_call_formal_signature = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) -> | Sil.Call (_, Sil.Const (Sil.Cfun pn), (_, tt):: args, _, _) ->
(try (try
let arg_names = IList.map (function | e, t -> get_type_name t) args in let arg_names = IList.map (function | _, t -> get_type_name t) args in
let rt_name = Procname.java_get_return_type pn in let rt_name = Procname.java_get_return_type pn in
let m_name = Procname.java_get_method pn in let m_name = Procname.java_get_method pn in
Some (get_type_name tt, m_name, arg_names, rt_name) Some (get_type_name tt, m_name, arg_names, rt_name)
@ -262,7 +262,7 @@ let method_is_initializer
| None -> false | None -> false
(** Get the vararg values by looking for array assignments to the pvar. *) (** Get the vararg values by looking for array assignments to the pvar. *)
let java_get_vararg_values node pvar idenv pdesc = let java_get_vararg_values node pvar idenv =
let values = ref [] in let values = ref [] in
let do_instr = function let do_instr = function
| Sil.Set (Sil.Lindex (array_exp, _), _, content_exp, _) | Sil.Set (Sil.Lindex (array_exp, _), _, content_exp, _)
@ -274,13 +274,13 @@ let java_get_vararg_values node pvar idenv pdesc =
IList.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 let () = match Errdesc.find_program_variable_assignment node pvar with
| Some (node', _) -> | Some (node', _) ->
Cfg.Procdesc.iter_slope_range do_node pdesc node' node Cfg.Procdesc.iter_slope_range do_node node' node
| None -> () in | None -> () in
!values !values
let proc_calls resolve_attributes pname pdesc filter : (Procname.t * ProcAttributes.t) list = let proc_calls resolve_attributes pdesc filter : (Procname.t * ProcAttributes.t) list =
let res = ref [] in let res = ref [] in
let do_instruction node instr = match instr with let do_instruction _ instr = match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), _, _, _) -> | Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), _, _, _) ->
begin begin
match resolve_attributes callee_pn with match resolve_attributes callee_pn with
@ -329,7 +329,7 @@ let proc_iter_overridden_methods f tenv proc_name =
let get_fields_nullified procdesc = let get_fields_nullified procdesc =
(* walk through the instructions and look for instance fields that are assigned to null *) (* walk through the instructions and look for instance fields that are assigned to null *)
let collect_nullified_flds (nullified_flds, this_ids) _ = function let collect_nullified_flds (nullified_flds, this_ids) _ = function
| Sil.Set (Sil.Lfield (Sil.Var lhs, fld, _), typ, rhs, loc) | Sil.Set (Sil.Lfield (Sil.Var lhs, fld, _), _, rhs, _)
when Sil.exp_is_null_literal rhs && Ident.IdentSet.mem lhs this_ids -> when Sil.exp_is_null_literal rhs && Ident.IdentSet.mem lhs this_ids ->
(Ident.FieldSet.add fld nullified_flds, this_ids) (Ident.FieldSet.add fld nullified_flds, this_ids)
| Sil.Letderef (id, rhs, _, _) when Sil.exp_is_this rhs -> | Sil.Letderef (id, rhs, _, _) when Sil.exp_is_this rhs ->

4
infer/src/checkers/patternMatch.mli
Unescape View File

@ -44,14 +44,14 @@ val is_direct_subtype_of : Sil.typ -> Typename.t -> bool
val java_get_const_type_name : Sil.const -> string val java_get_const_type_name : Sil.const -> string
(** Get the values of a vararg parameter given the pvar used to assign the elements. *) (** Get the values of a vararg parameter given the pvar used to assign the elements. *)
val java_get_vararg_values : Cfg.Node.t -> Sil.pvar -> Idenv.t -> Cfg.Procdesc.t -> Sil.exp list val java_get_vararg_values : Cfg.Node.t -> Sil.pvar -> Idenv.t -> Sil.exp list
val java_proc_name_with_class_method : Procname.t -> string -> string -> bool val java_proc_name_with_class_method : Procname.t -> string -> string -> bool
(** Return the callees that satisfy [filter]. *) (** Return the callees that satisfy [filter]. *)
val proc_calls : val proc_calls :
(Procname.t -> ProcAttributes.t option) -> (Procname.t -> ProcAttributes.t option) ->
Procname.t -> Cfg.Procdesc.t -> Cfg.Procdesc.t ->
(Procname.t -> ProcAttributes.t -> bool) -> (Procname.t -> ProcAttributes.t -> bool) ->
(Procname.t * ProcAttributes.t) list (Procname.t * ProcAttributes.t) list

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

@ -158,16 +158,16 @@ let check_printf_args_ok
match instrs, nvar with match instrs, nvar with
| Sil.Letderef (id, Sil.Lvar iv, _, _):: _, Sil.Var nid | Sil.Letderef (id, Sil.Lvar iv, _, _):: _, Sil.Var nid
when Ident.equal id nid -> iv when Ident.equal id nid -> iv
| i:: is, _ -> array_ivar is nvar | _:: is, _ -> array_ivar is nvar
| _ -> raise Not_found in | _ -> raise Not_found in
let rec fixed_nvar_type_name instrs nvar = let rec fixed_nvar_type_name instrs nvar =
match nvar with match nvar with
| Sil.Var nid -> ( | Sil.Var nid -> (
match instrs with match instrs with
| Sil.Letderef (id, Sil.Lvar iv, t, _):: _ | Sil.Letderef (id, Sil.Lvar _, t, _):: _
when Ident.equal id nid -> PatternMatch.get_type_name t when Ident.equal id nid -> PatternMatch.get_type_name t
| i:: is -> fixed_nvar_type_name is nvar | _:: is -> fixed_nvar_type_name is nvar
| _ -> raise Not_found) | _ -> raise Not_found)
| Sil.Const c -> PatternMatch.java_get_const_type_name c | Sil.Const c -> PatternMatch.java_get_const_type_name c
| _ -> raise (Failure "Could not resolve fixed type name") in | _ -> raise (Failure "Could not resolve fixed type name") in

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

@ -23,7 +23,7 @@ struct
Set.Make(struct Set.Make(struct
type t = Sil.instr type t = Sil.instr
let compare i1 i2 = match i1, i2 with let compare i1 i2 = match i1, i2 with
| Sil.Call (ret1, e1, etl1, loc1, cf1), Sil.Call (ret2, e2, etl2, loc2, cf2) -> | Sil.Call (_, e1, etl1, _, cf1), Sil.Call (_, e2, etl2, _, cf2) ->
(* ignore return ids and call flags *) (* ignore return ids and call flags *)
let n = Sil.exp_compare e1 e2 in let n = Sil.exp_compare e1 e2 in
if n <> 0 then n else let n = IList.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
@ -87,7 +87,7 @@ struct
| Some loc, None | Some loc, None
| None, Some loc -> | None, Some loc ->
if _paths = AllPaths then None else Some loc if _paths = AllPaths then None else Some loc
| Some loc1, Some loc2 -> | Some loc1, Some _ ->
Some loc1 (* left priority *) Some loc1 (* left priority *)
let join = _join paths let join = _join paths
let do_node node lo1 = let do_node node lo1 =
@ -95,7 +95,7 @@ struct
let lo' = (* use left priority join to implement transfer function *) let lo' = (* use left priority join to implement transfer function *)
_join SomePath lo1 lo2 in _join SomePath lo1 lo2 in
[lo'], [lo'] [lo'], [lo']
let proc_throws pn = Dataflow.DontKnow let proc_throws _ = Dataflow.DontKnow
end) in end) in
let transitions = DFAllocCheck.run pdesc None in let transitions = DFAllocCheck.run pdesc None in
@ -104,11 +104,11 @@ struct
| DFAllocCheck.Dead_state -> None | DFAllocCheck.Dead_state -> None
(** Check repeated calls to the same procedure. *) (** Check repeated calls to the same procedure. *)
let check_instr get_proc_desc curr_pname curr_pdesc node extension instr normalized_etl = let check_instr get_proc_desc curr_pname curr_pdesc extension instr normalized_etl =
(** Arguments are not temporary variables. *) (** Arguments are not temporary variables. *)
let arguments_not_temp args = let arguments_not_temp args =
let filter_arg (e, t) = match e with let filter_arg (e, _) = match e with
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
(* same temporary variable does not imply same value *) (* same temporary variable does not imply same value *)
not (Errdesc.pvar_is_frontend_tmp pvar) not (Errdesc.pvar_is_frontend_tmp pvar)
@ -158,7 +158,7 @@ struct
pp = pp; pp = pp;
} }
let update_payload typestate payload = payload let update_payload _ payload = payload
end (* CheckRepeatedCalls *) end (* CheckRepeatedCalls *)
module MainRepeatedCalls = module MainRepeatedCalls =

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

@ -104,7 +104,7 @@ let create_struct_type struct_name = `StructType struct_name
let create_pointer_type typ = `PointerOf typ let create_pointer_type typ = `PointerOf typ
let create_integer_literal stmt_info n = let create_integer_literal n =
let stmt_info = dummy_stmt_info () in let stmt_info = dummy_stmt_info () in
let expr_info = { let expr_info = {
Clang_ast_t.ei_type_ptr = create_int_type; Clang_ast_t.ei_type_ptr = create_int_type;
@ -151,7 +151,7 @@ let create_implicit_cast_expr stmt_info stmts typ cast_kind =
Clang_ast_t.ImplicitCastExpr (stmt_info, stmts, expr_info, cast_expr_info) Clang_ast_t.ImplicitCastExpr (stmt_info, stmts, expr_info, cast_expr_info)
let create_nil stmt_info = let create_nil stmt_info =
let integer_literal = create_integer_literal stmt_info "0" in let integer_literal = create_integer_literal "0" in
let cstyle_cast_expr = create_cstyle_cast_expr stmt_info [integer_literal] create_int_type in let cstyle_cast_expr = create_cstyle_cast_expr stmt_info [integer_literal] create_int_type in
let paren_expr = create_parent_expr stmt_info [cstyle_cast_expr] in let paren_expr = create_parent_expr stmt_info [cstyle_cast_expr] in
create_implicit_cast_expr stmt_info [paren_expr] create_id_type `NullToPointer create_implicit_cast_expr stmt_info [paren_expr] create_id_type `NullToPointer
@ -218,7 +218,7 @@ let make_decl_ref_expr_info decl_ref = {
drti_found_decl_ref = None; drti_found_decl_ref = None;
} }
let make_objc_ivar_decl decl_info tp property_impl_decl_info ivar_name = let make_objc_ivar_decl decl_info tp ivar_name =
let field_decl_info = { let field_decl_info = {
Clang_ast_t.fldi_is_mutable = true; Clang_ast_t.fldi_is_mutable = true;
fldi_is_module_private = true; fldi_is_module_private = true;
@ -265,7 +265,7 @@ let make_binary_stmt stmt1 stmt2 stmt_info expr_info boi =
let make_next_object_exp stmt_info item items = let make_next_object_exp stmt_info item items =
let var_decl_ref, var_type = let var_decl_ref, var_type =
match item with match item with
| Clang_ast_t.DeclStmt (stmt_info, _, [Clang_ast_t.VarDecl(di, name_info, var_type, _)]) -> | Clang_ast_t.DeclStmt (_, _, [Clang_ast_t.VarDecl(di, name_info, var_type, _)]) ->
let decl_ptr = di.Clang_ast_t.di_pointer in let decl_ptr = di.Clang_ast_t.di_pointer in
let decl_ref = make_decl_ref_tp `Var decl_ptr name_info false var_type in let decl_ref = make_decl_ref_tp `Var decl_ptr name_info false var_type in
let stmt_info_var = { let stmt_info_var = {
@ -290,7 +290,7 @@ let make_next_object_exp stmt_info item items =
(* dispatch_once(v,block_def) is transformed as: *) (* dispatch_once(v,block_def) is transformed as: *)
(* void (^block_var)()=block_def; block_var() *) (* void (^block_var)()=block_def; block_var() *)
let translate_dispatch_function block_name stmt_info stmt_list ei n = let translate_dispatch_function block_name stmt_info stmt_list n =
let block_expr = let block_expr =
try IList.nth stmt_list (n + 1) try IList.nth stmt_list (n + 1)
with Not_found -> assert false in with Not_found -> assert false in
@ -300,7 +300,7 @@ let translate_dispatch_function block_name stmt_info stmt_list ei n =
} in } in
let open Clang_ast_t in let open Clang_ast_t in
match block_expr with match block_expr with
| BlockExpr (bsi, bsl, bei, bd) -> | BlockExpr (_, _, bei, _) ->
let tp = bei.ei_type_ptr in let tp = bei.ei_type_ptr in
let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} in let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} in
let block_def = ImplicitCastExpr(stmt_info,[block_expr], bei, cast_info) in let block_def = ImplicitCastExpr(stmt_info,[block_expr], bei, cast_info) in
@ -344,7 +344,7 @@ let pseudo_object_tp () = create_class_type (CFrontend_config.pseudo_object_type
(* Create expression PseudoObjectExpr for 'o.m' *) (* Create expression PseudoObjectExpr for 'o.m' *)
let build_PseudoObjectExpr tp_m o_cast_decl_ref_exp mname = let build_PseudoObjectExpr tp_m o_cast_decl_ref_exp mname =
match o_cast_decl_ref_exp with match o_cast_decl_ref_exp with
| Clang_ast_t.ImplicitCastExpr (si, stmt_list, ei, cast_expr_info) -> | Clang_ast_t.ImplicitCastExpr (si, _, ei, _) ->
let ove = build_OpaqueValueExpr si o_cast_decl_ref_exp ei in let ove = build_OpaqueValueExpr si o_cast_decl_ref_exp ei in
let ei_opre = make_expr_info (pseudo_object_tp ()) in let ei_opre = make_expr_info (pseudo_object_tp ()) in
let count_name = Ast_utils.make_name_decl CFrontend_config.count in let count_name = Ast_utils.make_name_decl CFrontend_config.count in
@ -410,7 +410,7 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let build_idx_decl pidx = let build_idx_decl pidx =
match pidx with match pidx with
| Clang_ast_t.ParmVarDecl (di_idx, name_idx, tp_idx, _) -> | Clang_ast_t.ParmVarDecl (di_idx, name_idx, tp_idx, _) ->
let zero = create_integer_literal stmt_info "0" in let zero = create_integer_literal "0" in
(* tp_idx idx = 0; *) (* tp_idx idx = 0; *)
let idx_decl_stmt = make_DeclStmt (fresh_stmt_info stmt_info) di_idx tp_idx name_idx (Some zero) in let idx_decl_stmt = make_DeclStmt (fresh_stmt_info stmt_info) di_idx tp_idx name_idx (Some zero) in
let idx_ei = make_expr_info tp_idx in let idx_ei = make_expr_info tp_idx in
@ -475,7 +475,7 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
(* idx<a.count *) (* idx<a.count *)
let bin_op pidx array_decl_ref_exp = let bin_op pidx array_decl_ref_exp =
let idx_decl_stmt, idx_decl_ref_exp, idx_cast, idx_tp = build_idx_decl pidx in let _, _, idx_cast, idx_tp = build_idx_decl pidx in
let rhs = build_PseudoObjectExpr idx_tp array_decl_ref_exp CFrontend_config.count in let rhs = build_PseudoObjectExpr idx_tp array_decl_ref_exp CFrontend_config.count in
let lt = { Clang_ast_t.boi_kind = `LT } in let lt = { Clang_ast_t.boi_kind = `LT } in
let exp_info = make_expr_info create_int_type in let exp_info = make_expr_info create_int_type in
@ -493,7 +493,7 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
| _ -> assert false in | _ -> assert false in
(* id object = objects[idx]; *) (* id object = objects[idx]; *)
let build_object_DeclStmt pobj decl_ref_expr_array decl_ref_expr_idx tp_idx = let build_object_DeclStmt pobj decl_ref_expr_array decl_ref_expr_idx =
let open Clang_ast_t in let open Clang_ast_t in
match pobj with match pobj with
| ParmVarDecl(di_obj, name_obj, tp_obj, _) -> | ParmVarDecl(di_obj, name_obj, tp_obj, _) ->
@ -525,7 +525,7 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let make_object_cast_decl_ref_expr objects = let make_object_cast_decl_ref_expr objects =
match objects with match objects with
| Clang_ast_t.DeclStmt (si, _, [Clang_ast_t.VarDecl (di, name, tp, vdi)]) -> | Clang_ast_t.DeclStmt (si, _, [Clang_ast_t.VarDecl (_, name, tp, _)]) ->
let decl_ref = make_decl_ref_tp `Var si.Clang_ast_t.si_pointer name false tp in let decl_ref = make_decl_ref_tp `Var si.Clang_ast_t.si_pointer name false tp in
cast_expr decl_ref tp cast_expr decl_ref tp
| _ -> assert false in | _ -> assert false in
@ -574,7 +574,7 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let idx_decl_stmt, idx_decl_ref_exp, idx_cast, tp_idx = build_idx_decl pidx in let idx_decl_stmt, idx_decl_ref_exp, idx_cast, tp_idx = build_idx_decl pidx in
let guard = bin_op pidx objects in let guard = bin_op pidx objects in
let incr = un_op idx_decl_ref_exp tp_idx in let incr = un_op idx_decl_ref_exp tp_idx in
let obj_assignment = build_object_DeclStmt pobj objects idx_cast tp_idx in let obj_assignment = build_object_DeclStmt pobj objects idx_cast in
let object_cast = build_cast_decl_ref_expr_from_parm pobj in let object_cast = build_cast_decl_ref_expr_from_parm pobj in
let stop_cast = build_cast_decl_ref_expr_from_parm pstop in let stop_cast = build_cast_decl_ref_expr_from_parm pstop in
let call_block = make_block_call block_tp object_cast idx_cast stop_cast in let call_block = make_block_call block_tp object_cast idx_cast stop_cast in
@ -598,7 +598,7 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
(* We translate the logical negation of an integer with a conditional*) (* We translate the logical negation of an integer with a conditional*)
(* !x <=> x?0:1 *) (* !x <=> x?0:1 *)
let trans_negation_with_conditional stmt_info expr_info stmt_list = let trans_negation_with_conditional stmt_info expr_info stmt_list =
let stmt_list_cond = stmt_list @ [create_integer_literal stmt_info "0"] @ [create_integer_literal stmt_info "1"] in let stmt_list_cond = stmt_list @ [create_integer_literal "0"] @ [create_integer_literal "1"] in
Clang_ast_t.ConditionalOperator (stmt_info, stmt_list_cond, expr_info) Clang_ast_t.ConditionalOperator (stmt_info, stmt_list_cond, expr_info)
let create_assume_not_null_call decl_info var_name var_type = let create_assume_not_null_call decl_info var_name var_type =
@ -617,7 +617,7 @@ let create_assume_not_null_call decl_info var_name var_type =
} in } in
let cast_info_call = { Clang_ast_t.cei_cast_kind = `LValueToRValue; cei_base_path = [] } in let cast_info_call = { Clang_ast_t.cei_cast_kind = `LValueToRValue; cei_base_path = [] } in
let decl_ref_exp_cast = Clang_ast_t.ImplicitCastExpr (stmt_info, [var_decl_ref], expr_info, cast_info_call) in let decl_ref_exp_cast = Clang_ast_t.ImplicitCastExpr (stmt_info, [var_decl_ref], expr_info, cast_info_call) in
let null_expr = create_integer_literal stmt_info "0" in let null_expr = create_integer_literal "0" in
let bin_op_expr_info = make_general_expr_info create_BOOL_type `RValue `Ordinary in let bin_op_expr_info = make_general_expr_info create_BOOL_type `RValue `Ordinary in
let bin_op = make_binary_stmt decl_ref_exp_cast null_expr stmt_info bin_op_expr_info boi in let bin_op = make_binary_stmt decl_ref_exp_cast null_expr stmt_info bin_op_expr_info boi in
let parameters = [bin_op] in let parameters = [bin_op] in

5
infer/src/clang/ast_expressions.mli
Unescape View File

@ -43,8 +43,7 @@ val create_struct_type : string -> type_ptr
val create_pointer_type : type_ptr -> type_ptr val create_pointer_type : type_ptr -> type_ptr
val make_objc_ivar_decl : decl_info -> type_ptr -> obj_c_property_impl_decl_info -> val make_objc_ivar_decl : decl_info -> type_ptr -> named_decl_info -> decl
named_decl_info -> decl
val make_stmt_info : decl_info -> stmt_info val make_stmt_info : decl_info -> stmt_info
@ -72,7 +71,7 @@ val make_obj_c_message_expr_info_class : string -> string -> pointer option ->
val make_obj_c_message_expr_info_instance : string -> obj_c_message_expr_info val make_obj_c_message_expr_info_instance : string -> obj_c_message_expr_info
val translate_dispatch_function : string -> stmt_info -> stmt list -> expr_info -> int -> stmt * type_ptr val translate_dispatch_function : string -> stmt_info -> stmt list -> int -> stmt * type_ptr
val translate_block_enumerate : string -> stmt_info -> stmt list -> expr_info -> val translate_block_enumerate : string -> stmt_info -> stmt list -> expr_info ->
stmt * (string * Clang_ast_t.pointer * type_ptr) list stmt * (string * Clang_ast_t.pointer * type_ptr) list

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

@ -18,7 +18,7 @@ open CFrontend_utils
(* The difference is when the lvalue is a __strong or __autoreleasing. In those*) (* The difference is when the lvalue is a __strong or __autoreleasing. In those*)
(* case we need to add proper retain/release.*) (* case we need to add proper retain/release.*)
(* See document: "Objective-C Automatic Reference Counting" describing the semantics *) (* See document: "Objective-C Automatic Reference Counting" describing the semantics *)
let assignment_arc_mode context e1 typ e2 loc rhs_owning_method is_e1_decl = let assignment_arc_mode e1 typ e2 loc rhs_owning_method is_e1_decl =
let assign = Sil.Set (e1, typ, e2, loc) in let assign = Sil.Set (e1, typ, e2, loc) in
let retain_pname = SymExec.ModelBuiltins.__objc_retain in let retain_pname = SymExec.ModelBuiltins.__objc_retain in
let release_pname = SymExec.ModelBuiltins.__objc_release in let release_pname = SymExec.ModelBuiltins.__objc_release in
@ -27,7 +27,7 @@ let assignment_arc_mode context e1 typ e2 loc rhs_owning_method is_e1_decl =
let bi_retain = Sil.Const (Sil.Cfun procname) in let bi_retain = Sil.Const (Sil.Cfun procname) in
Sil.Call([], bi_retain, [(e, t)], loc, Sil.cf_default) in Sil.Call([], bi_retain, [(e, t)], loc, Sil.cf_default) in
match typ with match typ with
| Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && not is_e1_decl -> | Sil.Tptr (_, Sil.Pk_pointer) when not rhs_owning_method && not is_e1_decl ->
(* for __strong e1 = e2 the semantics is*) (* for __strong e1 = e2 the semantics is*)
(* retain(e2); tmp=e1; e1=e2; release(tmp); *) (* retain(e2); tmp=e1; e1=e2; release(tmp); *)
let retain = mk_call retain_pname e2 typ in let retain = mk_call retain_pname e2 typ in
@ -35,15 +35,15 @@ let assignment_arc_mode context e1 typ e2 loc rhs_owning_method is_e1_decl =
let tmp_assign = Sil.Letderef(id, e1, typ, loc) in let tmp_assign = Sil.Letderef(id, e1, typ, loc) in
let release = mk_call release_pname (Sil.Var id) typ in let release = mk_call release_pname (Sil.Var id) typ in
(e1,[retain; tmp_assign; assign; release ], [id]) (e1,[retain; tmp_assign; assign; release ], [id])
| Sil.Tptr (t, Sil.Pk_pointer) when not rhs_owning_method && is_e1_decl -> | Sil.Tptr (_, Sil.Pk_pointer) when not rhs_owning_method && is_e1_decl ->
(* for A __strong *e1 = e2 the semantics is*) (* for A __strong *e1 = e2 the semantics is*)
(* retain(e2); e1=e2; *) (* retain(e2); e1=e2; *)
let retain = mk_call retain_pname e2 typ in let retain = mk_call retain_pname e2 typ in
(e1,[retain; assign ], []) (e1,[retain; assign ], [])
| Sil.Tptr (t, Sil.Pk_objc_weak) | Sil.Tptr (_, Sil.Pk_objc_weak)
| Sil.Tptr (t, Sil.Pk_objc_unsafe_unretained) -> | Sil.Tptr (_, Sil.Pk_objc_unsafe_unretained) ->
(e1, [assign],[]) (e1, [assign],[])
| Sil.Tptr (t, Sil.Pk_objc_autoreleasing) -> | Sil.Tptr (_, Sil.Pk_objc_autoreleasing) ->
(* for __autoreleasing e1 = e2 the semantics is*) (* for __autoreleasing e1 = e2 the semantics is*)
(* retain(e2); autorelease(e2); e1=e2; *) (* retain(e2); autorelease(e2); e1=e2; *)
let retain = mk_call retain_pname e2 typ in let retain = mk_call retain_pname e2 typ in
@ -89,7 +89,7 @@ let compound_assignment_binary_operation_instruction boi e1 typ e2 loc =
| `XorAssign -> | `XorAssign ->
let e1_xor_e2 = Sil.BinOp(Sil.BXor, Sil.Var id, e2) in let e1_xor_e2 = Sil.BinOp(Sil.BXor, Sil.Var id, e2) in
(e1, [Sil.Set (e1, typ, e1_xor_e2, loc)]) (e1, [Sil.Set (e1, typ, e1_xor_e2, loc)])
| bok -> assert false in | _ -> assert false in
(e_res, instr1:: instr_op, [id]) (e_res, instr1:: instr_op, [id])
(* Returns a pair ([binary_expression], instructions). "binary_expression" *) (* Returns a pair ([binary_expression], instructions). "binary_expression" *)
@ -119,7 +119,7 @@ let binary_operation_instruction context boi e1 typ e2 loc rhs_owning_method =
| `LOr -> (binop_exp (Sil.LOr), [], []) | `LOr -> (binop_exp (Sil.LOr), [], [])
| `Assign -> | `Assign ->
if !Config.arc_mode && ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv typ then if !Config.arc_mode && ObjcInterface_decl.is_pointer_to_objc_class context.CContext.tenv typ then
assignment_arc_mode context e1 typ e2 loc rhs_owning_method false assignment_arc_mode e1 typ e2 loc rhs_owning_method false
else else
(e1, [Sil.Set (e1, typ, e2, loc)], []) (e1, [Sil.Set (e1, typ, e2, loc)], [])
| `Comma -> (e2, [], []) (* C99 6.5.17-2 *) | `Comma -> (e2, [], []) (* C99 6.5.17-2 *)

2
infer/src/clang/cArithmetic_trans.mli
Unescape View File

@ -20,7 +20,7 @@ val unary_operation_instruction :
Ident.t list * Sil.exp * Sil.instr list Ident.t list * Sil.exp * Sil.instr list
val assignment_arc_mode : val assignment_arc_mode :
CContext.t -> Sil.exp -> Sil.typ -> Sil.exp -> Location.t -> bool -> bool -> Sil.exp -> Sil.typ -> Sil.exp -> Location.t -> bool -> bool ->
Sil.exp * Sil.instr list * Ident.t list Sil.exp * Sil.instr list * Ident.t list
val sil_const_plus_one : Sil.exp -> Sil.exp val sil_const_plus_one : Sil.exp -> Sil.exp

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

@ -75,7 +75,7 @@ let rec get_curr_class context =
let get_curr_class_name curr_class = let get_curr_class_name curr_class =
match curr_class with match curr_class with
| ContextCls (name, _, _) -> name | ContextCls (name, _, _) -> name
| ContextCategory (name, cls) -> cls | ContextCategory (_, cls) -> cls
| ContextProtocol name -> name | ContextProtocol name -> name
| ContextNoCls -> assert false | ContextNoCls -> assert false
@ -127,12 +127,12 @@ let create_curr_class tenv class_name ck =
let add_block_static_var context block_name static_var_typ = let add_block_static_var context block_name static_var_typ =
match context.outer_context, static_var_typ with match context.outer_context, static_var_typ with
| Some outer_context, (static_var, typ) when Sil.pvar_is_global static_var -> | Some outer_context, (static_var, _) when Sil.pvar_is_global static_var ->
(let new_static_vars, duplicate = (let new_static_vars, duplicate =
try try
let static_vars = Procname.Map.find block_name outer_context.blocks_static_vars in let static_vars = Procname.Map.find block_name outer_context.blocks_static_vars in
if IList.mem ( if IList.mem (
fun (var1, typ1) (var2, typ2) -> Sil.pvar_equal var1 var2 fun (var1, _) (var2, _) -> Sil.pvar_equal var1 var2
) static_var_typ static_vars then ) static_var_typ static_vars then
static_vars, true static_vars, true
else else

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

@ -42,7 +42,7 @@ let enum_decl decl =
ignore (add_enum_constant_to_map_if_needed decl_pointer None) ignore (add_enum_constant_to_map_if_needed decl_pointer None)
| _ -> () in | _ -> () in
match decl with match decl with
| EnumDecl (decl_info, _, _, type_ptr, decl_list, _, _) -> | EnumDecl (_, _, _, type_ptr, decl_list, _, _) ->
add_enum_constants_to_map (IList.rev decl_list); add_enum_constants_to_map (IList.rev decl_list);
let sil_type = Sil.Tint Sil.IInt in let sil_type = Sil.Tint Sil.IInt in
Ast_utils.update_sil_types_map type_ptr sil_type; Ast_utils.update_sil_types_map type_ptr sil_type;

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

@ -60,7 +60,7 @@ let rec get_fields type_ptr_to_sil_type tenv curr_class decl_list =
General_utils.append_no_duplicates_fields [field_tuple] fields in General_utils.append_no_duplicates_fields [field_tuple] fields in
match decl_list with match decl_list with
| [] -> [] | [] -> []
| ObjCPropertyDecl (_, named_decl_info, obj_c_property_decl_info) :: decl_list' -> | ObjCPropertyDecl (_, _, obj_c_property_decl_info) :: decl_list' ->
(let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in (let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in
match Ast_utils.get_decl_opt_with_decl_ref ivar_decl_ref with match Ast_utils.get_decl_opt_with_decl_ref ivar_decl_ref with
| Some (ObjCIvarDecl (_, name_info, type_ptr, _, _)) -> | Some (ObjCIvarDecl (_, name_info, type_ptr, _, _)) ->
@ -69,7 +69,7 @@ let rec get_fields type_ptr_to_sil_type tenv curr_class decl_list =
| _ -> get_fields type_ptr_to_sil_type tenv curr_class decl_list') | _ -> get_fields type_ptr_to_sil_type tenv curr_class decl_list')
| ObjCIvarDecl (_, name_info, type_ptr, _, _) :: decl_list' -> | ObjCIvarDecl (_, name_info, type_ptr, _, _) :: decl_list' ->
add_field name_info type_ptr [] decl_list' add_field name_info type_ptr [] decl_list'
| decl :: decl_list' -> | _ :: decl_list' ->
get_fields type_ptr_to_sil_type tenv curr_class decl_list' get_fields type_ptr_to_sil_type tenv curr_class decl_list'
(* Add potential extra fields defined only in the implementation of the class *) (* Add potential extra fields defined only in the implementation of the class *)
@ -110,10 +110,10 @@ let is_ivar_atomic ivar fields =
let get_property_corresponding_ivar tenv type_ptr_to_sil_type class_name property_decl = let get_property_corresponding_ivar tenv type_ptr_to_sil_type class_name property_decl =
let open Clang_ast_t in let open Clang_ast_t in
match property_decl with match property_decl with
| ObjCPropertyDecl (decl_info, named_decl_info, obj_c_property_decl_info) -> | ObjCPropertyDecl (_, named_decl_info, obj_c_property_decl_info) ->
(let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in (let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in
match Ast_utils.get_decl_opt_with_decl_ref ivar_decl_ref with match Ast_utils.get_decl_opt_with_decl_ref ivar_decl_ref with
| Some ObjCIvarDecl (decl_info, named_decl_info, type_ptr, _, _) -> | Some ObjCIvarDecl (_, named_decl_info, _, _, _) ->
General_utils.mk_class_field_name named_decl_info General_utils.mk_class_field_name named_decl_info
| _ -> (* Ivar is not known, so add a default one to the tenv *) | _ -> (* Ivar is not known, so add a default one to the tenv *)
let type_ptr = obj_c_property_decl_info.Clang_ast_t.opdi_type_ptr in let type_ptr = obj_c_property_decl_info.Clang_ast_t.opdi_type_ptr in

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

@ -29,29 +29,29 @@ let rec translate_one_declaration tenv cg cfg parent_dec dec =
let should_translate_decl = CLocation.should_translate_lib source_range in let should_translate_decl = CLocation.should_translate_lib source_range in
(if should_translate_decl then (if should_translate_decl then
match dec with match dec with
| FunctionDecl(di, name_info, tp, fdecl_info) -> | FunctionDecl(_, _, _, _) ->
CMethod_declImpl.function_decl tenv cfg cg dec None CMethod_declImpl.function_decl tenv cfg cg dec None
| ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, oi_decl_info) -> | ObjCInterfaceDecl(_, name_info, decl_list, _, oi_decl_info) ->
let name = Ast_utils.get_qualified_name name_info in let name = Ast_utils.get_qualified_name name_info in
let curr_class = ObjcInterface_decl.get_curr_class name oi_decl_info in let curr_class = ObjcInterface_decl.get_curr_class name oi_decl_info in
ignore ignore
(ObjcInterface_decl.interface_declaration CTypes_decl.type_ptr_to_sil_type tenv dec); (ObjcInterface_decl.interface_declaration CTypes_decl.type_ptr_to_sil_type tenv dec);
CMethod_declImpl.process_methods tenv cg cfg curr_class decl_list CMethod_declImpl.process_methods tenv cg cfg curr_class decl_list
| ObjCProtocolDecl(decl_info, name_info, decl_list, decl_context_info, _) -> | ObjCProtocolDecl(_, name_info, decl_list, _, _) ->
let name = Ast_utils.get_qualified_name name_info in let name = Ast_utils.get_qualified_name name_info in
let curr_class = CContext.ContextProtocol name in let curr_class = CContext.ContextProtocol name in
ignore (ObjcProtocol_decl.protocol_decl CTypes_decl.type_ptr_to_sil_type tenv dec); ignore (ObjcProtocol_decl.protocol_decl CTypes_decl.type_ptr_to_sil_type tenv dec);
CMethod_declImpl.process_methods tenv cg cfg curr_class decl_list CMethod_declImpl.process_methods tenv cg cfg curr_class decl_list
| ObjCCategoryDecl(decl_info, name_info, decl_list, decl_context_info, ocdi) -> | ObjCCategoryDecl(_, name_info, decl_list, _, ocdi) ->
let name = Ast_utils.get_qualified_name name_info in let name = Ast_utils.get_qualified_name name_info in
let curr_class = ObjcCategory_decl.get_curr_class_from_category_decl name ocdi in let curr_class = ObjcCategory_decl.get_curr_class_from_category_decl name ocdi in
ignore (ObjcCategory_decl.category_decl CTypes_decl.type_ptr_to_sil_type tenv dec); ignore (ObjcCategory_decl.category_decl CTypes_decl.type_ptr_to_sil_type tenv dec);
CMethod_declImpl.process_methods tenv cg cfg curr_class decl_list CMethod_declImpl.process_methods tenv cg cfg curr_class decl_list
| ObjCCategoryImplDecl(decl_info, name_info, decl_list, decl_context_info, ocidi) -> | ObjCCategoryImplDecl(_, name_info, decl_list, _, ocidi) ->
let name = Ast_utils.get_qualified_name name_info in let name = Ast_utils.get_qualified_name name_info in
let curr_class = ObjcCategory_decl.get_curr_class_from_category_impl name ocidi in let curr_class = ObjcCategory_decl.get_curr_class_from_category_impl name ocidi in
ignore (ObjcCategory_decl.category_impl_decl CTypes_decl.type_ptr_to_sil_type tenv dec); ignore (ObjcCategory_decl.category_impl_decl CTypes_decl.type_ptr_to_sil_type tenv dec);
@ -63,7 +63,7 @@ let rec translate_one_declaration tenv cg cfg parent_dec dec =
CFrontend_errors.check_for_property_errors cfg cg tenv name decls CFrontend_errors.check_for_property_errors cfg cg tenv name decls
| _ -> ()) | _ -> ())
| ObjCImplementationDecl(decl_info, name_info, decl_list, decl_context_info, idi) -> | ObjCImplementationDecl(_, _, decl_list, _, idi) ->
let curr_class = ObjcInterface_decl.get_curr_class_impl idi in let curr_class = ObjcInterface_decl.get_curr_class_impl idi in
let type_ptr_to_sil_type = CTypes_decl.type_ptr_to_sil_type in let type_ptr_to_sil_type = CTypes_decl.type_ptr_to_sil_type in
ignore (ObjcInterface_decl.interface_impl_declaration type_ptr_to_sil_type tenv dec); ignore (ObjcInterface_decl.interface_impl_declaration type_ptr_to_sil_type tenv dec);
@ -75,10 +75,10 @@ let rec translate_one_declaration tenv cg cfg parent_dec dec =
CFrontend_errors.check_for_property_errors cfg cg tenv name decls CFrontend_errors.check_for_property_errors cfg cg tenv name decls
| _ -> ()) | _ -> ())
| CXXMethodDecl (decl_info, name_info, type_ptr, function_decl_info, _) | CXXMethodDecl (decl_info, _, _, _, _)
| CXXConstructorDecl (decl_info, name_info, type_ptr, function_decl_info, _) | CXXConstructorDecl (decl_info, _, _, _, _)
| CXXConversionDecl (decl_info, name_info, type_ptr, function_decl_info, _) | CXXConversionDecl (decl_info, _, _, _, _)
| CXXDestructorDecl (decl_info, name_info, type_ptr, function_decl_info, _) -> | CXXDestructorDecl (decl_info, _, _, _, _) ->
(* di_parent_pointer has pointer to lexical context such as class.*) (* di_parent_pointer has pointer to lexical context such as class.*)
(* If it's not defined, then it's the same as parent in AST *) (* If it's not defined, then it's the same as parent in AST *)
let class_decl = match decl_info.Clang_ast_t.di_parent_pointer with let class_decl = match decl_info.Clang_ast_t.di_parent_pointer with
@ -93,7 +93,7 @@ let rec translate_one_declaration tenv cg cfg parent_dec dec =
CMethod_declImpl.process_methods tenv cg cfg curr_class [dec] CMethod_declImpl.process_methods tenv cg cfg curr_class [dec]
| Some dec -> Printing.log_stats "Methods of %s skipped\n" (Ast_utils.string_of_decl dec) | Some dec -> Printing.log_stats "Methods of %s skipped\n" (Ast_utils.string_of_decl dec)
| None -> ()) | None -> ())
| dec -> ()); | _ -> ());
match dec with match dec with
(* Currently C/C++ record decl treated in the same way *) (* Currently C/C++ record decl treated in the same way *)
| ClassTemplateSpecializationDecl (decl_info, _, _, _, decl_list, _, _, _) | ClassTemplateSpecializationDecl (decl_info, _, _, _, decl_list, _, _, _)
@ -109,19 +109,19 @@ let rec translate_one_declaration tenv cg cfg parent_dec dec =
ignore (CTypes_decl.add_types_from_decl_to_tenv tenv dec); ignore (CTypes_decl.add_types_from_decl_to_tenv tenv dec);
IList.iter (translate_one_declaration tenv cg cfg dec) method_decls IList.iter (translate_one_declaration tenv cg cfg dec) method_decls
| EnumDecl _ -> ignore (CEnum_decl.enum_decl dec) | EnumDecl _ -> ignore (CEnum_decl.enum_decl dec)
| LinkageSpecDecl (decl_info, decl_list, decl_context_info) -> | LinkageSpecDecl (_, decl_list, _) ->
Printing.log_out "ADDING: LinkageSpecDecl decl list\n"; Printing.log_out "ADDING: LinkageSpecDecl decl list\n";
IList.iter (translate_one_declaration tenv cg cfg dec) decl_list IList.iter (translate_one_declaration tenv cg cfg dec) decl_list
| NamespaceDecl (decl_info, name_info, decl_list, decl_context_info, _) -> | NamespaceDecl (_, _, decl_list, _, _) ->
IList.iter (translate_one_declaration tenv cg cfg dec) decl_list IList.iter (translate_one_declaration tenv cg cfg dec) decl_list
| ClassTemplateDecl (decl_info, named_decl_info, template_decl_info) | ClassTemplateDecl (_, _, template_decl_info)
| FunctionTemplateDecl (decl_info, named_decl_info, template_decl_info) -> | FunctionTemplateDecl (_, _, template_decl_info) ->
let decl_list = template_decl_info.Clang_ast_t.tdi_specializations in let decl_list = template_decl_info.Clang_ast_t.tdi_specializations in
IList.iter (translate_one_declaration tenv cg cfg dec) decl_list IList.iter (translate_one_declaration tenv cg cfg dec) decl_list
| dec -> () | _ -> ()
(* Translates a file by translating the ast into a cfg. *) (* Translates a file by translating the ast into a cfg. *)
let compute_icfg tenv source_file ast = let compute_icfg tenv ast =
match ast with match ast with
| Clang_ast_t.TranslationUnitDecl(_, decl_list, _, _) -> | Clang_ast_t.TranslationUnitDecl(_, decl_list, _, _) ->
CFrontend_config.global_translation_unit_decls := decl_list; CFrontend_config.global_translation_unit_decls := decl_list;
@ -148,7 +148,7 @@ let do_source_file source_file ast =
Config.nLOC := FileLOC.file_get_loc (DB.source_file_to_string source_file); Config.nLOC := FileLOC.file_get_loc (DB.source_file_to_string source_file);
Printing.log_out "\n Start building call/cfg graph for '%s'....\n" Printing.log_out "\n Start building call/cfg graph for '%s'....\n"
(DB.source_file_to_string source_file); (DB.source_file_to_string source_file);
let call_graph, cfg = compute_icfg tenv (DB.source_file_to_string source_file) ast in let call_graph, cfg = compute_icfg tenv ast in
Printing.log_out "\n End building call/cfg graph for '%s'.\n" Printing.log_out "\n End building call/cfg graph for '%s'.\n"
(DB.source_file_to_string source_file); (DB.source_file_to_string source_file);
(* This part below is a boilerplate in every frontends. *) (* This part below is a boilerplate in every frontends. *)

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

@ -141,7 +141,7 @@ struct
| _ -> lstmt) | _ -> lstmt)
(* given that this has not been translated, looking up for variables *) (* given that this has not been translated, looking up for variables *)
(* inside leads to inconsistencies *) (* inside leads to inconsistencies *)
| ObjCAtCatchStmt (stmt_info, stmt_list, obj_c_message_expr_kind) -> | ObjCAtCatchStmt _ ->
[] []
| _ -> snd (Clang_ast_proj.get_stmt_tuple stmt) | _ -> snd (Clang_ast_proj.get_stmt_tuple stmt)
@ -158,7 +158,7 @@ struct
let get_unqualified_name name_info = let get_unqualified_name name_info =
let name = match name_info.Clang_ast_t.ni_qual_name with let name = match name_info.Clang_ast_t.ni_qual_name with
| name :: quals -> name | name :: _ -> name
| [] -> name_info.Clang_ast_t.ni_name in | [] -> name_info.Clang_ast_t.ni_name in
fold_qual_name [name] fold_qual_name [name]
@ -291,7 +291,7 @@ struct
let update_enum_map enum_constant_pointer sil_exp = let update_enum_map enum_constant_pointer sil_exp =
let open Clang_ast_main in let open Clang_ast_main in
let (predecessor_pointer_opt, sil_exp_opt) = let (predecessor_pointer_opt, _) =
try PointerMap.find enum_constant_pointer !CFrontend_config.enum_map try PointerMap.find enum_constant_pointer !CFrontend_config.enum_map
with Not_found -> assert false in with Not_found -> assert false in
let enum_map_value = (predecessor_pointer_opt, Some sil_exp) in let enum_map_value = (predecessor_pointer_opt, Some sil_exp) in
@ -334,7 +334,7 @@ struct
let typ = match typ_opt with Some t -> t | _ -> assert false in let typ = match typ_opt with Some t -> t | _ -> assert false in
(* it needs extending to handle objC types *) (* it needs extending to handle objC types *)
match typ with match typ with
| Clang_ast_t.RecordType (ti, decl_ptr) -> get_decl decl_ptr | Clang_ast_t.RecordType (_, decl_ptr) -> get_decl decl_ptr
| _ -> None | _ -> None
(*TODO take the attributes into account too. To be done after we get the attribute's arguments. *) (*TODO take the attributes into account too. To be done after we get the attribute's arguments. *)
@ -523,7 +523,7 @@ struct
if n < i then acc else aux (n -1) (n :: acc) if n < i then acc else aux (n -1) (n :: acc)
in aux j [] ;; in aux j [] ;;
let replicate n el = IList.map (fun i -> el) (list_range 0 (n -1)) let replicate n el = IList.map (fun _ -> el) (list_range 0 (n -1))
let mk_class_field_name field_qual_name = let mk_class_field_name field_qual_name =
let field_name = field_qual_name.Clang_ast_t.ni_name in let field_name = field_qual_name.Clang_ast_t.ni_name in

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

@ -72,7 +72,7 @@ let arg_desc =
"Toot directory of the project" "Toot directory of the project"
; ;
"-fobjc-arc", "-fobjc-arc",
Arg.Unit (fun s -> Config.arc_mode := true), Arg.Unit (fun _ -> Config.arc_mode := true),
None, None,
"Translate with Objective-C Automatic Reference Counting (ARC)" "Translate with Objective-C Automatic Reference Counting (ARC)"
; ;
@ -92,7 +92,7 @@ let print_usage_exit () =
exit(1) exit(1)
let () = let () =
Utils.Arg.parse arg_desc (fun arg -> ()) usage Utils.Arg.parse arg_desc (fun _ -> ()) usage
(* This function reads the json file in fname, validates it, and encoded in the AST data structure*) (* This function reads the json file in fname, validates it, and encoded in the AST data structure*)
(* defined in Clang_ast_t. *) (* defined in Clang_ast_t. *)

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

@ -30,7 +30,7 @@ struct
(* Translates the method/function's body into nodes of the cfg. *) (* Translates the method/function's body into nodes of the cfg. *)
let add_method tenv cg cfg class_decl_opt procname body has_return_param is_objc_method let add_method tenv cg cfg class_decl_opt procname body has_return_param is_objc_method
captured_vars outer_context_opt extra_instrs = outer_context_opt extra_instrs =
Printing.log_out Printing.log_out
"\n\n>>---------- ADDING METHOD: '%s' ---------<<\n@." (Procname.to_string procname); "\n\n>>---------- ADDING METHOD: '%s' ---------<<\n@." (Procname.to_string procname);
@ -77,7 +77,7 @@ struct
let return_param_typ_opt = CMethod_signature.ms_get_return_param_typ ms in let return_param_typ_opt = CMethod_signature.ms_get_return_param_typ ms in
if CMethod_trans.create_local_procdesc cfg tenv ms [body] captured_vars false then if CMethod_trans.create_local_procdesc cfg tenv ms [body] captured_vars false then
add_method tenv cg cfg CContext.ContextNoCls procname body return_param_typ_opt false add_method tenv cg cfg CContext.ContextNoCls procname body return_param_typ_opt false
captured_vars outer_context_opt extra_instrs outer_context_opt extra_instrs
| None -> () | None -> ()
let process_method_decl tenv cg cfg curr_class meth_decl ~is_objc = let process_method_decl tenv cg cfg curr_class meth_decl ~is_objc =
@ -90,7 +90,7 @@ struct
let is_objc_inst_method = is_instance && is_objc in let is_objc_inst_method = is_instance && is_objc in
let return_param_typ_opt = CMethod_signature.ms_get_return_param_typ ms in let return_param_typ_opt = CMethod_signature.ms_get_return_param_typ ms in
if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_objc_inst_method then if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_objc_inst_method then
add_method tenv cg cfg curr_class procname body return_param_typ_opt is_objc [] add_method tenv cg cfg curr_class procname body return_param_typ_opt is_objc
None extra_instrs None extra_instrs
| None -> () | None -> ()

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

@ -101,7 +101,7 @@ let get_language function_method_decl_info =
let get_parameters tenv function_method_decl_info = let get_parameters tenv function_method_decl_info =
let par_to_ms_par par = let par_to_ms_par par =
match par with match par with
| Clang_ast_t.ParmVarDecl (decl_info, name_info, type_ptr, var_decl_info) -> | Clang_ast_t.ParmVarDecl (_, name_info, type_ptr, var_decl_info) ->
let name = General_utils.get_var_name_string name_info var_decl_info in let name = General_utils.get_var_name_string name_info var_decl_info in
(name, type_ptr) (name, type_ptr)
| _ -> assert false in | _ -> assert false in
@ -117,7 +117,7 @@ let get_return_type tenv function_method_decl_info =
Ast_expressions.create_void_type, Some (Sil.Tptr (return_typ, Sil.Pk_pointer)) Ast_expressions.create_void_type, Some (Sil.Tptr (return_typ, Sil.Pk_pointer))
else return_type_ptr, None else return_type_ptr, None
let build_method_signature tenv decl_info procname function_method_decl_info is_anonym_block let build_method_signature tenv decl_info procname function_method_decl_info
parent_pointer pointer_to_property_opt = parent_pointer pointer_to_property_opt =
let source_range = decl_info.Clang_ast_t.di_source_range in let source_range = decl_info.Clang_ast_t.di_source_range in
let tp, return_param_type_opt = get_return_type tenv function_method_decl_info in let tp, return_param_type_opt = get_return_type tenv function_method_decl_info in
@ -131,7 +131,7 @@ let build_method_signature tenv decl_info procname function_method_decl_info is_
let get_assume_not_null_calls param_decls = let get_assume_not_null_calls param_decls =
let do_one_param decl = match decl with let do_one_param decl = match decl with
| Clang_ast_t.ParmVarDecl (decl_info, name, tp, var_decl_info) | Clang_ast_t.ParmVarDecl (decl_info, name, tp, _)
when CFrontend_utils.Ast_utils.is_type_nonnull tp -> when CFrontend_utils.Ast_utils.is_type_nonnull tp ->
let assume_call = Ast_expressions.create_assume_not_null_call decl_info name tp in let assume_call = Ast_expressions.create_assume_not_null_call decl_info name tp in
[(`ClangStmt assume_call)] [(`ClangStmt assume_call)]
@ -151,7 +151,7 @@ let method_signature_of_decl tenv meth_decl block_data_opt =
let func_decl = Func_decl_info (fdi, tp, language) in let func_decl = Func_decl_info (fdi, tp, language) in
let function_info = Some (decl_info, fdi) in let function_info = Some (decl_info, fdi) in
let procname = General_utils.mk_procname_from_function name function_info tp language in let procname = General_utils.mk_procname_from_function name function_info tp language in
let ms = build_method_signature tenv decl_info procname func_decl false None None in let ms = build_method_signature tenv decl_info procname func_decl None None in
let extra_instrs = get_assume_not_null_calls fdi.Clang_ast_t.fdi_parameters in let extra_instrs = get_assume_not_null_calls fdi.Clang_ast_t.fdi_parameters in
ms, fdi.Clang_ast_t.fdi_body, extra_instrs ms, fdi.Clang_ast_t.fdi_body, extra_instrs
| CXXMethodDecl (decl_info, name_info, tp, fdi, mdi), _ | CXXMethodDecl (decl_info, name_info, tp, fdi, mdi), _
@ -163,8 +163,7 @@ let method_signature_of_decl tenv meth_decl block_data_opt =
let procname = General_utils.mk_procname_from_cpp_method class_name method_name tp in let procname = General_utils.mk_procname_from_cpp_method class_name method_name tp in
let method_decl = Cpp_Meth_decl_info (fdi, mdi, class_name, tp) in let method_decl = Cpp_Meth_decl_info (fdi, mdi, class_name, tp) in
let parent_pointer = decl_info.Clang_ast_t.di_parent_pointer in let parent_pointer = decl_info.Clang_ast_t.di_parent_pointer in
let ms = build_method_signature tenv decl_info procname method_decl false parent_pointer let ms = build_method_signature tenv decl_info procname method_decl parent_pointer None in
None in
let non_null_instrs = get_assume_not_null_calls fdi.Clang_ast_t.fdi_parameters in let non_null_instrs = get_assume_not_null_calls fdi.Clang_ast_t.fdi_parameters in
let init_list_instrs = get_init_list_instrs mdi in (* it will be empty for methods *) let init_list_instrs = get_init_list_instrs mdi in (* it will be empty for methods *)
ms, fdi.Clang_ast_t.fdi_body, (init_list_instrs @ non_null_instrs) ms, fdi.Clang_ast_t.fdi_body, (init_list_instrs @ non_null_instrs)
@ -180,13 +179,13 @@ let method_signature_of_decl tenv meth_decl block_data_opt =
match mdi.Clang_ast_t.omdi_property_decl with match mdi.Clang_ast_t.omdi_property_decl with
| Some decl_ref -> Some decl_ref.Clang_ast_t.dr_decl_pointer | Some decl_ref -> Some decl_ref.Clang_ast_t.dr_decl_pointer
| None -> None in | None -> None in
let ms = build_method_signature tenv decl_info procname method_decl false let ms = build_method_signature tenv decl_info procname method_decl
parent_pointer pointer_to_property_opt in parent_pointer pointer_to_property_opt in
let extra_instrs = get_assume_not_null_calls mdi.omdi_parameters in let extra_instrs = get_assume_not_null_calls mdi.omdi_parameters in
ms, mdi.omdi_body, extra_instrs ms, mdi.omdi_body, extra_instrs
| BlockDecl (decl_info, bdi), Some (outer_context, tp, procname, _) -> | BlockDecl (decl_info, bdi), Some (outer_context, tp, procname, _) ->
let func_decl = Block_decl_info (bdi, tp, outer_context) in let func_decl = Block_decl_info (bdi, tp, outer_context) in
let ms = build_method_signature tenv decl_info procname func_decl true None None in let ms = build_method_signature tenv decl_info procname func_decl None None in
let extra_instrs = get_assume_not_null_calls bdi.bdi_parameters in let extra_instrs = get_assume_not_null_calls bdi.bdi_parameters in
ms, bdi.bdi_body, extra_instrs ms, bdi.bdi_body, extra_instrs
| _ -> raise Invalid_declaration | _ -> raise Invalid_declaration
@ -257,8 +256,8 @@ let get_class_name_method_call_from_receiver_kind context obj_c_message_expr_inf
(CTypes.classname_of_type sil_type) (CTypes.classname_of_type sil_type)
| `Instance -> | `Instance ->
(match act_params with (match act_params with
| (instance_obj, Sil.Tptr(t, _)):: _ | (_, Sil.Tptr(t, _)):: _
| (instance_obj, t):: _ -> CTypes.classname_of_type t | (_, t):: _ -> CTypes.classname_of_type t
| _ -> assert false) | _ -> assert false)
| `SuperInstance ->get_superclass_curr_class_objc context | `SuperInstance ->get_superclass_curr_class_objc context
| `SuperClass -> get_superclass_curr_class_objc context | `SuperClass -> get_superclass_curr_class_objc context
@ -276,7 +275,7 @@ let get_objc_property_accessor tenv ms =
let open Clang_ast_t in let open Clang_ast_t in
let pointer_to_property_opt = CMethod_signature.ms_get_pointer_to_property_opt ms in let pointer_to_property_opt = CMethod_signature.ms_get_pointer_to_property_opt ms in
match Ast_utils.get_decl_opt pointer_to_property_opt with match Ast_utils.get_decl_opt pointer_to_property_opt with
| Some (ObjCPropertyDecl (decl_info, named_decl_info, obj_c_property_decl_info) as d) -> | Some (ObjCPropertyDecl _ as d) ->
let class_name = Procname.c_get_class (CMethod_signature.ms_get_name ms) in let class_name = Procname.c_get_class (CMethod_signature.ms_get_name ms) in
let field_name = CField_decl.get_property_corresponding_ivar tenv let field_name = CField_decl.get_property_corresponding_ivar tenv
CTypes_decl.type_ptr_to_sil_type class_name d in CTypes_decl.type_ptr_to_sil_type class_name d in

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

@ -114,7 +114,7 @@ struct
let fields = IList.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 let fields = CFrontend_utils.General_utils.sort_fields fields in
Printing.log_out "Block %s field:\n" block_name; Printing.log_out "Block %s field:\n" block_name;
IList.iter (fun (fn, ft, _) -> IList.iter (fun (fn, _, _) ->
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
let mblock = Mangled.from_string block_name in let mblock = Mangled.from_string block_name in
let block_type = Sil.Tstruct let block_type = Sil.Tstruct
@ -130,7 +130,7 @@ struct
Sil.tenv_add tenv block_name block_type; Sil.tenv_add tenv block_name block_type;
let trans_res = CTrans_utils.alloc_trans trans_state loc (Ast_expressions.dummy_stmt_info ()) block_type true in let trans_res = CTrans_utils.alloc_trans trans_state loc (Ast_expressions.dummy_stmt_info ()) block_type true in
let id_block = match trans_res.exps with let id_block = match trans_res.exps with
| [(Sil.Var id, t)] -> id | [(Sil.Var id, _)] -> id
| _ -> assert false in | _ -> assert false in
let block_var = Sil.mk_pvar mblock procname in let block_var = Sil.mk_pvar mblock procname in
let declare_block_local = let declare_block_local =
@ -241,7 +241,7 @@ struct
f trans_state e f trans_state e
else f { trans_state with priority = Free } e else f { trans_state with priority = Free } e
let mk_temp_sil_var tenv procdesc var_name_prefix = let mk_temp_sil_var procdesc var_name_prefix =
let procname = Cfg.Procdesc.get_proc_name procdesc in let procname = Cfg.Procdesc.get_proc_name procdesc in
let id = Ident.create_fresh Ident.knormal in let id = Ident.create_fresh Ident.knormal in
let pvar_mangled = Mangled.from_string (var_name_prefix ^ Ident.to_string id) in let pvar_mangled = Mangled.from_string (var_name_prefix ^ Ident.to_string id) in
@ -250,7 +250,7 @@ struct
let mk_temp_sil_var_for_expr tenv procdesc var_name_prefix expr_info = let mk_temp_sil_var_for_expr tenv procdesc var_name_prefix expr_info =
let type_ptr = expr_info.Clang_ast_t.ei_type_ptr in let type_ptr = expr_info.Clang_ast_t.ei_type_ptr in
let typ = CTypes_decl.type_ptr_to_sil_type tenv type_ptr in let typ = CTypes_decl.type_ptr_to_sil_type tenv type_ptr in
(mk_temp_sil_var tenv procdesc var_name_prefix, typ) (mk_temp_sil_var procdesc var_name_prefix, typ)
let create_call_instr trans_state return_type function_sil params_sil sil_loc let create_call_instr trans_state return_type function_sil params_sil sil_loc
call_flags ~is_objc_method = call_flags ~is_objc_method =
@ -263,9 +263,8 @@ struct
let var_exp = match trans_state.var_exp_typ with let var_exp = match trans_state.var_exp_typ with
| Some (exp, _) -> exp | Some (exp, _) -> exp
| _ -> | _ ->
let tenv = trans_state.context.CContext.tenv in
let procdesc = trans_state.context.CContext.procdesc in let procdesc = trans_state.context.CContext.procdesc in
let pvar = mk_temp_sil_var tenv procdesc "__temp_return_" in let pvar = mk_temp_sil_var procdesc "__temp_return_" in
Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, return_type)]; Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, return_type)];
Sil.Lvar pvar in Sil.Lvar pvar in
(* It is very confusing - same expression has two different types in two contexts:*) (* It is very confusing - same expression has two different types in two contexts:*)
@ -303,7 +302,7 @@ struct
| Some bn -> { empty_res_trans with root_nodes = bn.continue } | Some bn -> { empty_res_trans with root_nodes = bn.continue }
| _ -> assert false | _ -> assert false
let stringLiteral_trans trans_state stmt_info expr_info str = let stringLiteral_trans trans_state expr_info str =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
let exp = Sil.Const (Sil.Cstr (str)) in let exp = Sil.Const (Sil.Cstr (str)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
@ -312,40 +311,40 @@ struct
(* that has integral type (e.g., int or long) and is the same size and alignment as a pointer. The __null *) (* that has integral type (e.g., int or long) and is the same size and alignment as a pointer. The __null *)
(* extension is typically only used by system headers, which define NULL as __null in C++ rather than using 0 *) (* extension is typically only used by system headers, which define NULL as __null in C++ rather than using 0 *)
(* (which is an integer that may not match the size of a pointer)". So we implement it as the constant zero *) (* (which is an integer that may not match the size of a pointer)". So we implement it as the constant zero *)
let gNUNullExpr_trans trans_state stmt_info expr_info = let gNUNullExpr_trans trans_state expr_info =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
let exp = Sil.Const (Sil.Cint (Sil.Int.zero)) in let exp = Sil.Const (Sil.Cint (Sil.Int.zero)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
let nullPtrExpr_trans trans_state stmt_info expr_info = let nullPtrExpr_trans trans_state expr_info =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
{ empty_res_trans with exps = [(Sil.exp_null, typ)]} { empty_res_trans with exps = [(Sil.exp_null, typ)]}
let objCSelectorExpr_trans trans_state stmt_info expr_info selector = let objCSelectorExpr_trans trans_state expr_info selector =
stringLiteral_trans trans_state stmt_info expr_info selector stringLiteral_trans trans_state expr_info selector
let objCEncodeExpr_trans trans_state stmt_info expr_info type_ptr = let objCEncodeExpr_trans trans_state expr_info type_ptr =
stringLiteral_trans trans_state stmt_info expr_info (Ast_utils.string_of_type_ptr type_ptr) stringLiteral_trans trans_state expr_info (Ast_utils.string_of_type_ptr type_ptr)
let objCProtocolExpr_trans trans_state stmt_info expr_info decl_ref = let objCProtocolExpr_trans trans_state expr_info decl_ref =
let name = (match decl_ref.Clang_ast_t.dr_name with let name = (match decl_ref.Clang_ast_t.dr_name with
| Some s -> s.Clang_ast_t.ni_name | Some s -> s.Clang_ast_t.ni_name
| _ -> "") in | _ -> "") in
stringLiteral_trans trans_state stmt_info expr_info name stringLiteral_trans trans_state expr_info name
let characterLiteral_trans trans_state stmt_info expr_info n = let characterLiteral_trans trans_state expr_info n =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
let exp = Sil.Const (Sil.Cint (Sil.Int.of_int n)) in let exp = Sil.Const (Sil.Cint (Sil.Int.of_int n)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
let floatingLiteral_trans trans_state stmt_info expr_info float_string = let floatingLiteral_trans trans_state expr_info float_string =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
let exp = Sil.Const (Sil.Cfloat (float_of_string float_string)) in let exp = Sil.Const (Sil.Cfloat (float_of_string float_string)) in
{ empty_res_trans with exps = [(exp, typ)]} { empty_res_trans with exps = [(exp, typ)]}
(* Note currently we don't have support for different qual *) (* Note currently we don't have support for different qual *)
(* type like long, unsigned long, etc *) (* type like long, unsigned long, etc *)
and integerLiteral_trans trans_state stmt_info expr_info integer_literal_info = and integerLiteral_trans trans_state expr_info integer_literal_info =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
let exp, ids = let exp, ids =
try try
@ -362,7 +361,7 @@ struct
exps = [(exp, typ)]; exps = [(exp, typ)];
ids = ids; } ids = ids; }
let cxxScalarValueInitExpr_trans trans_state stmt_info expr_info = let cxxScalarValueInitExpr_trans trans_state expr_info =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
(* constant will be different depending on type *) (* constant will be different depending on type *)
let zero_opt = match typ with let zero_opt = match typ with
@ -374,11 +373,11 @@ struct
| Some zero -> { empty_res_trans with exps = [(Sil.Const zero, typ)] } | Some zero -> { empty_res_trans with exps = [(Sil.Const zero, typ)] }
| _ -> empty_res_trans | _ -> empty_res_trans
let nullStmt_trans succ_nodes stmt_info = let nullStmt_trans succ_nodes =
{ empty_res_trans with root_nodes = succ_nodes } { empty_res_trans with root_nodes = succ_nodes }
(* The stmt seems to be always empty *) (* The stmt seems to be always empty *)
let unaryExprOrTypeTraitExpr_trans trans_state stmt_info expr_info unary_expr_or_type_trait_expr_info = let unaryExprOrTypeTraitExpr_trans trans_state expr_info unary_expr_or_type_trait_expr_info =
let tenv = trans_state.context.CContext.tenv in let tenv = trans_state.context.CContext.tenv in
let typ = CTypes_decl.type_ptr_to_sil_type tenv expr_info.Clang_ast_t.ei_type_ptr in let typ = CTypes_decl.type_ptr_to_sil_type tenv expr_info.Clang_ast_t.ei_type_ptr in
match unary_expr_or_type_trait_expr_info.Clang_ast_t.uttei_kind with match unary_expr_or_type_trait_expr_info.Clang_ast_t.uttei_kind with
@ -578,7 +577,7 @@ struct
decl_ref.Clang_ast_t.dr_decl_pointer in decl_ref.Clang_ast_t.dr_decl_pointer in
print_error decl_kind; assert false print_error decl_kind; assert false
and declRefExpr_trans trans_state stmt_info expr_info decl_ref_expr_info e = and declRefExpr_trans trans_state stmt_info decl_ref_expr_info _ =
Printing.log_out " priority node free = '%s'\n@." Printing.log_out " priority node free = '%s'\n@."
(string_of_bool (PriorityNode.is_priority_free trans_state)); (string_of_bool (PriorityNode.is_priority_free trans_state));
let decl_ref = match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with let decl_ref = match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with
@ -623,7 +622,7 @@ struct
let const_exp = get_enum_constant_expr context decl_ref.Clang_ast_t.dr_decl_pointer in let const_exp = get_enum_constant_expr context decl_ref.Clang_ast_t.dr_decl_pointer in
{ empty_res_trans with exps = [(const_exp, typ)] } { empty_res_trans with exps = [(const_exp, typ)] }
and arraySubscriptExpr_trans trans_state stmt_info expr_info stmt_list = and arraySubscriptExpr_trans trans_state expr_info stmt_list =
let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let typ = CTypes_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in
let array_stmt, idx_stmt = (match stmt_list with let array_stmt, idx_stmt = (match stmt_list with
| [a; i] -> a, i (* Assumption: the statement list contains 2 elements, | [a; i] -> a, i (* Assumption: the statement list contains 2 elements,
@ -631,9 +630,9 @@ struct
| _ -> assert false) in (* Let's get notified if the assumption is wrong...*) | _ -> assert false) in (* Let's get notified if the assumption is wrong...*)
let res_trans_a = instruction trans_state array_stmt in let res_trans_a = instruction trans_state array_stmt in
let res_trans_idx = instruction trans_state idx_stmt in let res_trans_idx = instruction trans_state idx_stmt in
let (a_exp, a_typ) = extract_exp_from_list res_trans_a.exps let (a_exp, _) = extract_exp_from_list res_trans_a.exps
"WARNING: In ArraySubscriptExpr there was a problem in translating array exp.\n" in "WARNING: In ArraySubscriptExpr there was a problem in translating array exp.\n" in
let (i_exp, i_typ) = extract_exp_from_list res_trans_idx.exps let (i_exp, _) = extract_exp_from_list res_trans_idx.exps
"WARNING: In ArraySubscriptExpr there was a problem in translating index exp.\n" in "WARNING: In ArraySubscriptExpr there was a problem in translating index exp.\n" in
let array_exp = Sil.Lindex (a_exp, i_exp) in let array_exp = Sil.Lindex (a_exp, i_exp) in
@ -673,7 +672,7 @@ struct
let sil_loc = CLocation.get_sil_location stmt_info context in let sil_loc = CLocation.get_sil_location stmt_info context in
let typ = CTypes_decl.type_ptr_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_type_ptr in let typ = CTypes_decl.type_ptr_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_type_ptr in
(match stmt_list with (match stmt_list with
| [s1; ImplicitCastExpr (stmt, [CompoundLiteralExpr (cle_stmt_info, stmts, expr_info)], _, cast_expr_info)] -> | [s1; ImplicitCastExpr (_, [CompoundLiteralExpr (_, stmts, expr_info)], _, _)] ->
let decl_ref = get_decl_ref_info s1 in let decl_ref = get_decl_ref_info s1 in
let pvar = CVar_decl.sil_var_of_decl_ref context decl_ref procname in let pvar = CVar_decl.sil_var_of_decl_ref context decl_ref procname in
let trans_state' = { trans_state with var_exp_typ = Some (Sil.Lvar pvar, typ) } in let trans_state' = { trans_state with var_exp_typ = Some (Sil.Lvar pvar, typ) } in
@ -692,7 +691,9 @@ struct
(* translation of s2 is done taking care of block special case *) (* translation of s2 is done taking care of block special case *)
exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state' s2 stmt_info in exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state' s2 stmt_info in
let (sil_e1, sil_typ1) = extract_exp_from_list res_trans_e1.exps "\nWARNING: Missing LHS operand in BinOp. Returning -1. Fix needed...\n" in let (sil_e1, sil_typ1) = extract_exp_from_list res_trans_e1.exps "\nWARNING: Missing LHS operand in BinOp. Returning -1. Fix needed...\n" in
let (sil_e2, sil_typ2) = extract_exp_from_list res_trans_e2.exps "\nWARNING: Missing RHS operand in BinOp. Returning -1. Fix needed...\n" in let (sil_e2, _) =
extract_exp_from_list res_trans_e2.exps
"\nWARNING: Missing RHS operand in BinOp. Returning -1. Fix needed...\n" in
let exp_op, instr_bin, ids_bin = let exp_op, instr_bin, ids_bin =
CArithmetic_trans.binary_operation_instruction context binary_operator_info sil_e1 typ sil_e2 sil_loc rhs_owning_method in CArithmetic_trans.binary_operation_instruction context binary_operator_info sil_e1 typ sil_e2 sil_loc rhs_owning_method in
@ -748,7 +749,7 @@ struct
(* afterwards. The 'instructions' function does not do that *) (* afterwards. The 'instructions' function does not do that *)
let trans_state_param = let trans_state_param =
{ trans_state_pri with succ_nodes = []; var_exp_typ = None } in { trans_state_pri with succ_nodes = []; var_exp_typ = None } in
let (sil_fe, typ_fe) = extract_exp_from_list res_trans_callee.exps let (sil_fe, _) = extract_exp_from_list res_trans_callee.exps
"WARNING: The translation of fun_exp did not return an expression. Returning -1. NEED TO BE FIXED" in "WARNING: The translation of fun_exp did not return an expression. Returning -1. NEED TO BE FIXED" in
let callee_pname_opt = let callee_pname_opt =
match sil_fe with match sil_fe with
@ -821,7 +822,7 @@ struct
let sil_loc = CLocation.get_sil_location si context in let sil_loc = CLocation.get_sil_location si context in
(* first for method address, second for 'this' expression *) (* first for method address, second for 'this' expression *)
assert ((IList.length result_trans_callee.exps) = 2); assert ((IList.length result_trans_callee.exps) = 2);
let (sil_method, typ_method) = IList.hd result_trans_callee.exps in let (sil_method, _) = IList.hd result_trans_callee.exps in
let callee_pname = match sil_method with let callee_pname = match sil_method with
| Sil.Const (Sil.Cfun pn) -> pn | Sil.Const (Sil.Cfun pn) -> pn
| _ -> assert false (* method pointer not implemented, this shouldn't happen *) in | _ -> assert false (* method pointer not implemented, this shouldn't happen *) in
@ -878,9 +879,8 @@ struct
let var_exp, class_type = match trans_state.var_exp_typ with let var_exp, class_type = match trans_state.var_exp_typ with
| Some exp_typ -> exp_typ | Some exp_typ -> exp_typ
| None -> | None ->
let tenv = trans_state.context.CContext.tenv in
let procdesc = trans_state.context.CContext.procdesc in let procdesc = trans_state.context.CContext.procdesc in
let pvar = mk_temp_sil_var tenv procdesc "__temp_construct_" in let pvar = mk_temp_sil_var procdesc "__temp_construct_" in
let class_type = CTypes_decl.get_type_from_expr_info ei context.CContext.tenv in let class_type = CTypes_decl.get_type_from_expr_info ei context.CContext.tenv in
Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, class_type)]; Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, class_type)];
Sil.Lvar pvar, class_type in Sil.Lvar pvar, class_type in
@ -901,8 +901,8 @@ struct
cxx_method_construct_call_trans trans_state_pri res_trans_callee [] si Sil.Tvoid cxx_method_construct_call_trans trans_state_pri res_trans_callee [] si Sil.Tvoid
else empty_res_trans else empty_res_trans
and objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info stmt_list and objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info
expr_info method_type trans_state_pri sil_loc act_params = method_type trans_state_pri sil_loc act_params =
let context = trans_state.context in let context = trans_state.context in
let receiver_kind = obj_c_message_expr_info.Clang_ast_t.omei_receiver_kind in let receiver_kind = obj_c_message_expr_info.Clang_ast_t.omei_receiver_kind in
let selector = obj_c_message_expr_info.Clang_ast_t.omei_selector in let selector = obj_c_message_expr_info.Clang_ast_t.omei_selector in
@ -961,8 +961,8 @@ struct
let obj_c_message_expr_info, res_trans_subexpr_list = let obj_c_message_expr_info, res_trans_subexpr_list =
objCMessageExpr_deal_with_static_self trans_state_param stmt_list obj_c_message_expr_info in objCMessageExpr_deal_with_static_self trans_state_param stmt_list obj_c_message_expr_info in
let subexpr_exprs = collect_exprs res_trans_subexpr_list in let subexpr_exprs = collect_exprs res_trans_subexpr_list in
match objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info stmt_list match objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info
expr_info method_type trans_state_pri sil_loc subexpr_exprs with method_type trans_state_pri sil_loc subexpr_exprs with
| Some res -> res | Some res -> res
| None -> | None ->
let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
@ -993,16 +993,16 @@ struct
{ res_trans_to_parent with exps = res_trans_call.exps } { res_trans_to_parent with exps = res_trans_call.exps }
and dispatch_function_trans trans_state stmt_info stmt_list ei n = and dispatch_function_trans trans_state stmt_info stmt_list n =
Printing.log_out "\n Call to a dispatch function treated as special case...\n"; Printing.log_out "\n Call to a dispatch function treated as special case...\n";
let procname = Cfg.Procdesc.get_proc_name trans_state.context.CContext.procdesc in 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 pvar = CFrontend_utils.General_utils.get_next_block_pvar procname in
let transformed_stmt, tp = let transformed_stmt, _ =
Ast_expressions.translate_dispatch_function (Sil.pvar_to_string pvar) stmt_info stmt_list ei n in Ast_expressions.translate_dispatch_function (Sil.pvar_to_string pvar) stmt_info stmt_list n in
instruction trans_state transformed_stmt instruction trans_state transformed_stmt
and block_enumeration_trans trans_state stmt_info stmt_list ei = and block_enumeration_trans trans_state stmt_info stmt_list ei =
let declare_nullify_vars loc res_state roots preds (pvar, typ) = let declare_nullify_vars loc preds pvar =
(* Add nullify of the temp block var to the last node (predecessor or the successor nodes)*) (* Add nullify of the temp block var to the last node (predecessor or the successor nodes)*)
IList.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
@ -1011,17 +1011,16 @@ struct
let pvar = CFrontend_utils.General_utils.get_next_block_pvar procname in let pvar = CFrontend_utils.General_utils.get_next_block_pvar procname in
let transformed_stmt, vars_to_register = let transformed_stmt, vars_to_register =
Ast_expressions.translate_block_enumerate (Sil.pvar_to_string pvar) stmt_info stmt_list ei in Ast_expressions.translate_block_enumerate (Sil.pvar_to_string pvar) stmt_info stmt_list ei in
let pvars_types = IList.map (fun (v, pointer, tp) -> let pvars = IList.map (fun (v, _, _) ->
let pvar = Sil.mk_pvar (Mangled.from_string v) procname in Sil.mk_pvar (Mangled.from_string v) procname
let typ = CTypes_decl.type_ptr_to_sil_type trans_state.context.CContext.tenv tp in ) vars_to_register in
(pvar, typ)) vars_to_register in
let loc = CLocation.get_sil_location stmt_info trans_state.context in let loc = CLocation.get_sil_location stmt_info trans_state.context in
let res_state = instruction trans_state transformed_stmt in let res_state = instruction trans_state transformed_stmt in
let preds = IList.flatten (IList.map (fun n -> Cfg.Node.get_preds n) trans_state.succ_nodes) in 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; IList.iter (declare_nullify_vars loc preds) pvars;
res_state res_state
and compoundStmt_trans trans_state stmt_info stmt_list = and compoundStmt_trans trans_state stmt_list =
instructions trans_state stmt_list instructions trans_state stmt_list
and conditionalOperator_trans trans_state stmt_info stmt_list expr_info = and conditionalOperator_trans trans_state stmt_info stmt_list expr_info =
@ -1035,7 +1034,7 @@ struct
let trans_state_pri = PriorityNode.force_claim_priority_node trans_state stmt_info in let trans_state_pri = PriorityNode.force_claim_priority_node trans_state stmt_info in
let trans_state' = { trans_state_pri with succ_nodes = [] } in let trans_state' = { trans_state_pri with succ_nodes = [] } in
let res_trans_b = instruction trans_state' stmt in let res_trans_b = instruction trans_state' stmt in
let (e', e'_typ) = extract_exp_from_list res_trans_b.exps let (e', _) = extract_exp_from_list res_trans_b.exps
"\nWARNING: Missing branch expression for Conditional operator. Need to be fixed\n" in "\nWARNING: Missing branch expression for Conditional operator. Need to be fixed\n" in
let set_temp_var = [ let set_temp_var = [
Sil.Declare_locals([(pvar, var_typ)], sil_loc); Sil.Declare_locals([(pvar, var_typ)], sil_loc);
@ -1099,7 +1098,8 @@ struct
(* Assumption: If it's a null_stmt, it is a loop with no bound, so we set condition to 1 *) (* Assumption: If it's a null_stmt, it is a loop with no bound, so we set condition to 1 *)
else else
instruction trans_state cond in instruction trans_state cond in
let e', instrs' = define_condition_side_effects context res_trans_cond.exps res_trans_cond.instrs sil_loc in let e', instrs' =
define_condition_side_effects 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_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 let prune_f = mk_prune_node false e' res_trans_cond.ids instrs' in
IList.iter (fun n' -> Cfg.Node.set_succs_exn n' [prune_t; prune_f] []) res_trans_cond.leaf_nodes; IList.iter (fun n' -> Cfg.Node.set_succs_exn n' [prune_t; prune_f] []) res_trans_cond.leaf_nodes;
@ -1137,7 +1137,7 @@ struct
let root_nodes_to_parent = let root_nodes_to_parent =
if (IList.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 (exp1, typ1) = extract_exp res_trans_s1.exps in
let (exp2, typ2) = extract_exp res_trans_s2.exps in let (exp2, _) = extract_exp res_trans_s2.exps in
let e_cond = Sil.BinOp (binop, exp1, exp2) in let e_cond = Sil.BinOp (binop, exp1, exp2) in
{ root_nodes = root_nodes_to_parent; { root_nodes = root_nodes_to_parent;
leaf_nodes = prune_to_short_c@res_trans_s2.leaf_nodes; leaf_nodes = prune_to_short_c@res_trans_s2.leaf_nodes;
@ -1149,7 +1149,7 @@ struct
Printing.log_out "Translating Condition for Conditional/Loop \n"; Printing.log_out "Translating Condition for Conditional/Loop \n";
let open Clang_ast_t in let open Clang_ast_t in
match cond with match cond with
| BinaryOperator(si, [s1; s2], expr_info, boi) -> | BinaryOperator(_, [s1; s2], _, boi) ->
(match boi.Clang_ast_t.boi_kind with (match boi.Clang_ast_t.boi_kind with
| `LAnd -> short_circuit (Sil.LAnd) s1 s2 | `LAnd -> short_circuit (Sil.LAnd) s1 s2
| `LOr -> short_circuit (Sil.LOr) s1 s2 | `LOr -> short_circuit (Sil.LOr) s1 s2
@ -1160,7 +1160,7 @@ struct
and declStmt_in_condition_trans trans_state decl_stmt res_trans_cond = and declStmt_in_condition_trans trans_state decl_stmt res_trans_cond =
match decl_stmt with match decl_stmt with
| Clang_ast_t.DeclStmt(stmt_info, stmt_list, decl_list) -> | Clang_ast_t.DeclStmt(stmt_info, _, decl_list) ->
let trans_state_decl = { trans_state with let trans_state_decl = { trans_state with
succ_nodes = res_trans_cond.root_nodes succ_nodes = res_trans_cond.root_nodes
} in } in
@ -1291,7 +1291,7 @@ struct
let e_const = res_trans_case_const.exps in let e_const = res_trans_case_const.exps in
let e_const' = let e_const' =
match e_const with match e_const with
| [(head, typ)] -> head | [(head, _)] -> head
| _ -> assert false in | _ -> assert false in
let sil_eq_cond = Sil.BinOp (Sil.Eq, switch_e_cond', e_const') in let sil_eq_cond = Sil.BinOp (Sil.Eq, switch_e_cond', e_const') in
let sil_loc = CLocation.get_sil_location stmt_info context in let sil_loc = CLocation.get_sil_location stmt_info context in
@ -1307,7 +1307,7 @@ struct
| _ -> assert false in | _ -> assert false in
match cases with (* top-down to handle default cases *) match cases with (* top-down to handle default cases *)
| [] -> next_nodes, next_prune_nodes | [] -> next_nodes, next_prune_nodes
| CaseStmt(stmt_info, _ :: _ :: case_content) as case :: rest -> | CaseStmt(_, _ :: _ :: case_content) as case :: rest ->
let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in
let case_entry_point = connected_instruction (IList.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 *) (* connects between cases, then continuation has priority about breaks *)
@ -1332,7 +1332,7 @@ struct
{ empty_res_trans with root_nodes = top_nodes; leaf_nodes = succ_nodes } { empty_res_trans with root_nodes = top_nodes; leaf_nodes = succ_nodes }
| _ -> assert false | _ -> assert false
and stmtExpr_trans trans_state stmt_info stmt_list expr_info = and stmtExpr_trans trans_state stmt_info stmt_list =
let context = trans_state.context in let context = trans_state.context in
let stmt = extract_stmt_from_singleton stmt_list "ERROR: StmtExpr should have only one statement.\n" in 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 res_trans_stmt = instruction trans_state stmt in
@ -1364,7 +1364,7 @@ struct
let continuation_cond = mk_cond_continuation outer_continuation in let continuation_cond = mk_cond_continuation outer_continuation in
let init_incr_nodes = let init_incr_nodes =
match loop_kind with match loop_kind with
| Loops.For (init, decl_stmt, cond, incr, body) -> | Loops.For (init, _, _, incr, _) ->
let trans_state' = { let trans_state' = {
trans_state with trans_state with
succ_nodes = [join_node]; succ_nodes = [join_node];
@ -1391,12 +1391,12 @@ struct
let body_succ_nodes = let body_succ_nodes =
match loop_kind with match loop_kind with
| Loops.For _ -> (match init_incr_nodes with | Loops.For _ -> (match init_incr_nodes with
| Some (nodes_init, nodes_incr) -> nodes_incr | Some (_, nodes_incr) -> nodes_incr
| None -> assert false) | None -> assert false)
| Loops.While _ -> [join_node] | Loops.While _ -> [join_node]
| Loops.DoWhile _ -> res_trans_cond.root_nodes in | Loops.DoWhile _ -> res_trans_cond.root_nodes in
let body_continuation = match continuation, init_incr_nodes with let body_continuation = match continuation, init_incr_nodes with
| Some c, Some (nodes_init, nodes_incr) -> | Some c, Some (_, nodes_incr) ->
Some { c with continue = nodes_incr } Some { c with continue = nodes_incr }
| _ -> continuation in | _ -> continuation in
let res_trans_body = let res_trans_body =
@ -1421,7 +1421,7 @@ struct
let root_nodes = let root_nodes =
match loop_kind with match loop_kind with
| Loops.For _ -> | Loops.For _ ->
(match init_incr_nodes with | Some (nodes_init, nodes_incr) -> nodes_init | None -> assert false) (match init_incr_nodes with | Some (nodes_init, _) -> nodes_init | None -> assert false)
| Loops.While _ | Loops.DoWhile _ -> [join_node] in | Loops.While _ | Loops.DoWhile _ -> [join_node] in
{ empty_res_trans with root_nodes = root_nodes; leaf_nodes = prune_nodes_f } { empty_res_trans with root_nodes = root_nodes; leaf_nodes = prune_nodes_f }
@ -1509,10 +1509,10 @@ struct
collect_left_hand_exprs e tvar (StringSet.add (Typename.to_string typename) tns) collect_left_hand_exprs e tvar (StringSet.add (Typename.to_string typename) tns)
| _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*)) | _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*))
| Sil.Tstruct { Sil.instance_fields } as type_struct -> | Sil.Tstruct { Sil.instance_fields } as type_struct ->
let lh_exprs = IList.map ( fun (fieldname, fieldtype, _) -> let lh_exprs = IList.map ( fun (fieldname, _, _) ->
Sil.Lfield (e, fieldname, type_struct) ) Sil.Lfield (e, fieldname, type_struct) )
instance_fields in instance_fields in
let lh_types = IList.map ( fun (fieldname, fieldtype, _) -> fieldtype) let lh_types = IList.map ( fun (_, fieldtype, _) -> fieldtype)
instance_fields in instance_fields in
IList.map (fun (e, t) -> IList.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)) -> | Sil.Tarray (arrtyp, Sil.Const (Sil.Cint n)) ->
@ -1544,7 +1544,8 @@ struct
(* In arc mode, if it's a method call or we are initializing with a pointer to objc class *) (* In arc mode, if it's a method call or we are initializing with a pointer to objc class *)
(* we need to add retain/release *) (* we need to add retain/release *)
let (e, instrs, ids) = let (e, instrs, ids) =
CArithmetic_trans.assignment_arc_mode context lh_exp lh_t rh_exp sil_loc rhs_owning_method true in CArithmetic_trans.assignment_arc_mode
lh_exp lh_t rh_exp sil_loc rhs_owning_method true in
([(e, lh_t)], instrs, ids) ([(e, lh_t)], instrs, ids)
else else
([], [Sil.Set (lh_exp, lh_t, rh_exp, sil_loc)], [])) ([], [Sil.Set (lh_exp, lh_t, rh_exp, sil_loc)], []))
@ -1616,7 +1617,7 @@ struct
(* we need to add retain/release *) (* we need to add retain/release *)
let (e, instrs, ids) = let (e, instrs, ids) =
CArithmetic_trans.assignment_arc_mode CArithmetic_trans.assignment_arc_mode
context var_exp ie_typ sil_e1' sil_loc rhs_owning_method true in var_exp ie_typ sil_e1' sil_loc rhs_owning_method true in
([(e, ie_typ)], instrs, ids) ([(e, ie_typ)], instrs, ids)
else else
([], [Sil.Set (var_exp, ie_typ, sil_e1', sil_loc)], []) in ([], [Sil.Set (var_exp, ie_typ, sil_e1', sil_loc)], []) in
@ -1676,13 +1677,13 @@ struct
empty_res_trans in empty_res_trans in
{ res_trans with leaf_nodes = [] } { res_trans with leaf_nodes = [] }
and objCPropertyRefExpr_trans trans_state stmt_info stmt_list = and objCPropertyRefExpr_trans trans_state stmt_list =
match stmt_list with match stmt_list with
| [stmt] -> instruction trans_state stmt | [stmt] -> instruction trans_state stmt
| _ -> assert false | _ -> assert false
(* For OpaqueValueExpr we return the translation generated from its source expression*) (* For OpaqueValueExpr we return the translation generated from its source expression*)
and opaqueValueExpr_trans trans_state stmt_info opaque_value_expr_info = and opaqueValueExpr_trans trans_state opaque_value_expr_info =
Printing.log_out " priority node free = '%s'\n@." Printing.log_out " priority node free = '%s'\n@."
(string_of_bool (PriorityNode.is_priority_free trans_state)); (string_of_bool (PriorityNode.is_priority_free trans_state));
match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with
@ -1703,7 +1704,7 @@ struct
(* For example: 'x.f = a' when 'f' is a property will be translated with a call to f's setter [x f:a]*) (* For example: 'x.f = a' when 'f' is a property will be translated with a call to f's setter [x f:a]*)
(* the stmt_list will be [x.f = a; x; a; CallToSetter] Among all element of the list we only need*) (* the stmt_list will be [x.f = a; x; a; CallToSetter] Among all element of the list we only need*)
(* to translate the CallToSetter which is how x.f = a is actually implemented by the runtime.*) (* to translate the CallToSetter which is how x.f = a is actually implemented by the runtime.*)
and pseudoObjectExpr_trans trans_state stmt_info stmt_list = and pseudoObjectExpr_trans trans_state stmt_list =
Printing.log_out " priority node free = '%s'\n@." Printing.log_out " priority node free = '%s'\n@."
(string_of_bool (PriorityNode.is_priority_free trans_state)); (string_of_bool (PriorityNode.is_priority_free trans_state));
let rec do_semantic_elements el = let rec do_semantic_elements el =
@ -1713,7 +1714,7 @@ struct
| stmt :: _ -> instruction trans_state stmt | stmt :: _ -> instruction trans_state stmt
| _ -> assert false in | _ -> assert false in
match stmt_list with match stmt_list with
| syntactic_form :: semantic_form -> | _ :: semantic_form ->
do_semantic_elements semantic_form do_semantic_elements semantic_form
| _ -> assert false | _ -> assert false
@ -1737,7 +1738,7 @@ struct
} }
(* function used in the computation for both Member_Expr and ObjCIVarRefExpr *) (* function used in the computation for both Member_Expr and ObjCIVarRefExpr *)
and do_memb_ivar_ref_exp trans_state expr_info stmt_info stmt_list decl_ref = and do_memb_ivar_ref_exp trans_state stmt_info stmt_list decl_ref =
let exp_stmt = extract_stmt_from_singleton stmt_list let exp_stmt = extract_stmt_from_singleton stmt_list
"WARNING: in MemberExpr there must be only one stmt defining its expression.\n" in "WARNING: in MemberExpr there must be only one stmt defining its expression.\n" in
(* Don't pass var_exp_typ to child of MemberExpr - this may lead to initializing variable *) (* Don't pass var_exp_typ to child of MemberExpr - this may lead to initializing variable *)
@ -1747,14 +1748,14 @@ struct
let result_trans_exp_stmt = exec_with_glvalue_as_reference instruction trans_state' exp_stmt in let result_trans_exp_stmt = exec_with_glvalue_as_reference instruction trans_state' exp_stmt in
decl_ref_trans trans_state result_trans_exp_stmt stmt_info decl_ref decl_ref_trans trans_state result_trans_exp_stmt stmt_info decl_ref
and objCIvarRefExpr_trans trans_state stmt_info expr_info stmt_list obj_c_ivar_ref_expr_info = and objCIvarRefExpr_trans trans_state stmt_info stmt_list obj_c_ivar_ref_expr_info =
let decl_ref = obj_c_ivar_ref_expr_info.Clang_ast_t.ovrei_decl_ref in let decl_ref = obj_c_ivar_ref_expr_info.Clang_ast_t.ovrei_decl_ref in
CFrontend_errors.check_for_ivar_errors trans_state.context stmt_info obj_c_ivar_ref_expr_info; CFrontend_errors.check_for_ivar_errors trans_state.context stmt_info obj_c_ivar_ref_expr_info;
do_memb_ivar_ref_exp trans_state expr_info stmt_info stmt_list decl_ref do_memb_ivar_ref_exp trans_state stmt_info stmt_list decl_ref
and memberExpr_trans trans_state stmt_info expr_info stmt_list member_expr_info = and memberExpr_trans trans_state stmt_info stmt_list member_expr_info =
let decl_ref = member_expr_info.Clang_ast_t.mei_decl_ref in let decl_ref = member_expr_info.Clang_ast_t.mei_decl_ref in
do_memb_ivar_ref_exp trans_state expr_info stmt_info stmt_list decl_ref do_memb_ivar_ref_exp trans_state stmt_info stmt_list decl_ref
and unaryOperator_trans trans_state stmt_info expr_info stmt_list unary_operator_info = and unaryOperator_trans trans_state stmt_info expr_info stmt_list unary_operator_info =
let context = trans_state.context in let context = trans_state.context in
@ -1804,7 +1805,7 @@ struct
succ_nodes = []; succ_nodes = [];
var_exp_typ = Some (ret_exp, ret_typ) } in var_exp_typ = Some (ret_exp, ret_typ) } in
let res_trans_stmt = exec_with_self_exception instruction trans_state' stmt in let res_trans_stmt = exec_with_self_exception instruction trans_state' stmt in
let (sil_expr, sil_typ) = extract_exp_from_list res_trans_stmt.exps let (sil_expr, _) = extract_exp_from_list res_trans_stmt.exps
"WARNING: There should be only one return expression.\n" in "WARNING: There should be only one return expression.\n" in
let ret_instrs = if IList.exists (Sil.exp_equal ret_exp) res_trans_stmt.initd_exps let ret_instrs = if IList.exists (Sil.exp_equal ret_exp) res_trans_stmt.initd_exps
@ -1830,7 +1831,7 @@ struct
(* It may be that later on (when we treat ARC) some info can be taken from it. *) (* It may be that later on (when we treat ARC) some info can be taken from it. *)
(* For ParenExpression we translate its body composed by the stmt_list. *) (* For ParenExpression we translate its body composed by the stmt_list. *)
(* In paren expression there should be only one stmt that defines the expression *) (* In paren expression there should be only one stmt that defines the expression *)
and parenExpr_trans trans_state stmt_info stmt_list = and parenExpr_trans trans_state stmt_list =
let stmt = extract_stmt_from_singleton stmt_list let stmt = extract_stmt_from_singleton stmt_list
"WARNING: In ParenExpression there should be only one stmt.\n" in "WARNING: In ParenExpression there should be only one stmt.\n" in
instruction trans_state stmt instruction trans_state stmt
@ -1888,7 +1889,7 @@ struct
(* We ignore this item since we don't deal with the concurrency problem yet *) (* We ignore this item since we don't deal with the concurrency problem yet *)
(* For the same reason we also ignore the stmt_info that is related with the ObjCAtSynchronizedStmt construct *) (* For the same reason we also ignore the stmt_info that is related with the ObjCAtSynchronizedStmt construct *)
(* Finally we recursively work on the CompoundStmt, the second item of stmt_list *) (* Finally we recursively work on the CompoundStmt, the second item of stmt_list *)
and objCAtSynchronizedStmt_trans trans_state stmt_info stmt_list = and objCAtSynchronizedStmt_trans trans_state stmt_list =
(match stmt_list with (match stmt_list with
| [_; compound_stmt] -> instruction trans_state compound_stmt | [_; compound_stmt] -> instruction trans_state compound_stmt
| _ -> assert false) | _ -> assert false)
@ -1897,7 +1898,7 @@ struct
let context = trans_state.context in let context = trans_state.context in
let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
let loc = let loc =
(match stmt_info.Clang_ast_t.si_source_range with (l1, l2) -> (match stmt_info.Clang_ast_t.si_source_range with (l1, _) ->
CLocation.clang_to_sil_location l1 (Some context.CContext.procdesc)) in CLocation.clang_to_sil_location l1 (Some context.CContext.procdesc)) in
(* Given a captured var, return the instruction to assign it to a temp *) (* Given a captured var, return the instruction to assign it to a temp *)
let assign_captured_var (cvar, typ) = let assign_captured_var (cvar, typ) =
@ -1905,7 +1906,7 @@ struct
let instr = Sil.Letderef (id, (Sil.Lvar cvar), typ, loc) in let instr = Sil.Letderef (id, (Sil.Lvar cvar), typ, loc) in
(id, instr) in (id, instr) in
match decl with match decl with
| Clang_ast_t.BlockDecl (decl_info, block_decl_info) -> | Clang_ast_t.BlockDecl (_, block_decl_info) ->
let open CContext in let open CContext in
let type_ptr = expr_info.Clang_ast_t.ei_type_ptr in let type_ptr = expr_info.Clang_ast_t.ei_type_ptr in
let block_pname = CFrontend_utils.General_utils.mk_fresh_block_procname procname in let block_pname = CFrontend_utils.General_utils.mk_fresh_block_procname procname in
@ -1941,7 +1942,7 @@ struct
(* 1. Handle __new_array *) (* 1. Handle __new_array *)
(* 2. Handle initialization values *) (* 2. Handle initialization values *)
and cxxDeleteExpr_trans trans_state stmt_info stmt_list expr_info delete_expr_info = and cxxDeleteExpr_trans trans_state stmt_info stmt_list delete_expr_info =
let context = trans_state.context in let context = trans_state.context in
let sil_loc = CLocation.get_sil_location stmt_info context in let sil_loc = CLocation.get_sil_location stmt_info context in
let fname = SymExec.ModelBuiltins.__delete in let fname = SymExec.ModelBuiltins.__delete in
@ -1979,7 +1980,7 @@ struct
let res_trans = init_expr_trans trans_state var_exp_typ stmt_info (Some temp_exp) in let res_trans = init_expr_trans trans_state var_exp_typ stmt_info (Some temp_exp) in
{ res_trans with exps = [var_exp_typ] } { res_trans with exps = [var_exp_typ] }
and compoundLiteralExpr_trans trans_state stmt_info stmt_list expr_info = and compoundLiteralExpr_trans trans_state stmt_list expr_info =
let context = trans_state.context in let context = trans_state.context in
let procdesc = context.CContext.procdesc in let procdesc = context.CContext.procdesc in
let (pvar, typ) = mk_temp_sil_var_for_expr context.CContext.tenv procdesc let (pvar, typ) = mk_temp_sil_var_for_expr context.CContext.tenv procdesc
@ -2036,8 +2037,8 @@ struct
| LabelStmt(stmt_info, stmt_list, label_name) -> | LabelStmt(stmt_info, stmt_list, label_name) ->
labelStmt_trans trans_state stmt_info stmt_list label_name labelStmt_trans trans_state stmt_info stmt_list label_name
| ArraySubscriptExpr(stmt_info, stmt_list, expr_info) -> | ArraySubscriptExpr(_, stmt_list, expr_info) ->
arraySubscriptExpr_trans trans_state stmt_info expr_info stmt_list arraySubscriptExpr_trans trans_state expr_info stmt_list
| BinaryOperator(stmt_info, stmt_list, expr_info, binary_operator_info) -> | BinaryOperator(stmt_info, stmt_list, expr_info, binary_operator_info) ->
binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list
@ -2045,7 +2046,7 @@ struct
| CallExpr(stmt_info, stmt_list, ei) -> | CallExpr(stmt_info, stmt_list, ei) ->
(match is_dispatch_function stmt_list with (match is_dispatch_function stmt_list with
| Some block_arg_pos -> | Some block_arg_pos ->
dispatch_function_trans trans_state stmt_info stmt_list ei block_arg_pos dispatch_function_trans trans_state stmt_info stmt_list block_arg_pos
| None -> | None ->
callExpr_trans trans_state stmt_info stmt_list ei) callExpr_trans trans_state stmt_info stmt_list ei)
@ -2065,9 +2066,9 @@ struct
else else
objCMessageExpr_trans trans_state stmt_info obj_c_message_expr_info stmt_list expr_info objCMessageExpr_trans trans_state stmt_info obj_c_message_expr_info stmt_list expr_info
| CompoundStmt (stmt_info, stmt_list) -> | CompoundStmt (_, stmt_list) ->
(* No node for this statement. We just collect its statement list*) (* No node for this statement. We just collect its statement list*)
compoundStmt_trans trans_state stmt_info stmt_list compoundStmt_trans trans_state stmt_list
| ConditionalOperator(stmt_info, stmt_list, expr_info) -> | ConditionalOperator(stmt_info, stmt_list, expr_info) ->
(* Ternary operator "cond ? exp1 : exp2" *) (* Ternary operator "cond ? exp1 : exp2" *)
@ -2079,11 +2080,11 @@ struct
| SwitchStmt (stmt_info, switch_stmt_list) -> | SwitchStmt (stmt_info, switch_stmt_list) ->
switchStmt_trans trans_state stmt_info switch_stmt_list switchStmt_trans trans_state stmt_info switch_stmt_list
| CaseStmt (stmt_info, stmt_list) -> | CaseStmt _ ->
Printing.log_out "FATAL: Passing from CaseStmt outside of SwitchStmt, terminating.\n"; assert false Printing.log_out "FATAL: Passing from CaseStmt outside of SwitchStmt, terminating.\n"; assert false
| StmtExpr(stmt_info, stmt_list, expr_info) -> | StmtExpr(stmt_info, stmt_list, _) ->
stmtExpr_trans trans_state stmt_info stmt_list expr_info stmtExpr_trans trans_state stmt_info stmt_list
| ForStmt(stmt_info, [init; decl_stmt; cond; incr; body]) -> | ForStmt(stmt_info, [init; decl_stmt; cond; incr; body]) ->
forStmt_trans trans_state init decl_stmt cond incr body stmt_info forStmt_trans trans_state init decl_stmt cond incr body stmt_info
@ -2100,31 +2101,31 @@ struct
| ObjCForCollectionStmt(stmt_info, [item; items; body]) -> | ObjCForCollectionStmt(stmt_info, [item; items; body]) ->
objCForCollectionStmt_trans trans_state item items body stmt_info objCForCollectionStmt_trans trans_state item items body stmt_info
| NullStmt(stmt_info, stmt_list) -> | NullStmt _ ->
nullStmt_trans trans_state.succ_nodes stmt_info nullStmt_trans trans_state.succ_nodes
| CompoundAssignOperator(stmt_info, stmt_list, expr_info, binary_operator_info, caoi) -> | CompoundAssignOperator(stmt_info, stmt_list, expr_info, binary_operator_info, _) ->
binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list
| DeclStmt(stmt_info, stmt_list, decl_list) -> | DeclStmt(stmt_info, _, decl_list) ->
declStmt_trans trans_state decl_list stmt_info declStmt_trans trans_state decl_list stmt_info
| DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) as d -> | DeclRefExpr(stmt_info, _, _, decl_ref_expr_info) as d ->
declRefExpr_trans trans_state stmt_info expr_info decl_ref_expr_info d declRefExpr_trans trans_state stmt_info decl_ref_expr_info d
| ObjCPropertyRefExpr(stmt_info, stmt_list, expr_info, property_ref_expr_info) -> | ObjCPropertyRefExpr(_, stmt_list, _, _) ->
objCPropertyRefExpr_trans trans_state stmt_info stmt_list objCPropertyRefExpr_trans trans_state stmt_list
| CXXThisExpr(stmt_info, _, expr_info) -> cxxThisExpr_trans trans_state stmt_info expr_info | CXXThisExpr(stmt_info, _, expr_info) -> cxxThisExpr_trans trans_state stmt_info expr_info
| OpaqueValueExpr(stmt_info, stmt_list, expr_info, opaque_value_expr_info) -> | OpaqueValueExpr(_, _, _, opaque_value_expr_info) ->
opaqueValueExpr_trans trans_state stmt_info opaque_value_expr_info opaqueValueExpr_trans trans_state opaque_value_expr_info
| PseudoObjectExpr(stmt_info, stmt_list, expr_info) -> | PseudoObjectExpr(_, stmt_list, _) ->
pseudoObjectExpr_trans trans_state stmt_info stmt_list pseudoObjectExpr_trans trans_state stmt_list
| UnaryExprOrTypeTraitExpr(stmt_info, stmt_list, expr_info, ei) -> | UnaryExprOrTypeTraitExpr(_, _, expr_info, ei) ->
unaryExprOrTypeTraitExpr_trans trans_state stmt_info expr_info ei unaryExprOrTypeTraitExpr_trans trans_state expr_info ei
| ObjCBridgedCastExpr(stmt_info, stmt_list, expr_info, cast_kind, _) -> | ObjCBridgedCastExpr(stmt_info, stmt_list, expr_info, cast_kind, _) ->
cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_kind true cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_kind true
@ -2136,32 +2137,32 @@ struct
| CXXFunctionalCastExpr(stmt_info, stmt_list, expr_info, cast_kind, _)-> | CXXFunctionalCastExpr(stmt_info, stmt_list, expr_info, cast_kind, _)->
cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_kind false cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_kind false
| IntegerLiteral(stmt_info, _, expr_info, integer_literal_info) -> | IntegerLiteral(_, _, expr_info, integer_literal_info) ->
integerLiteral_trans trans_state stmt_info expr_info integer_literal_info integerLiteral_trans trans_state expr_info integer_literal_info
| StringLiteral(stmt_info, stmt_list, expr_info, str) -> | StringLiteral(_, _, expr_info, str) ->
stringLiteral_trans trans_state stmt_info expr_info str stringLiteral_trans trans_state expr_info str
| GNUNullExpr(stmt_info, stmt_list, expr_info) -> | GNUNullExpr(_, _, expr_info) ->
gNUNullExpr_trans trans_state stmt_info expr_info gNUNullExpr_trans trans_state expr_info
| CXXNullPtrLiteralExpr(stmt_info, stmt_list, expr_info) -> | CXXNullPtrLiteralExpr(_, _, expr_info) ->
nullPtrExpr_trans trans_state stmt_info expr_info nullPtrExpr_trans trans_state expr_info
| ObjCSelectorExpr(stmt_info, stmt_list, expr_info, selector) -> | ObjCSelectorExpr(_, _, expr_info, selector) ->
objCSelectorExpr_trans trans_state stmt_info expr_info selector objCSelectorExpr_trans trans_state expr_info selector
| ObjCEncodeExpr(stmt_info, stmt_list, expr_info, type_ptr) -> | ObjCEncodeExpr(_, _, expr_info, type_ptr) ->
objCEncodeExpr_trans trans_state stmt_info expr_info type_ptr objCEncodeExpr_trans trans_state expr_info type_ptr
| ObjCProtocolExpr(stmt_info, stmt_list, expr_info, decl_ref) -> | ObjCProtocolExpr(_, _, expr_info, decl_ref) ->
objCProtocolExpr_trans trans_state stmt_info expr_info decl_ref objCProtocolExpr_trans trans_state expr_info decl_ref
| ObjCIvarRefExpr(stmt_info, stmt_list, expr_info, obj_c_ivar_ref_expr_info) -> | ObjCIvarRefExpr(stmt_info, stmt_list, _, obj_c_ivar_ref_expr_info) ->
objCIvarRefExpr_trans trans_state stmt_info expr_info stmt_list obj_c_ivar_ref_expr_info objCIvarRefExpr_trans trans_state stmt_info stmt_list obj_c_ivar_ref_expr_info
| MemberExpr(stmt_info, stmt_list, expr_info, member_expr_info) -> | MemberExpr(stmt_info, stmt_list, _, member_expr_info) ->
memberExpr_trans trans_state stmt_info expr_info stmt_list member_expr_info memberExpr_trans trans_state stmt_info stmt_list member_expr_info
| UnaryOperator(stmt_info, stmt_list, expr_info, unary_operator_info) -> | UnaryOperator(stmt_info, stmt_list, expr_info, unary_operator_info) ->
if is_logical_negation_of_int trans_state.context.CContext.tenv expr_info unary_operator_info then if is_logical_negation_of_int trans_state.context.CContext.tenv expr_info unary_operator_info then
@ -2175,20 +2176,20 @@ struct
(* We analyze the content of the expr. We treat ExprWithCleanups as a wrapper. *) (* We analyze the content of the expr. We treat ExprWithCleanups as a wrapper. *)
(* It may be that later on (when we treat ARC) some info can be taken from it. *) (* It may be that later on (when we treat ARC) some info can be taken from it. *)
| ExprWithCleanups(stmt_info, stmt_list, expr_info, _) | ExprWithCleanups(_, stmt_list, _, _)
| ParenExpr(stmt_info, stmt_list, expr_info) -> | ParenExpr(_, stmt_list, _) ->
parenExpr_trans trans_state stmt_info stmt_list parenExpr_trans trans_state stmt_list
| ObjCBoolLiteralExpr (stmt_info, stmts, expr_info, n) | ObjCBoolLiteralExpr (_, _, expr_info, n)
| CharacterLiteral (stmt_info, stmts, expr_info, n) | CharacterLiteral (_, _, expr_info, n)
| CXXBoolLiteralExpr (stmt_info, stmts, expr_info, n) -> | CXXBoolLiteralExpr (_, _, expr_info, n) ->
characterLiteral_trans trans_state stmt_info expr_info n characterLiteral_trans trans_state expr_info n
| FloatingLiteral (stmt_info, stmts, expr_info, float_string) -> | FloatingLiteral (_, _, expr_info, float_string) ->
floatingLiteral_trans trans_state stmt_info expr_info float_string floatingLiteral_trans trans_state expr_info float_string
| CXXScalarValueInitExpr (stmt_info, stmts, expr_info) -> | CXXScalarValueInitExpr (_, _, expr_info) ->
cxxScalarValueInitExpr_trans trans_state stmt_info expr_info cxxScalarValueInitExpr_trans trans_state expr_info
| ObjCBoxedExpr (stmt_info, stmts, info, sel) -> | ObjCBoxedExpr (stmt_info, stmts, info, sel) ->
objCBoxedExpr_trans trans_state info sel stmt_info stmts objCBoxedExpr_trans trans_state info sel stmt_info stmts
@ -2202,14 +2203,14 @@ struct
| ObjCStringLiteral(stmt_info, stmts, info) -> | ObjCStringLiteral(stmt_info, stmts, info) ->
objCStringLiteral_trans trans_state stmt_info stmts info objCStringLiteral_trans trans_state stmt_info stmts info
| BreakStmt(stmt_info, lstmt) -> breakStmt_trans trans_state | BreakStmt _ -> breakStmt_trans trans_state
| ContinueStmt(stmt_infr, lstmt) -> continueStmt_trans trans_state | ContinueStmt _ -> continueStmt_trans trans_state
| ObjCAtSynchronizedStmt(stmt_info, stmt_list) -> | ObjCAtSynchronizedStmt(_, stmt_list) ->
objCAtSynchronizedStmt_trans trans_state stmt_info stmt_list objCAtSynchronizedStmt_trans trans_state stmt_list
| ObjCIndirectCopyRestoreExpr (stmt_info, stmt_list, _) -> | ObjCIndirectCopyRestoreExpr (_, stmt_list, _) ->
instructions trans_state stmt_list instructions trans_state stmt_list
| BlockExpr(stmt_info, _ , expr_info, decl) -> | BlockExpr(stmt_info, _ , expr_info, decl) ->
@ -2218,20 +2219,20 @@ struct
| ObjCAutoreleasePoolStmt (stmt_info, stmts) -> | ObjCAutoreleasePoolStmt (stmt_info, stmts) ->
objcAutoreleasePool_trans trans_state stmt_info stmts objcAutoreleasePool_trans trans_state stmt_info stmts
| ObjCAtTryStmt (stmt_info, stmts) -> | ObjCAtTryStmt (_, stmts) ->
compoundStmt_trans trans_state stmt_info stmts compoundStmt_trans trans_state stmts
| ObjCAtThrowStmt (stmt_info, stmts) -> | ObjCAtThrowStmt (stmt_info, stmts) ->
returnStmt_trans trans_state stmt_info stmts returnStmt_trans trans_state stmt_info stmts
| ObjCAtFinallyStmt (stmt_info, stmts) -> | ObjCAtFinallyStmt (_, stmts) ->
compoundStmt_trans trans_state stmt_info stmts compoundStmt_trans trans_state stmts
| ObjCAtCatchStmt (stmt_info, stmts, obj_c_message_expr_kind) -> | ObjCAtCatchStmt _ ->
compoundStmt_trans trans_state stmt_info [] compoundStmt_trans trans_state []
| PredefinedExpr (stmt_info, stmts, expr_info, predefined_expr_type) -> | PredefinedExpr (_, _, expr_info, _) ->
stringLiteral_trans trans_state stmt_info expr_info "" stringLiteral_trans trans_state expr_info ""
| BinaryConditionalOperator (stmt_info, stmts, expr_info) -> | BinaryConditionalOperator (stmt_info, stmts, expr_info) ->
(match stmts with (match stmts with
@ -2241,25 +2242,25 @@ struct
"BinaryConditionalOperator not translated %s @." "BinaryConditionalOperator not translated %s @."
(Ast_utils.string_of_stmt instr); (Ast_utils.string_of_stmt instr);
assert false) assert false)
| CXXNewExpr (stmt_info, stmt_list, expr_info, _) -> | CXXNewExpr (stmt_info, _, expr_info, _) ->
cxxNewExpr_trans trans_state stmt_info expr_info cxxNewExpr_trans trans_state stmt_info expr_info
| CXXDeleteExpr (stmt_info, stmt_list, expr_info, delete_expr_info) -> | CXXDeleteExpr (stmt_info, stmt_list, _, delete_expr_info) ->
cxxDeleteExpr_trans trans_state stmt_info stmt_list expr_info delete_expr_info cxxDeleteExpr_trans trans_state stmt_info stmt_list delete_expr_info
| MaterializeTemporaryExpr (stmt_info, stmt_list, expr_info, _) -> | MaterializeTemporaryExpr (stmt_info, stmt_list, expr_info, _) ->
materializeTemporaryExpr_trans trans_state stmt_info stmt_list expr_info materializeTemporaryExpr_trans trans_state stmt_info stmt_list expr_info
| CompoundLiteralExpr (stmt_info, stmt_list, expr_info) -> | CompoundLiteralExpr (_, stmt_list, expr_info) ->
compoundLiteralExpr_trans trans_state stmt_info stmt_list expr_info compoundLiteralExpr_trans trans_state stmt_list expr_info
| InitListExpr (stmt_info, stmts, expr_info) -> | InitListExpr (stmt_info, stmts, expr_info) ->
initListExpr_trans trans_state stmt_info expr_info stmts initListExpr_trans trans_state stmt_info expr_info stmts
| CXXBindTemporaryExpr (stmt_info, stmt_list, expr_info, cxx_bind_temp_expr_info) -> | CXXBindTemporaryExpr (_, stmt_list, _, _) ->
(* right now we ignore this expression and try to translate the child node *) (* right now we ignore this expression and try to translate the child node *)
parenExpr_trans trans_state stmt_info stmt_list parenExpr_trans trans_state stmt_list
| CXXDynamicCastExpr (stmt_info, stmts, expr_info, cast_expr_info, type_ptr, _) -> | CXXDynamicCastExpr (stmt_info, stmts, _, _, type_ptr, _) ->
cxxDynamicCastExpr_trans trans_state stmt_info stmts type_ptr cxxDynamicCastExpr_trans trans_state stmt_info stmts type_ptr
| CXXDefaultArgExpr (stmt_info, stmt_list, expr_info, default_arg_info) -> | CXXDefaultArgExpr (_, _, _, default_arg_info) ->
cxxDefaultArgExpr_trans trans_state default_arg_info cxxDefaultArgExpr_trans trans_state default_arg_info
| s -> (Printing.log_stats | s -> (Printing.log_stats

19
infer/src/clang/cTrans_models.ml
Unescape View File

@ -35,11 +35,11 @@ let is_alloc_model typ funct =
let rec get_func_type_from_stmt stmt = let rec get_func_type_from_stmt stmt =
match stmt with match stmt with
| Clang_ast_t.DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> | Clang_ast_t.DeclRefExpr(_, _, expr_info, _) ->
Some expr_info.Clang_ast_t.ei_type_ptr Some expr_info.Clang_ast_t.ei_type_ptr
| _ -> | _ ->
match CFrontend_utils.Ast_utils.get_stmts_from_stmt stmt with match CFrontend_utils.Ast_utils.get_stmts_from_stmt stmt with
| stmt:: rest -> get_func_type_from_stmt stmt | stmt:: _ -> get_func_type_from_stmt stmt
| [] -> None | [] -> None
let is_retain_predefined_model typ funct = let is_retain_predefined_model typ funct =
@ -138,7 +138,7 @@ let get_predefined_ms_stringWithUTF8String class_name method_name mk_procname la
get_predefined_ms_method condition class_name method_name Procname.Class_objc_method get_predefined_ms_method condition class_name method_name Procname.Class_objc_method
mk_procname lang [("x", Ast_expressions.create_char_star_type)] id_type [] None mk_procname lang [("x", Ast_expressions.create_char_star_type)] id_type [] None
let get_predefined_ms_retain_release class_name method_name mk_procname lang = let get_predefined_ms_retain_release method_name mk_procname lang =
let condition = is_retain_or_release method_name in let condition = is_retain_or_release method_name in
let return_type = let return_type =
if is_retain_method method_name || is_autorelease_method method_name if is_retain_method method_name || is_autorelease_method method_name
@ -175,15 +175,14 @@ let get_predefined_ms_is_kind_of_class class_name method_name mk_procname lang =
[] (Some SymExec.ModelBuiltins.__instanceof) [] (Some SymExec.ModelBuiltins.__instanceof)
let get_predefined_model_method_signature class_name method_name mk_procname lang = let get_predefined_model_method_signature class_name method_name mk_procname lang =
let next_predefined f a = function let next_predefined f = function
| Some _ as x -> x | Some _ as x -> x
| None -> f a method_name mk_procname lang in | None -> f method_name mk_procname lang in
let class_type = Ast_expressions.create_class_type (class_name, `OBJC) in
get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname lang get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname lang
|> next_predefined get_predefined_ms_retain_release class_type |> next_predefined get_predefined_ms_retain_release
|> next_predefined get_predefined_ms_stringWithUTF8String class_name |> next_predefined (get_predefined_ms_stringWithUTF8String class_name)
|> next_predefined get_predefined_ms_autoreleasepool_init class_name |> next_predefined (get_predefined_ms_autoreleasepool_init class_name)
|> next_predefined get_predefined_ms_is_kind_of_class class_name |> next_predefined (get_predefined_ms_is_kind_of_class class_name)
let dispatch_functions = [ let dispatch_functions = [
("_dispatch_once", 1); ("_dispatch_once", 1);

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

@ -310,7 +310,7 @@ let alloc_trans trans_state loc stmt_info function_type is_cf_non_null_alloc =
let objc_new_trans trans_state loc stmt_info cls_name function_type = let objc_new_trans trans_state loc stmt_info cls_name function_type =
let fname = SymExec.ModelBuiltins.__objc_alloc_no_fail in let fname = SymExec.ModelBuiltins.__objc_alloc_no_fail in
let (alloc_ret_type, alloc_ret_id, alloc_stmt_call, alloc_exp) = let (alloc_ret_type, alloc_ret_id, alloc_stmt_call, _) =
create_alloc_instrs trans_state.context loc function_type fname in create_alloc_instrs trans_state.context loc function_type fname in
let init_ret_id = Ident.create_fresh Ident.knormal in let init_ret_id = Ident.create_fresh Ident.knormal in
let is_instance = true in let is_instance = true in
@ -440,7 +440,7 @@ let trans_assume_false sil_loc context succ_nodes =
Cfg.Node.set_succs_exn prune_node succ_nodes []; Cfg.Node.set_succs_exn prune_node succ_nodes [];
{ empty_res_trans with root_nodes = [prune_node]; leaf_nodes = [prune_node] } { empty_res_trans with root_nodes = [prune_node]; leaf_nodes = [prune_node] }
let define_condition_side_effects context e_cond instrs_cond sil_loc = let define_condition_side_effects e_cond instrs_cond sil_loc =
let (e', typ) = extract_exp_from_list e_cond "\nWARNING: Missing expression in IfStmt. Need to be fixed\n" in let (e', typ) = extract_exp_from_list e_cond "\nWARNING: Missing expression in IfStmt. Need to be fixed\n" in
match e' with match e' with
| Sil.Lvar pvar -> | Sil.Lvar pvar ->
@ -575,7 +575,7 @@ let rec is_owning_method s =
let rec is_method_call s = let rec is_method_call s =
match s with match s with
| Clang_ast_t.ObjCMessageExpr (_, _ , _, mei) -> true | Clang_ast_t.ObjCMessageExpr _ -> true
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with | _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false | [] -> false
| s'':: _ -> is_method_call s'') | s'':: _ -> is_method_call s'')
@ -588,14 +588,14 @@ let get_info_from_decl_ref decl_ref =
let rec get_decl_ref_info s = let rec get_decl_ref_info s =
match s with match s with
| Clang_ast_t.DeclRefExpr (stmt_info, stmt_list, expr_info, decl_ref_expr_info) -> | Clang_ast_t.DeclRefExpr (_, _, _, decl_ref_expr_info) ->
(match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with (match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with
| Some decl_ref -> decl_ref | Some decl_ref -> decl_ref
| None -> assert false) | None -> assert false)
| _ -> | _ ->
match Clang_ast_proj.get_stmt_tuple s with match Clang_ast_proj.get_stmt_tuple s with
| stmt_info, [] -> assert false | _, [] -> assert false
| stmt_info, s'':: _ -> | _, s'':: _ ->
get_decl_ref_info s'' get_decl_ref_info s''
let rec contains_opaque_value_expr s = let rec contains_opaque_value_expr s =
@ -624,7 +624,7 @@ let is_dispatch_function stmt_list =
let s = name_info.Clang_ast_t.ni_name in let s = name_info.Clang_ast_t.ni_name in
(match (CTrans_models.is_dispatch_function_name s) with (match (CTrans_models.is_dispatch_function_name s) with
| None -> None | None -> None
| Some (dispatch_function, block_arg_pos) -> | Some (_, block_arg_pos) ->
try try
(match IList.nth stmts block_arg_pos with (match IList.nth stmts block_arg_pos with
| BlockExpr _ -> Some block_arg_pos | BlockExpr _ -> Some block_arg_pos

2
infer/src/clang/cTrans_utils.mli
Unescape View File

@ -55,7 +55,7 @@ val fix_param_exps_mismatch : 'a list -> (Sil.exp * Sil.typ) list -> (Sil.exp *
val get_selector_receiver : Clang_ast_t.obj_c_message_expr_info -> string * Clang_ast_t.receiver_kind val get_selector_receiver : Clang_ast_t.obj_c_message_expr_info -> string * Clang_ast_t.receiver_kind
val define_condition_side_effects : val define_condition_side_effects :
CContext.t -> (Sil.exp * Sil.typ) list -> Sil.instr list -> Location.t -> (Sil.exp * Sil.typ) list -> Sil.instr list -> Location.t ->
(Sil.exp * Sil.typ) list * Sil.instr list (Sil.exp * Sil.typ) list * Sil.instr list
val extract_stmt_from_singleton : Clang_ast_t.stmt list -> string -> Clang_ast_t.stmt val extract_stmt_from_singleton : Clang_ast_t.stmt list -> string -> Clang_ast_t.stmt

40
infer/src/clang/cType_to_sil_type.ml
Unescape View File

@ -68,7 +68,7 @@ and sil_type_of_attr_type translate_decl tenv type_info attr_info =
match type_info.Clang_ast_t.ti_desugared_type with match type_info.Clang_ast_t.ti_desugared_type with
| Some type_ptr -> | Some type_ptr ->
(match Ast_utils.get_type type_ptr with (match Ast_utils.get_type type_ptr with
| Some Clang_ast_t.ObjCObjectPointerType (type_info', type_ptr') -> | Some Clang_ast_t.ObjCObjectPointerType (_, type_ptr') ->
let typ = type_ptr_to_sil_type translate_decl tenv type_ptr' in let typ = type_ptr_to_sil_type translate_decl tenv type_ptr' in
Sil.Tptr (typ, pointer_attribute_of_objc_attribute attr_info) Sil.Tptr (typ, pointer_attribute_of_objc_attribute attr_info)
| _ -> type_ptr_to_sil_type translate_decl tenv type_ptr) | _ -> type_ptr_to_sil_type translate_decl tenv type_ptr)
@ -77,44 +77,44 @@ and sil_type_of_attr_type translate_decl tenv type_info attr_info =
and sil_type_of_c_type translate_decl tenv c_type = and sil_type_of_c_type translate_decl tenv c_type =
let open Clang_ast_t in let open Clang_ast_t in
match c_type with match c_type with
| NoneType (type_info) -> Sil.Tvoid | NoneType _ -> Sil.Tvoid
| BuiltinType (type_info, builtin_type_kind) -> | BuiltinType (_, builtin_type_kind) ->
sil_type_of_builtin_type_kind builtin_type_kind sil_type_of_builtin_type_kind builtin_type_kind
| PointerType (type_info, type_ptr) | PointerType (_, type_ptr)
| ObjCObjectPointerType (type_info, type_ptr) -> | ObjCObjectPointerType (_, type_ptr) ->
let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in
if Sil.typ_equal typ (get_builtin_objc_type `ObjCClass) then if Sil.typ_equal typ (get_builtin_objc_type `ObjCClass) then
typ typ
else Sil.Tptr (typ, Sil.Pk_pointer) else Sil.Tptr (typ, Sil.Pk_pointer)
| ObjCObjectType (type_info, objc_object_type_info) -> | ObjCObjectType (_, objc_object_type_info) ->
type_ptr_to_sil_type translate_decl tenv objc_object_type_info.Clang_ast_t.base_type type_ptr_to_sil_type translate_decl tenv objc_object_type_info.Clang_ast_t.base_type
| BlockPointerType (type_info, type_ptr) -> | BlockPointerType (_, type_ptr) ->
let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in
Sil.Tptr (typ, Sil.Pk_pointer) Sil.Tptr (typ, Sil.Pk_pointer)
| IncompleteArrayType (type_info, type_ptr) | IncompleteArrayType (_, type_ptr)
| DependentSizedArrayType (type_info, type_ptr) | DependentSizedArrayType (_, type_ptr)
| VariableArrayType (type_info, type_ptr) -> | VariableArrayType (_, type_ptr) ->
build_array_type translate_decl tenv type_ptr (-1) build_array_type translate_decl tenv type_ptr (-1)
| ConstantArrayType (type_info, type_ptr, n) -> | ConstantArrayType (_, type_ptr, n) ->
build_array_type translate_decl tenv type_ptr n build_array_type translate_decl tenv type_ptr n
| FunctionProtoType (type_info, function_type_info, _) | FunctionProtoType _
| FunctionNoProtoType (type_info, function_type_info) -> | FunctionNoProtoType _ ->
Sil.Tfun false Sil.Tfun false
| ParenType (type_info, type_ptr) -> | ParenType (_, type_ptr) ->
type_ptr_to_sil_type translate_decl tenv type_ptr type_ptr_to_sil_type translate_decl tenv type_ptr
| DecayedType (type_info, type_ptr) -> | DecayedType (_, type_ptr) ->
type_ptr_to_sil_type translate_decl tenv type_ptr type_ptr_to_sil_type translate_decl tenv type_ptr
| RecordType (type_info, pointer) | RecordType (_, pointer)
| EnumType (type_info, pointer) -> | EnumType (_, pointer) ->
decl_ptr_to_sil_type translate_decl tenv pointer decl_ptr_to_sil_type translate_decl tenv pointer
| ElaboratedType (type_info) -> | ElaboratedType (type_info) ->
(match type_info.Clang_ast_t.ti_desugared_type with (match type_info.Clang_ast_t.ti_desugared_type with
Some type_ptr -> type_ptr_to_sil_type translate_decl tenv type_ptr Some type_ptr -> type_ptr_to_sil_type translate_decl tenv type_ptr
| None -> Sil.Tvoid) | None -> Sil.Tvoid)
| ObjCInterfaceType (type_info, pointer) -> | ObjCInterfaceType (_, pointer) ->
decl_ptr_to_sil_type translate_decl tenv pointer decl_ptr_to_sil_type translate_decl tenv pointer
| RValueReferenceType (type_info, type_ptr) | RValueReferenceType (_, type_ptr)
| LValueReferenceType (type_info, type_ptr) -> | LValueReferenceType (_, type_ptr) ->
let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in
Sil.Tptr (typ, Sil.Pk_reference) Sil.Tptr (typ, Sil.Pk_reference)
| AttributedType (type_info, attr_info) -> | AttributedType (type_info, attr_info) ->

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

@ -44,7 +44,7 @@ let classname_of_type typ =
let search_enum_type_by_name tenv name = let search_enum_type_by_name tenv name =
let found = ref None in let found = ref None in
let mname = Mangled.from_string name in let mname = Mangled.from_string name in
let f tn typ = let f _ typ =
match typ with match typ with
| Sil.Tenum enum_constants -> | Sil.Tenum enum_constants ->
IList.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
@ -68,10 +68,10 @@ let is_class typ =
let rec return_type_of_function_type_ptr type_ptr = let rec return_type_of_function_type_ptr type_ptr =
let open Clang_ast_t in let open Clang_ast_t in
match Ast_utils.get_type type_ptr with match Ast_utils.get_type type_ptr with
| Some FunctionProtoType (type_info, function_type_info, _) | Some FunctionProtoType (_, function_type_info, _)
| Some FunctionNoProtoType (type_info, function_type_info) -> | Some FunctionNoProtoType (_, function_type_info) ->
function_type_info.Clang_ast_t.fti_return_type function_type_info.Clang_ast_t.fti_return_type
| Some BlockPointerType (type_info, in_type_ptr) -> | Some BlockPointerType (_, in_type_ptr) ->
return_type_of_function_type_ptr in_type_ptr return_type_of_function_type_ptr in_type_ptr
| Some _ -> | Some _ ->
Printing.log_err "Warning: Type pointer %s is not a function type." Printing.log_err "Warning: Type pointer %s is not a function type."
@ -108,7 +108,7 @@ let rec expand_structured_type tenv typ =
typ typ
else expand_structured_type tenv t else expand_structured_type tenv t
| None -> typ) | None -> typ)
| Sil.Tptr(t, _) -> typ (*do not expand types under pointers *) | Sil.Tptr _ -> typ (*do not expand types under pointers *)
| _ -> typ | _ -> typ
(* To be called with strings of format "<pointer_type_info>*<class_name>" *) (* To be called with strings of format "<pointer_type_info>*<class_name>" *)

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

@ -41,7 +41,7 @@ let add_predefined_objc_types tenv =
(* Whenever new type are added manually to the translation in ast_expressions, *) (* Whenever new type are added manually to the translation in ast_expressions, *)
(* they should be added here too!! *) (* they should be added here too!! *)
let add_predefined_basic_types tenv = let add_predefined_basic_types () =
let open Ast_expressions in let open Ast_expressions in
let add_basic_type tp basic_type_kind = let add_basic_type tp basic_type_kind =
let sil_type = CType_to_sil_type.sil_type_of_builtin_type_kind basic_type_kind in let sil_type = CType_to_sil_type.sil_type_of_builtin_type_kind basic_type_kind in
@ -71,16 +71,16 @@ let add_predefined_basic_types tenv =
let add_predefined_types tenv = let add_predefined_types tenv =
add_predefined_objc_types tenv; add_predefined_objc_types tenv;
add_predefined_basic_types tenv add_predefined_basic_types ()
let create_csu opt_type = let create_csu opt_type =
match opt_type with match opt_type with
| `Type s -> | `Type s ->
(let buf = Str.split (Str.regexp "[ \t]+") s in (let buf = Str.split (Str.regexp "[ \t]+") s in
match buf with match buf with
| "struct":: l ->Csu.Struct | "struct":: _ ->Csu.Struct
| "class":: l -> Csu.Class Csu.CPP | "class":: _ -> Csu.Class Csu.CPP
| "union":: l -> Csu.Union | "union":: _ -> Csu.Union
| _ -> Csu.Struct) | _ -> Csu.Struct)
| _ -> assert false | _ -> assert false
@ -90,8 +90,8 @@ let get_record_name_csu decl =
let name_info, csu = match decl with let name_info, csu = match decl with
| RecordDecl (_, name_info, opt_type, _, _, _, _) -> | RecordDecl (_, name_info, opt_type, _, _, _, _) ->
name_info, create_csu opt_type name_info, create_csu opt_type
| CXXRecordDecl (_, name_info, opt_type, _, _, _, _, _) | CXXRecordDecl (_, name_info, _, _, _, _, _, _)
| ClassTemplateSpecializationDecl (_, name_info, opt_type, _, _, _, _, _) -> | ClassTemplateSpecializationDecl (_, name_info, _, _, _, _, _, _) ->
(* we use Csu.Class for C++ because we expect Csu.Class csu from *) (* we use Csu.Class for C++ because we expect Csu.Class csu from *)
(* types that have methods. And in C++ struct/class/union can have methods *) (* types that have methods. And in C++ struct/class/union can have methods *)
name_info, Csu.Class Csu.CPP name_info, Csu.Class Csu.CPP
@ -101,12 +101,12 @@ let get_record_name_csu decl =
let get_record_name decl = snd (get_record_name_csu decl) let get_record_name decl = snd (get_record_name_csu decl)
let get_class_methods tenv class_name decl_list = let get_class_methods class_name decl_list =
let process_method_decl = function let process_method_decl = function
| Clang_ast_t.CXXMethodDecl (decl_info, name_info, tp, function_decl_info, _) | Clang_ast_t.CXXMethodDecl (_, name_info, tp, _, _)
| Clang_ast_t.CXXConstructorDecl (decl_info, name_info, tp, function_decl_info, _) | Clang_ast_t.CXXConstructorDecl (_, name_info, tp, _, _)
| Clang_ast_t.CXXConversionDecl (decl_info, name_info, tp, function_decl_info, _) | Clang_ast_t.CXXConversionDecl (_, name_info, tp, _, _)
| Clang_ast_t.CXXDestructorDecl (decl_info, name_info, tp, function_decl_info, _) -> | Clang_ast_t.CXXDestructorDecl (_, name_info, tp, _, _) ->
let method_name = name_info.Clang_ast_t.ni_name in let method_name = name_info.Clang_ast_t.ni_name in
Printing.log_out " ...Declaring method '%s'.\n" method_name; Printing.log_out " ...Declaring method '%s'.\n" method_name;
let method_proc = General_utils.mk_procname_from_cpp_method class_name method_name tp in let method_proc = General_utils.mk_procname_from_cpp_method class_name method_name tp in
@ -186,7 +186,7 @@ and get_struct_cpp_class_declaration_type tenv decl =
General_utils.append_no_duplicates_fields extra_fields non_static_fields in General_utils.append_no_duplicates_fields extra_fields non_static_fields in
let sorted_non_static_fields = General_utils.sort_fields non_static_fields' in let sorted_non_static_fields = General_utils.sort_fields non_static_fields' in
let static_fields = [] in (* Note: We treat static field same as global variables *) let static_fields = [] in (* Note: We treat static field same as global variables *)
let def_methods = get_class_methods tenv name decl_list in (* C++ methods only *) let def_methods = get_class_methods name decl_list in (* C++ methods only *)
let superclasses = get_superclass_list_cpp decl in let superclasses = get_superclass_list_cpp decl in
let sil_type = Sil.Tstruct { let sil_type = Sil.Tstruct {
Sil.instance_fields = sorted_non_static_fields; Sil.instance_fields = sorted_non_static_fields;

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

@ -58,7 +58,7 @@ let sil_var_of_decl_ref context decl_ref procname =
let add_var_to_locals procdesc var_decl sil_typ pvar = let add_var_to_locals procdesc var_decl sil_typ pvar =
let open Clang_ast_t in let open Clang_ast_t in
match var_decl with match var_decl with
| VarDecl (di, var_name, type_ptr, vdi) -> | VarDecl (_, _, _, vdi) ->
if not vdi.Clang_ast_t.vdi_is_global then if not vdi.Clang_ast_t.vdi_is_global then
Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, sil_typ)] Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, sil_typ)]
| _ -> assert false | _ -> assert false
@ -67,7 +67,7 @@ let rec compute_autorelease_pool_vars context stmts =
let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
match stmts with match stmts with
| [] -> [] | [] -> []
| Clang_ast_t.DeclRefExpr (si, sl, ei, drei):: stmts' -> | Clang_ast_t.DeclRefExpr (_, _, _, drei):: stmts' ->
(let res = compute_autorelease_pool_vars context stmts' in (let res = compute_autorelease_pool_vars context stmts' in
match drei.Clang_ast_t.drti_decl_ref with match drei.Clang_ast_t.drti_decl_ref with
| Some decl_ref -> | Some decl_ref ->

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

@ -52,15 +52,15 @@ let get_base_class_name_from_category decl =
let open Clang_ast_t in let open Clang_ast_t in
let base_class_pointer_opt = let base_class_pointer_opt =
match decl with match decl with
| ObjCCategoryDecl (decl_info, name_info, decl_list, decl_context_info, cdi) -> | ObjCCategoryDecl (_, _, _, _, cdi) ->
cdi.Clang_ast_t.odi_class_interface cdi.Clang_ast_t.odi_class_interface
| ObjCCategoryImplDecl (decl_info, name_info, decl_list, decl_context_info, cii) -> | ObjCCategoryImplDecl (_, _, _, _, cii) ->
cii.Clang_ast_t.ocidi_class_interface cii.Clang_ast_t.ocidi_class_interface
| _ -> None in | _ -> None in
match base_class_pointer_opt with match base_class_pointer_opt with
| Some decl_ref -> | Some decl_ref ->
(match Ast_utils.get_decl decl_ref.Clang_ast_t.dr_decl_pointer with (match Ast_utils.get_decl decl_ref.Clang_ast_t.dr_decl_pointer with
| Some ObjCInterfaceDecl (decl_info, name_info, decl_list, _, ocidi) -> | Some ObjCInterfaceDecl (_, name_info, _, _, _) ->
Some (Ast_utils.get_qualified_name name_info) Some (Ast_utils.get_qualified_name name_info)
| _ -> None) | _ -> None)
| None -> None | None -> None
@ -98,7 +98,7 @@ let process_category type_ptr_to_sil_type tenv curr_class decl_info decl_list =
let category_decl type_ptr_to_sil_type tenv decl = let category_decl type_ptr_to_sil_type tenv decl =
let open Clang_ast_t in let open Clang_ast_t in
match decl with match decl with
| ObjCCategoryDecl (decl_info, name_info, decl_list, decl_context_info, cdi) -> | ObjCCategoryDecl (decl_info, name_info, decl_list, _, cdi) ->
let name = Ast_utils.get_qualified_name name_info in let name = Ast_utils.get_qualified_name name_info in
let curr_class = get_curr_class_from_category_decl name cdi in let curr_class = get_curr_class_from_category_decl name cdi in
Printing.log_out "ADDING: ObjCCategoryDecl for '%s'\n" name; Printing.log_out "ADDING: ObjCCategoryDecl for '%s'\n" name;
@ -111,7 +111,7 @@ let category_decl type_ptr_to_sil_type tenv decl =
let category_impl_decl type_ptr_to_sil_type tenv decl = let category_impl_decl type_ptr_to_sil_type tenv decl =
let open Clang_ast_t in let open Clang_ast_t in
match decl with match decl with
| ObjCCategoryImplDecl (decl_info, name_info, decl_list, decl_context_info, cii) -> | ObjCCategoryImplDecl (decl_info, name_info, decl_list, _, cii) ->
let name = Ast_utils.get_qualified_name name_info in let name = Ast_utils.get_qualified_name name_info in
let curr_class = get_curr_class_from_category_impl name cii in let curr_class = get_curr_class_from_category_impl name cii in
Printing.log_out "ADDING: ObjCCategoryImplDecl for '%s'\n" name; Printing.log_out "ADDING: ObjCCategoryImplDecl for '%s'\n" name;

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

@ -87,7 +87,7 @@ let get_interface_superclasses super_opt protocols =
let super_classes = super_class@protocol_names in let super_classes = super_class@protocol_names in
super_classes super_classes
let create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list class_name let create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list
otdi_super otdi_protocols = otdi_super otdi_protocols =
let super = get_super_interface_decl otdi_super in let super = get_super_interface_decl otdi_super in
let protocols = get_protocols otdi_protocols in let protocols = get_protocols otdi_protocols in
@ -102,7 +102,7 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info class_name
let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in let decl_key = `DeclPtr decl_info.Clang_ast_t.di_pointer in
Ast_utils.update_sil_types_map decl_key (Sil.Tvar interface_name); Ast_utils.update_sil_types_map decl_key (Sil.Tvar interface_name);
let superclasses, fields = let superclasses, fields =
create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list class_name create_superclasses_fields type_ptr_to_sil_type tenv curr_class decl_list
ocidi.Clang_ast_t.otdi_super ocidi.Clang_ast_t.otdi_super
ocidi.Clang_ast_t.otdi_protocols in ocidi.Clang_ast_t.otdi_protocols in
let methods = ObjcProperty_decl.get_methods curr_class decl_list in let methods = ObjcProperty_decl.get_methods curr_class decl_list in
@ -123,7 +123,7 @@ let add_class_to_tenv type_ptr_to_sil_type tenv curr_class decl_info class_name
let fields = General_utils.append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in let fields = General_utils.append_no_duplicates_fields [Sil.objc_ref_counter_field] fields in
let fields = General_utils.sort_fields fields in let fields = General_utils.sort_fields fields in
Printing.log_out "Class %s field:\n" class_name; Printing.log_out "Class %s field:\n" class_name;
IList.iter (fun (fn, ft, _) -> IList.iter (fun (fn, _, _) ->
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields; Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
let interface_type_info = let interface_type_info =
Sil.Tstruct { Sil.Tstruct {
@ -151,8 +151,8 @@ let add_missing_methods tenv class_name ck decl_info decl_list curr_class =
(match Sil.tenv_lookup tenv class_tn_name with (match Sil.tenv_lookup tenv class_tn_name with
| Some Sil.Tstruct | Some Sil.Tstruct
({ Sil.static_fields = []; ({ Sil.static_fields = [];
csu = Csu.Class ck; csu = Csu.Class _;
struct_name = Some name; struct_name = Some _;
def_methods; def_methods;
} as struct_typ) -> } as struct_typ) ->
let methods = General_utils.append_no_duplicates_methods def_methods methods in let methods = General_utils.append_no_duplicates_methods def_methods methods in
@ -185,7 +185,7 @@ let interface_declaration type_ptr_to_sil_type tenv decl =
let interface_impl_declaration type_ptr_to_sil_type tenv decl = let interface_impl_declaration type_ptr_to_sil_type tenv decl =
let open Clang_ast_t in let open Clang_ast_t in
match decl with match decl with
| ObjCImplementationDecl (decl_info, name_info, decl_list, decl_context_info, idi) -> | ObjCImplementationDecl (decl_info, name_info, decl_list, _, idi) ->
let class_name = Ast_utils.get_qualified_name name_info in let class_name = Ast_utils.get_qualified_name name_info in
Printing.log_out "ADDING: ObjCImplementationDecl for class '%s'\n" class_name; Printing.log_out "ADDING: ObjCImplementationDecl for class '%s'\n" class_name;
let _ = add_class_decl type_ptr_to_sil_type tenv idi in let _ = add_class_decl type_ptr_to_sil_type tenv idi in

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

@ -28,7 +28,7 @@ let get_methods curr_class decl_list =
let class_name = CContext.get_curr_class_name curr_class in let class_name = CContext.get_curr_class_name curr_class in
let get_method decl list_methods = let get_method decl list_methods =
match decl with match decl with
| Clang_ast_t.ObjCMethodDecl (decl_info, name_info, method_decl_info) -> | Clang_ast_t.ObjCMethodDecl (_, name_info, method_decl_info) ->
let is_instance = method_decl_info.Clang_ast_t.omdi_is_instance_method in let is_instance = method_decl_info.Clang_ast_t.omdi_is_instance_method in
let method_kind = Procname.objc_method_kind_of_bool is_instance in let method_kind = Procname.objc_method_kind_of_bool is_instance in
let method_name = name_info.Clang_ast_t.ni_name in let method_name = name_info.Clang_ast_t.ni_name in

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

@ -49,5 +49,5 @@ let protocol_decl type_ptr_to_sil_type tenv decl =
let is_protocol decl = let is_protocol decl =
let open Clang_ast_t in let open Clang_ast_t in
match decl with match decl with
| ObjCProtocolDecl(decl_info, name_info, decl_list, _, obj_c_protocol_decl_info) -> true | ObjCProtocolDecl _ -> true
| _ -> false | _ -> false

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

@ -69,7 +69,7 @@ struct
| None -> () | None -> ()
let callback1 let callback1
find_canonical_duplicate calls_this checks get_proc_desc idenv tenv curr_pname find_canonical_duplicate calls_this checks get_proc_desc idenv curr_pname
curr_pdesc annotated_signature linereader proc_loc curr_pdesc annotated_signature linereader proc_loc
: bool * Extension.extension TypeState.t option = : bool * Extension.extension TypeState.t option =
let mk_pvar s = Sil.mk_pvar s curr_pname in let mk_pvar s = Sil.mk_pvar s curr_pname in
@ -100,7 +100,7 @@ struct
checks.TypeCheck.check_ret_type; checks.TypeCheck.check_ret_type;
if checks.TypeCheck.eradicate then if checks.TypeCheck.eradicate then
EradicateChecks.check_return_annotation EradicateChecks.check_return_annotation
find_canonical_duplicate curr_pname curr_pdesc exit_node ret_range find_canonical_duplicate curr_pname exit_node ret_range
ret_ia ret_implicitly_nullable loc in ret_ia ret_implicitly_nullable loc in
let do_before_dataflow initial_typestate = let do_before_dataflow initial_typestate =
@ -131,7 +131,7 @@ struct
(TypeState.pp Extension.ext) typestate_succ) (TypeState.pp Extension.ext) typestate_succ)
typestates_succ; typestates_succ;
typestates_succ, typestates_exn typestates_succ, typestates_exn
let proc_throws pn = DontKnow let proc_throws _ = DontKnow
end) in end) in
let initial_typestate = get_initial_typestate () in let initial_typestate = get_initial_typestate () in
do_before_dataflow initial_typestate; do_before_dataflow initial_typestate;
@ -181,7 +181,7 @@ struct
}, ref false in }, ref false in
callback1 callback1
find_canonical_duplicate calls_this' checks' get_proc_desc idenv_pn find_canonical_duplicate calls_this' checks' get_proc_desc idenv_pn
tenv pname pdesc ann_sig linereader loc in pname pdesc ann_sig linereader loc in
let module Initializers = struct let module Initializers = struct
type init = Procname.t * Cfg.Procdesc.t type init = Procname.t * Cfg.Procdesc.t
@ -201,8 +201,8 @@ struct
get_class_opt init_pn = get_class_opt callee_pn in get_class_opt init_pn = get_class_opt callee_pn in
is_private && same_class in is_private && same_class in
let private_called = PatternMatch.proc_calls let private_called = PatternMatch.proc_calls
Specs.proc_resolve_attributes init_pn init_pd filter in Specs.proc_resolve_attributes init_pd filter in
let do_called (callee_pn, callee_attributes) = let do_called (callee_pn, _) =
match get_proc_desc callee_pn with match get_proc_desc callee_pn with
| Some callee_pd -> | Some callee_pd ->
res := (callee_pn, callee_pd) :: !res res := (callee_pn, callee_pd) :: !res
@ -260,7 +260,7 @@ struct
(** Typestates after the current procedure and all initializer procedures. *) (** Typestates after the current procedure and all initializer procedures. *)
let final_initializer_typestates_lazy = lazy let final_initializer_typestates_lazy = lazy
begin begin
let is_initializer pname proc_attributes = let is_initializer proc_attributes =
PatternMatch.method_is_initializer tenv proc_attributes || PatternMatch.method_is_initializer tenv proc_attributes ||
let ia, _ = let ia, _ =
(Models.get_modelled_annotated_signature proc_attributes).Annotations.ret in (Models.get_modelled_annotated_signature proc_attributes).Annotations.ret in
@ -268,7 +268,7 @@ struct
let initializers_current_class = let initializers_current_class =
pname_and_pdescs_with pname_and_pdescs_with
(function (pname, proc_attributes) -> (function (pname, proc_attributes) ->
is_initializer pname proc_attributes && is_initializer proc_attributes &&
Procname.java_get_class pname = Procname.java_get_class curr_pname) in Procname.java_get_class pname = Procname.java_get_class curr_pname) in
final_typestates final_typestates
((curr_pname, curr_pdesc) :: initializers_current_class) ((curr_pname, curr_pdesc) :: initializers_current_class)
@ -279,7 +279,7 @@ struct
begin begin
let constructors_current_class = let constructors_current_class =
pname_and_pdescs_with pname_and_pdescs_with
(fun (pname, proc_attributes) -> (fun (pname, _) ->
Procname.is_constructor pname && Procname.is_constructor pname &&
Procname.java_get_class pname = Procname.java_get_class curr_pname) in Procname.java_get_class pname = Procname.java_get_class curr_pname) in
final_typestates constructors_current_class final_typestates constructors_current_class
@ -317,7 +317,7 @@ struct
do_final_typestate final_typestate_opt calls_this; do_final_typestate final_typestate_opt calls_this;
if checks.TypeCheck.eradicate then if checks.TypeCheck.eradicate then
EradicateChecks.check_overridden_annotations EradicateChecks.check_overridden_annotations
find_canonical_duplicate get_proc_desc find_canonical_duplicate
tenv curr_pname curr_pdesc tenv curr_pname curr_pdesc
annotated_signature; annotated_signature;
@ -367,9 +367,9 @@ struct
type extension = unit type extension = unit
let ext = let ext =
let empty = () in let empty = () in
let check_instr get_proc_desc proc_name proc_desc node ext instr param = ext in let check_instr _ _ _ ext _ _ = ext in
let join () () = () in let join () () = () in
let pp fmt () = () in let pp _ () = () in
{ {
TypeState.empty = empty; TypeState.empty = empty;
check_instr = check_instr; check_instr = check_instr;

20
infer/src/eradicate/eradicateChecks.ml
Unescape View File

@ -118,7 +118,7 @@ type from_call =
| From_containsKey (** x.containsKey *) | From_containsKey (** x.containsKey *)
(** Check the normalized "is zero" or "is not zero" condition of a prune instruction. *) (** Check the normalized "is zero" or "is not zero" condition of a prune instruction. *)
let check_condition case_zero find_canonical_duplicate get_proc_desc curr_pname let check_condition case_zero find_canonical_duplicate curr_pname
node e typ ta true_branch from_call idenv linereader loc instr_ref : unit = node e typ ta true_branch from_call idenv linereader loc instr_ref : unit =
let is_fun_nonnull ta = match TypeAnnotation.get_origin ta with let is_fun_nonnull ta = match TypeAnnotation.get_origin ta with
| TypeOrigin.Proc proc_origin -> | TypeOrigin.Proc proc_origin ->
@ -186,7 +186,7 @@ let check_nonzero find_canonical_duplicate = check_condition false find_canonica
(** Check an assignment to a field. *) (** Check an assignment to a field. *)
let check_field_assignment let check_field_assignment
find_canonical_duplicate curr_pname node instr_ref typestate exp_lhs find_canonical_duplicate curr_pname node instr_ref typestate exp_lhs
exp_rhs typ loc fname t_ia_opt typecheck_expr print_current_state : unit = exp_rhs typ loc fname t_ia_opt typecheck_expr : unit =
let (t_lhs, ta_lhs, _) = let (t_lhs, ta_lhs, _) =
typecheck_expr node instr_ref curr_pname typestate exp_lhs typecheck_expr node instr_ref curr_pname typestate exp_lhs
(typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.ONone, [loc]) loc in (typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.ONone, [loc]) loc in
@ -253,7 +253,7 @@ let check_constructor_initialization
then begin then begin
match PatternMatch.get_this_type (Cfg.Procdesc.get_attributes curr_pdesc) with match PatternMatch.get_this_type (Cfg.Procdesc.get_attributes curr_pdesc) with
| Some (Sil.Tptr (Sil.Tstruct { Sil.instance_fields; struct_name } as ts, _)) -> | Some (Sil.Tptr (Sil.Tstruct { Sil.instance_fields; struct_name } as ts, _)) ->
let do_field (fn, ft, ia) = let do_field (fn, ft, _) =
let annotated_with f = match get_field_annotation fn ts with let annotated_with f = match get_field_annotation fn ts with
| None -> false | None -> false
| Some (_, ia) -> f ia in | Some (_, ia) -> f ia in
@ -347,7 +347,7 @@ let spec_make_return_nullable curr_pname =
(** Check the annotations when returning from a method. *) (** Check the annotations when returning from a method. *)
let check_return_annotation let check_return_annotation
find_canonical_duplicate curr_pname curr_pdesc exit_node ret_range find_canonical_duplicate curr_pname exit_node ret_range
ret_ia ret_implicitly_nullable loc : unit = ret_ia ret_implicitly_nullable loc : unit =
let ret_annotated_nullable = Annotations.ia_is_nullable ret_ia in let ret_annotated_nullable = Annotations.ia_is_nullable ret_ia in
let ret_annotated_present = Annotations.ia_is_present ret_ia in let ret_annotated_present = Annotations.ia_is_present ret_ia in
@ -414,11 +414,10 @@ let check_call_receiver
typestate typestate
call_params call_params
callee_pname callee_pname
callee_loc
(instr_ref : TypeErr.InstrRef.t) (instr_ref : TypeErr.InstrRef.t)
loc loc
typecheck_expr typecheck_expr
print_current_state : unit = : unit =
match call_params with match call_params with
| ((original_this_e, this_e), typ) :: _ -> | ((original_this_e, this_e), typ) :: _ ->
let (_, this_ta, _) = let (_, this_ta, _) =
@ -447,8 +446,7 @@ let check_call_receiver
(** Check the parameters of a call. *) (** Check the parameters of a call. *)
let check_call_parameters let check_call_parameters
find_canonical_duplicate curr_pname node typestate callee_attributes find_canonical_duplicate curr_pname node typestate callee_attributes
sig_params call_params loc annotated_signature sig_params call_params loc instr_ref typecheck_expr : unit =
instr_ref typecheck_expr print_current_state : unit =
let callee_pname = callee_attributes.ProcAttributes.proc_name in let callee_pname = callee_attributes.ProcAttributes.proc_name in
let has_this = is_virtual sig_params in let has_this = is_virtual sig_params in
let tot_param_num = IList.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
@ -515,7 +513,7 @@ let check_call_parameters
(** Checks if the annotations are consistent with the inherited class or with the (** Checks if the annotations are consistent with the inherited class or with the
implemented interfaces *) implemented interfaces *)
let check_overridden_annotations let check_overridden_annotations
find_canonical_duplicate get_proc_desc tenv proc_name proc_desc annotated_signature = find_canonical_duplicate tenv proc_name proc_desc annotated_signature =
let start_node = Cfg.Procdesc.get_start_node proc_desc in let start_node = Cfg.Procdesc.get_start_node proc_desc in
let loc = Cfg.Node.get_loc start_node in let loc = Cfg.Node.get_loc start_node in
@ -537,8 +535,8 @@ let check_overridden_annotations
and check_params overriden_proc_name overriden_signature = and check_params overriden_proc_name overriden_signature =
let compare pos current_param overriden_param : int = let compare pos current_param overriden_param : int =
let current_name, current_ia, current_type = current_param in let current_name, current_ia, _ = current_param in
let _, overriden_ia, overriden_type = overriden_param in let _, overriden_ia, _ = overriden_param in
let () = let () =
if not (Annotations.ia_is_nullable current_ia) if not (Annotations.ia_is_nullable current_ia)
&& Annotations.ia_is_nullable overriden_ia then && Annotations.ia_is_nullable overriden_ia then

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

@ -48,7 +48,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]), "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"; 1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object";
] in ] in
IList.map (fun (x, y, z) -> (x, z)) list, IList.map (fun (x, y, z) -> (y, z)) list IList.map (fun (x, _, z) -> (x, z)) list, IList.map (fun (_, y, z) -> (y, z)) list
let check_state_list = let check_state_list =
[ [

93
infer/src/eradicate/typeCheck.ml
Unescape View File

@ -43,7 +43,7 @@ module ComplexExpressions = struct
let procname_optional_isPresent = Models.is_optional_isPresent let procname_optional_isPresent = Models.is_optional_isPresent
let procname_instanceof = Procname.equal SymExec.ModelBuiltins.__instanceof let procname_instanceof = Procname.equal SymExec.ModelBuiltins.__instanceof
let procname_is_false_on_null get_proc_desc pn = let procname_is_false_on_null pn =
match Specs.proc_resolve_attributes pn with match Specs.proc_resolve_attributes pn with
| Some proc_attributes -> | Some proc_attributes ->
let annotated_signature = let annotated_signature =
@ -53,7 +53,7 @@ module ComplexExpressions = struct
| None -> | None ->
false false
let procname_is_true_on_null get_proc_desc pn = let procname_is_true_on_null pn =
let annotated_true_on_null () = let annotated_true_on_null () =
match Specs.proc_resolve_attributes pn with match Specs.proc_resolve_attributes pn with
| Some proc_attributes -> | Some proc_attributes ->
@ -102,8 +102,8 @@ module ComplexExpressions = struct
pp_to_string (Sil.pp_const pe_text) c pp_to_string (Sil.pp_const pe_text) c
| Sil.Dderef de -> | Sil.Dderef de ->
dexp_to_string de dexp_to_string de
| Sil.Dfcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual }) | Sil.Dfcall (fun_dexp, args, _, { Sil.cf_virtual = isvirtual })
| Sil.Dretcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual }) | Sil.Dretcall (fun_dexp, args, _, { Sil.cf_virtual = isvirtual })
when functions_idempotent () -> when functions_idempotent () ->
let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in
let pp_args fmt des = (pp_comma_seq) pp_arg fmt des in let pp_args fmt des = (pp_comma_seq) pp_arg fmt des in
@ -117,13 +117,13 @@ module ComplexExpressions = struct
| Sil.Dpvar pv | Sil.Dpvar pv
| Sil.Dpvaraddr pv when not (Errdesc.pvar_is_frontend_tmp pv) -> | Sil.Dpvaraddr pv when not (Errdesc.pvar_is_frontend_tmp pv) ->
Sil.pvar_to_string pv Sil.pvar_to_string pv
| Sil.Dpvar pv | Sil.Dpvar _
| Sil.Dpvaraddr pv (* front-end variable -- this should not happen) *) -> | Sil.Dpvaraddr _ (* front-end variable -- this should not happen) *) ->
case_not_handled () case_not_handled ()
| Sil.Dunop (op, de) -> | Sil.Dunop (op, de) ->
Sil.str_unop op ^ dexp_to_string de Sil.str_unop op ^ dexp_to_string de
| Sil.Dsizeof (typ, sub) -> | Sil.Dsizeof _ ->
case_not_handled () case_not_handled ()
| Sil.Dunknown -> | Sil.Dunknown ->
case_not_handled () in case_not_handled () in
@ -180,7 +180,7 @@ let rec typecheck_expr
find_canonical_duplicate visited checks find_canonical_duplicate visited checks
node instr_ref curr_pname node instr_ref curr_pname
typestate e1 tr_default loc typestate e1 tr_default loc
| Sil.Const c -> | Sil.Const _ ->
let (typ, _, locs) = tr_default in let (typ, _, locs) = tr_default in
(typ, TypeAnnotation.const Annotations.Nullable false (TypeOrigin.Const loc), locs) (typ, TypeAnnotation.const Annotations.Nullable false (TypeOrigin.Const loc), locs)
| Sil.Lfield (exp, fn, typ) -> | Sil.Lfield (exp, fn, typ) ->
@ -238,16 +238,16 @@ let rec typecheck_expr
(** Typecheck an instruction. *) (** Typecheck an instruction. *)
let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc curr_pname let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc curr_pname
curr_pdesc find_canonical_duplicate annotated_signature instr_ref linereader typestate instr = curr_pdesc find_canonical_duplicate annotated_signature instr_ref linereader typestate instr =
let print_current_state () = (* let print_current_state () = *)
L.stdout "Current Typestate in node %a@\n%a@." (* L.stdout "Current Typestate in node %a@\n%a@." *)
Cfg.Node.pp (TypeErr.InstrRef.get_node instr_ref) (* Cfg.Node.pp (TypeErr.InstrRef.get_node instr_ref) *)
(TypeState.pp ext) typestate; (* (TypeState.pp ext) typestate; *)
L.stdout " %a@." (Sil.pp_instr pe_text) instr in (* L.stdout " %a@." (Sil.pp_instr pe_text) instr in *)
(** Handle the case where a field access X.f happens via a temporary variable $Txxx. (** Handle the case where a field access X.f happens via a temporary variable $Txxx.
This has been observed in assignments this.f = exp when exp contains an ifthenelse. This has been observed in assignments this.f = exp when exp contains an ifthenelse.
Reconstuct the original expression knowing: the origin of $Txxx is 'this'. *) Reconstuct the original expression knowing: the origin of $Txxx is 'this'. *)
let handle_field_access_via_temporary typestate exp loc = let handle_field_access_via_temporary typestate exp =
let name_is_temporary name = let name_is_temporary name =
let prefix = "$T" in let prefix = "$T" in
Utils.string_is_prefix prefix name in Utils.string_is_prefix prefix name in
@ -278,11 +278,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(** Convert a complex expressions into a pvar. (** Convert a complex expressions into a pvar.
When [is_assigment] is true, update the relevant annotations for the pvar. *) When [is_assigment] is true, update the relevant annotations for the pvar. *)
let convert_complex_exp_to_pvar node' is_assignment _exp typestate loc = let convert_complex_exp_to_pvar node' is_assignment _exp typestate loc =
let exp = let exp = handle_field_access_via_temporary typestate (Idenv.expand_expr idenv _exp) in
handle_field_access_via_temporary
typestate
(Idenv.expand_expr idenv _exp)
loc in
let default = exp, typestate in let default = exp, typestate in
(* If this is an assignment, update the typestate for a field access pvar. *) (* If this is an assignment, update the typestate for a field access pvar. *)
@ -342,14 +338,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> default | _ -> default
end end
| Sil.Lvar pvar -> | Sil.Lvar _ ->
default default
| Sil.Lfield (_exp, fn, typ) when ComplexExpressions.parameter_and_static_field () -> | Sil.Lfield (_exp, fn, typ) when ComplexExpressions.parameter_and_static_field () ->
let exp' = Idenv.expand_expr_temps idenv node _exp in let exp' = Idenv.expand_expr_temps idenv node _exp in
let is_parameter_field pvar = (* parameter.field *) let is_parameter_field pvar = (* parameter.field *)
let name = Sil.pvar_get_name pvar in let name = Sil.pvar_get_name pvar in
let filter (s, ia, typ) = Mangled.equal s name in let filter (s, _, _) = Mangled.equal s name in
IList.exists filter annotated_signature.Annotations.params in IList.exists filter annotated_signature.Annotations.params in
let is_static_field pvar = (* static field *) let is_static_field pvar = (* static field *)
@ -365,7 +361,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let pvar = Sil.mk_pvar (Mangled.from_string fld_name) curr_pname in let pvar = Sil.mk_pvar (Mangled.from_string fld_name) curr_pname in
let typestate' = update_typestate_fld pvar fn typ in let typestate' = update_typestate_fld pvar fn typ in
(Sil.Lvar pvar, typestate') (Sil.Lvar pvar, typestate')
| Sil.Lfield (_exp', fn', typ') when Ident.java_fieldname_is_outer_instance fn' -> | Sil.Lfield (_exp', fn', _) when Ident.java_fieldname_is_outer_instance fn' ->
(** handle double dereference when accessing a field from an outer class *) (** handle double dereference when accessing a field from an outer class *)
let fld_name = Ident.fieldname_to_string fn' ^ "_" ^ Ident.fieldname_to_string fn in let fld_name = Ident.fieldname_to_string fn' ^ "_" ^ Ident.fieldname_to_string fn in
let pvar = Sil.mk_pvar (Mangled.from_string fld_name) curr_pname in let pvar = Sil.mk_pvar (Mangled.from_string fld_name) curr_pname in
@ -396,12 +392,12 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let pname = proc_attributes.ProcAttributes.proc_name in let pname = proc_attributes.ProcAttributes.proc_name in
if Procname.is_constructor pname then if Procname.is_constructor pname then
match PatternMatch.get_this_type proc_attributes with match PatternMatch.get_this_type proc_attributes with
| Some this_type -> | Some _ ->
begin begin
constructor_check_calls_this calls_this pname; constructor_check_calls_this calls_this pname;
(* Drop reference parameters to this and outer objects. *) (* Drop reference parameters to this and outer objects. *)
let is_hidden_parameter (n, t) = let is_hidden_parameter (n, _) =
let n_str = Mangled.to_string n in let n_str = Mangled.to_string n in
n_str = "this" || n_str = "this" ||
Str.string_match (Str.regexp "$bcvar[0-9]+") n_str 0 in Str.string_match (Str.regexp "$bcvar[0-9]+") n_str 0 in
@ -468,7 +464,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
ignore (typecheck_expr_simple typestate1 exp1 Sil.Tvoid TypeOrigin.Undef loc1) in ignore (typecheck_expr_simple typestate1 exp1 Sil.Tvoid TypeOrigin.Undef loc1) in
match instr with match instr with
| Sil.Remove_temps (idl, loc) -> | Sil.Remove_temps (idl, _) ->
if remove_temps then IList.fold_right TypeState.remove_id idl typestate if remove_temps then IList.fold_right TypeState.remove_id idl typestate
else typestate else typestate
| Sil.Declare_locals _ | Sil.Declare_locals _
@ -480,7 +476,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
TypeState.add_id id TypeState.add_id id
(typecheck_expr_simple typestate' e' typ TypeOrigin.Undef loc) (typecheck_expr_simple typestate' e' typ TypeOrigin.Undef loc)
typestate' typestate'
| Sil.Set (Sil.Lvar pvar, typ, Sil.Const (Sil.Cexn _), loc) when pvar_is_return pvar -> | Sil.Set (Sil.Lvar pvar, _, Sil.Const (Sil.Cexn _), _) when pvar_is_return pvar ->
(* skip assignment to return variable where it is an artifact of a throw instruction *) (* skip assignment to return variable where it is an artifact of a throw instruction *)
typestate typestate
| Sil.Set (e1, typ, e2, loc) -> | Sil.Set (e1, typ, e2, loc) ->
@ -494,7 +490,6 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
find_canonical_duplicate curr_pname node find_canonical_duplicate curr_pname node
instr_ref typestate1 e1' e2 typ loc fn t_ia_opt instr_ref typestate1 e1' e2 typ loc fn t_ia_opt
(typecheck_expr find_canonical_duplicate calls_this checks) (typecheck_expr find_canonical_duplicate calls_this checks)
print_current_state
| _ -> () in | _ -> () in
let typestate2 = let typestate2 =
match e1' with match e1' with
@ -503,7 +498,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
pvar pvar
(typecheck_expr_simple typestate1 e2 typ TypeOrigin.Undef loc) (typecheck_expr_simple typestate1 e2 typ TypeOrigin.Undef loc)
typestate1 typestate1
| Sil.Lfield (_, fn, styp) -> | Sil.Lfield _ ->
typestate1 typestate1
| _ -> | _ ->
typestate1 in typestate1 in
@ -567,7 +562,6 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
match Specs.proc_resolve_attributes (* AttributesTable.load_attributes *) callee_pname with match Specs.proc_resolve_attributes (* AttributesTable.load_attributes *) callee_pname with
| Some proc_attributes -> proc_attributes | Some proc_attributes -> proc_attributes
| None -> assert false in | None -> assert false in
let callee_loc = callee_attributes.ProcAttributes.loc in
let etl = drop_unchecked_params calls_this callee_attributes _etl in let etl = drop_unchecked_params calls_this callee_attributes _etl in
let call_params, typestate1 = let call_params, typestate1 =
@ -614,7 +608,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let clear_nullable_flag typestate'' pvar = let clear_nullable_flag typestate'' pvar =
(* remove the nullable flag for the given pvar *) (* remove the nullable flag for the given pvar *)
match TypeState.lookup_pvar pvar typestate'' with match TypeState.lookup_pvar pvar typestate'' with
| Some (t, ta, locs) -> | Some (t, ta, _) ->
let should_report = let should_report =
EradicateChecks.activate_condition_redundant && EradicateChecks.activate_condition_redundant &&
TypeAnnotation.get_value Annotations.Nullable ta = false && TypeAnnotation.get_value Annotations.Nullable ta = false &&
@ -642,14 +636,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> None in | _ -> None in
match find_parameter parameter_num call_params with match find_parameter parameter_num call_params with
| Some (pvar, typ) -> | Some (pvar, _) ->
if is_vararg if is_vararg
then then
let do_vararg_value e ts = match Idenv.expand_expr idenv e with let do_vararg_value e ts = match Idenv.expand_expr idenv e with
| Sil.Lvar pvar1 -> | Sil.Lvar pvar1 ->
pvar_apply loc clear_nullable_flag ts pvar1 pvar_apply loc clear_nullable_flag ts pvar1
| _ -> ts in | _ -> ts in
let vararg_values = PatternMatch.java_get_vararg_values node pvar idenv curr_pdesc in let vararg_values = PatternMatch.java_get_vararg_values node pvar idenv in
IList.fold_right do_vararg_value vararg_values typestate' IList.fold_right do_vararg_value vararg_values typestate'
else else
pvar_apply loc clear_nullable_flag typestate' pvar pvar_apply loc clear_nullable_flag typestate' pvar
@ -693,7 +687,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
set_flag pvar' Annotations.Present true set_flag pvar' Annotations.Present true
| _ -> () in | _ -> () in
match call_params with match call_params with
| ((_, Sil.Lvar pvar), typ):: _ -> | ((_, Sil.Lvar pvar), _):: _ ->
(* temporary variable for the value of the boolean condition *) (* temporary variable for the value of the boolean condition *)
begin begin
let curr_node = TypeErr.InstrRef.get_node instr_ref in let curr_node = TypeErr.InstrRef.get_node instr_ref in
@ -711,7 +705,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
() ()
| Some (node', id) -> | Some (node', id) ->
let () = match Errdesc.find_normal_variable_funcall node' id with let () = match Errdesc.find_normal_variable_funcall node' id with
| Some (Sil.Const (Sil.Cfun pn), [e], loc, call_flags) | Some (Sil.Const (Sil.Cfun pn), [e], _, _)
when ComplexExpressions.procname_optional_isPresent pn -> when ComplexExpressions.procname_optional_isPresent pn ->
handle_optional_isPresent node' e handle_optional_isPresent node' e
| _ -> () in | _ -> () in
@ -733,8 +727,8 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
object_t) object_t)
parameters in parameters in
match call_params with match call_params with
| ((_, Sil.Lvar pv_map), typ_map) :: | ((_, Sil.Lvar pv_map), _) ::
((_, exp_key), typ_key) :: ((_, exp_key), _) ::
((_, exp_value), typ_value) :: _ -> ((_, exp_value), typ_value) :: _ ->
(* Convert the dexp for k to the dexp for m.get(k) *) (* Convert the dexp for k to the dexp for m.get(k) *)
let convert_dexp_key_to_dexp_get = function let convert_dexp_key_to_dexp_get = function
@ -779,11 +773,9 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
typestate1 typestate1
call_params call_params
callee_pname callee_pname
callee_loc
instr_ref instr_ref
loc loc
(typecheck_expr find_canonical_duplicate calls_this checks) (typecheck_expr find_canonical_duplicate calls_this checks);
print_current_state;
if checks.eradicate then if checks.eradicate then
EradicateChecks.check_call_parameters EradicateChecks.check_call_parameters
find_canonical_duplicate find_canonical_duplicate
@ -794,18 +786,15 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
signature_params signature_params
call_params call_params
loc loc
annotated_signature
instr_ref instr_ref
(typecheck_expr find_canonical_duplicate calls_this checks) (typecheck_expr find_canonical_duplicate calls_this checks);
print_current_state;
let typestate2 = let typestate2 =
if checks.check_extension then if checks.check_extension then
let etl' = IList.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 = TypeState.get_extension typestate1 in
let extension' = let extension' =
ext.TypeState.check_instr ext.TypeState.check_instr
get_proc_desc curr_pname curr_pdesc node get_proc_desc curr_pname curr_pdesc extension instr etl' in
extension instr etl' in
TypeState.set_extension typestate1 extension' TypeState.set_extension typestate1 extension'
else typestate1 in else typestate1 in
if Models.is_check_not_null callee_pname then if Models.is_check_not_null callee_pname then
@ -833,7 +822,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
do_return loc typestate2 do_return loc typestate2
| Sil.Call _ -> | Sil.Call _ ->
typestate typestate
| Sil.Prune (cond, loc, true_branch, ik) -> | Sil.Prune (cond, loc, true_branch, _) ->
let rec check_condition node' c : _ TypeState.t = let rec check_condition node' c : _ TypeState.t =
(* check if the expression is coming from a call, and return the argument *) (* check if the expression is coming from a call, and return the argument *)
let from_call filter_callee e : Sil.exp option = let from_call filter_callee e : Sil.exp option =
@ -841,7 +830,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| Sil.Var id -> | Sil.Var id ->
begin begin
match Errdesc.find_normal_variable_funcall node' id with match Errdesc.find_normal_variable_funcall node' id with
| Some (Sil.Const (Sil.Cfun pn), e1:: _, loc, call_flags) when | Some (Sil.Const (Sil.Cfun pn), e1:: _, _, _) when
filter_callee pn -> filter_callee pn ->
Some e1 Some e1
| _ -> None | _ -> None
@ -858,11 +847,11 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(* check if the expression is coming from a procedure returning false on null *) (* check if the expression is coming from a procedure returning false on null *)
let from_is_false_on_null e : Sil.exp option = let from_is_false_on_null e : Sil.exp option =
from_call (ComplexExpressions.procname_is_false_on_null get_proc_desc) e in from_call ComplexExpressions.procname_is_false_on_null e in
(* check if the expression is coming from a procedure returning true on null *) (* check if the expression is coming from a procedure returning true on null *)
let from_is_true_on_null e : Sil.exp option = let from_is_true_on_null e : Sil.exp option =
from_call (ComplexExpressions.procname_is_true_on_null get_proc_desc) e in from_call ComplexExpressions.procname_is_true_on_null e in
(* check if the expression is coming from Map.containsKey *) (* check if the expression is coming from Map.containsKey *)
let from_containsKey e : Sil.exp option = let from_containsKey e : Sil.exp option =
@ -925,7 +914,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
if checks.eradicate then if checks.eradicate then
EradicateChecks.check_zero EradicateChecks.check_zero
find_canonical_duplicate get_proc_desc curr_pname find_canonical_duplicate curr_pname
node' e' typ node' e' typ
ta true_branch EradicateChecks.From_condition ta true_branch EradicateChecks.From_condition
idenv linereader loc instr_ref; idenv linereader loc instr_ref;
@ -959,7 +948,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| None -> | None ->
begin begin
match from_containsKey e with match from_containsKey e with
| Some e1 when ComplexExpressions.functions_idempotent () -> | Some _ when ComplexExpressions.functions_idempotent () ->
handle_containsKey e handle_containsKey e
| _ -> | _ ->
typestate, e, EradicateChecks.From_condition typestate, e, EradicateChecks.From_condition
@ -971,7 +960,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
typecheck_expr_simple typestate2 e' Sil.Tvoid TypeOrigin.ONone loc in typecheck_expr_simple typestate2 e' Sil.Tvoid TypeOrigin.ONone loc in
if checks.eradicate then if checks.eradicate then
EradicateChecks.check_nonzero find_canonical_duplicate get_proc_desc curr_pname EradicateChecks.check_nonzero find_canonical_duplicate curr_pname
node e' typ ta true_branch from_call idenv linereader loc instr_ref; node e' typ ta true_branch from_call idenv linereader loc instr_ref;
begin begin
match from_call with match from_call with
@ -1020,7 +1009,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let node', c1' = normalize_cond _node c1 in let node', c1' = normalize_cond _node c1 in
let node'', c2' = normalize_cond node' c2 in let node'', c2' = normalize_cond node' c2 in
node'', Sil.BinOp (bop, c1', c2') node'', Sil.BinOp (bop, c1', c2')
| Sil.Var id -> | Sil.Var _ ->
let c' = Idenv.expand_expr idenv _cond in let c' = Idenv.expand_expr idenv _cond in
if not (Sil.exp_equal c' _cond) then normalize_cond _node c' if not (Sil.exp_equal c' _cond) then normalize_cond _node c'
else _node, c' else _node, c'

47
infer/src/eradicate/typeErr.ml
Unescape View File

@ -35,8 +35,8 @@ struct
let equal (n1, i1) (n2, i2) = let equal (n1, i1) (n2, i2) =
Cfg.Node.equal n1 n2 && i1 = i2 Cfg.Node.equal n1 n2 && i1 = i2
let hash (n, i) = Hashtbl.hash (Cfg.Node.hash n, i) let hash (n, i) = Hashtbl.hash (Cfg.Node.hash n, i)
let get_node (n, i) = n let get_node (n, _) = n
let replace_node (n, i) n' = (n', i) let replace_node (_, i) n' = (n', i)
let create_generator n = (n, ref 0) let create_generator n = (n, ref 0)
let gen instr_ref_gen = let gen instr_ref_gen =
let (node, ir) = instr_ref_gen in let (node, ir) = instr_ref_gen in
@ -88,11 +88,12 @@ module H = Hashtbl.Make(struct
Procname.equal pn1 pn2 Procname.equal pn1 pn2
| Field_not_initialized (_, _), _ | Field_not_initialized (_, _), _
| _, Field_not_initialized (_, _) -> false | _, Field_not_initialized (_, _) -> false
| Field_not_mutable (fn1, od1), Field_not_mutable (fn2, od2) -> | Field_not_mutable (fn1, _), Field_not_mutable (fn2, _) ->
Ident.fieldname_equal fn1 fn2 Ident.fieldname_equal fn1 fn2
| Field_not_mutable _, _ | Field_not_mutable _, _
| _, Field_not_mutable _ -> false | _, Field_not_mutable _ -> false
| Field_annotation_inconsistent (ann1, fn1, od1), Field_annotation_inconsistent (ann2, fn2, od2) -> | Field_annotation_inconsistent (ann1, fn1, _),
Field_annotation_inconsistent (ann2, fn2, _) ->
ann1 = ann2 && ann1 = ann2 &&
Ident.fieldname_equal fn1 fn2 Ident.fieldname_equal fn1 fn2
| Field_annotation_inconsistent _, _ | Field_annotation_inconsistent _, _
@ -102,21 +103,21 @@ module H = Hashtbl.Make(struct
Procname.equal pn1 pn2 Procname.equal pn1 pn2
| Field_over_annotated (_, _), _ | Field_over_annotated (_, _), _
| _, Field_over_annotated (_, _) -> false | _, Field_over_annotated (_, _) -> false
| Null_field_access (so1, fn1, od1, ii1), Null_field_access (so2, fn2, od2, ii2) -> | Null_field_access (so1, fn1, _, ii1), Null_field_access (so2, fn2, _, ii2) ->
(opt_equal string_equal) so1 so2 && (opt_equal string_equal) so1 so2 &&
Ident.fieldname_equal fn1 fn2 && Ident.fieldname_equal fn1 fn2 &&
bool_equal ii1 ii2 bool_equal ii1 ii2
| Null_field_access _, _ | Null_field_access _, _
| _, Null_field_access _ -> false | _, Null_field_access _ -> false
| Call_receiver_annotation_inconsistent (ann1, so1, pn1, od1), | Call_receiver_annotation_inconsistent (ann1, so1, pn1, _),
Call_receiver_annotation_inconsistent (ann2, so2, pn2, od2) -> Call_receiver_annotation_inconsistent (ann2, so2, pn2, _) ->
ann1 = ann2 && ann1 = ann2 &&
(opt_equal string_equal) so1 so2 && (opt_equal string_equal) so1 so2 &&
Procname.equal pn1 pn2 Procname.equal pn1 pn2
| Call_receiver_annotation_inconsistent _, _ | Call_receiver_annotation_inconsistent _, _
| _, Call_receiver_annotation_inconsistent _ -> false | _, Call_receiver_annotation_inconsistent _ -> false
| Parameter_annotation_inconsistent (ann1, s1, n1, pn1, cl1, od1), | Parameter_annotation_inconsistent (ann1, s1, n1, pn1, cl1, _),
Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, od2) -> Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, _) ->
ann1 = ann2 && ann1 = ann2 &&
string_equal s1 s2 && string_equal s1 s2 &&
int_equal n1 n2 && int_equal n1 n2 &&
@ -124,8 +125,8 @@ module H = Hashtbl.Make(struct
Location.equal cl1 cl2 Location.equal cl1 cl2
| Parameter_annotation_inconsistent _, _ | Parameter_annotation_inconsistent _, _
| _, Parameter_annotation_inconsistent _ -> false | _, Parameter_annotation_inconsistent _ -> false
| Return_annotation_inconsistent (ann1, pn1, od1), | Return_annotation_inconsistent (ann1, pn1, _),
Return_annotation_inconsistent (ann2, pn2, od2) -> Return_annotation_inconsistent (ann2, pn2, _) ->
ann1 = ann2 && Procname.equal pn1 pn2 ann1 = ann2 && Procname.equal pn1 pn2
| Return_annotation_inconsistent _, _ | Return_annotation_inconsistent _, _
| _, Return_annotation_inconsistent _ -> false | _, Return_annotation_inconsistent _ -> false
@ -158,19 +159,19 @@ module H = Hashtbl.Make(struct
Hashtbl.hash (1, b, string_opt_hash so, nn) Hashtbl.hash (1, b, string_opt_hash so, nn)
| Field_not_initialized (fn, pn) -> | Field_not_initialized (fn, pn) ->
Hashtbl.hash (2, string_hash ((Ident.fieldname_to_string fn) ^ (Procname.to_string pn))) Hashtbl.hash (2, string_hash ((Ident.fieldname_to_string fn) ^ (Procname.to_string pn)))
| Field_not_mutable (fn, od) -> | Field_not_mutable (fn, _) ->
Hashtbl.hash (3, string_hash (Ident.fieldname_to_string fn)) Hashtbl.hash (3, string_hash (Ident.fieldname_to_string fn))
| Field_annotation_inconsistent (ann, fn, od) -> | Field_annotation_inconsistent (ann, fn, _) ->
Hashtbl.hash (4, ann, string_hash (Ident.fieldname_to_string fn)) Hashtbl.hash (4, ann, string_hash (Ident.fieldname_to_string fn))
| Field_over_annotated (fn, pn) -> | Field_over_annotated (fn, pn) ->
Hashtbl.hash (5, string_hash ((Ident.fieldname_to_string fn) ^ (Procname.to_string pn))) Hashtbl.hash (5, string_hash ((Ident.fieldname_to_string fn) ^ (Procname.to_string pn)))
| Null_field_access (so, fn, od, ii) -> | Null_field_access (so, fn, _, _) ->
Hashtbl.hash (6, string_opt_hash so, string_hash (Ident.fieldname_to_string fn)) Hashtbl.hash (6, string_opt_hash so, string_hash (Ident.fieldname_to_string fn))
| Call_receiver_annotation_inconsistent (ann, so, pn, od) -> | Call_receiver_annotation_inconsistent (ann, so, pn, _) ->
Hashtbl.hash (7, ann, string_opt_hash so, Procname.hash_pname pn) Hashtbl.hash (7, ann, string_opt_hash so, Procname.hash_pname pn)
| Parameter_annotation_inconsistent (ann, s, n, pn, cl, od) -> | Parameter_annotation_inconsistent (ann, s, n, pn, _, _) ->
Hashtbl.hash (8, ann, string_hash s, n, Procname.hash_pname pn) Hashtbl.hash (8, ann, string_hash s, n, Procname.hash_pname pn)
| Return_annotation_inconsistent (ann, pn, od) -> | Return_annotation_inconsistent (ann, pn, _) ->
Hashtbl.hash (9, ann, Procname.hash_pname pn) Hashtbl.hash (9, ann, Procname.hash_pname pn)
| Return_over_annotated pn -> | Return_over_annotated pn ->
Hashtbl.hash (10, Procname.hash_pname pn) Hashtbl.hash (10, Procname.hash_pname pn)
@ -302,9 +303,7 @@ type st_report_error =
unit unit
(** Report an error right now. *) (** Report an error right now. *)
let report_error_now let report_error_now (st_report_error : st_report_error) node err_instance loc proc_name : unit =
(st_report_error : st_report_error)
node err_instance instr_ref_opt loc proc_name : unit =
let demo_mode = true in let demo_mode = true in
let do_print_base ew_string kind_s s = let do_print_base ew_string kind_s s =
L.stdout "%s %s in %s %s@." ew_string kind_s (Procname.java_get_method proc_name) s in L.stdout "%s %s in %s %s@." ew_string kind_s (Procname.java_get_method proc_name) s in
@ -423,7 +422,7 @@ let report_error_now
None, None,
None, None,
origin_loc origin_loc
| Parameter_annotation_inconsistent (ann, s, n, pn, callee_loc, (origin_desc, origin_loc, _)) -> | Parameter_annotation_inconsistent (ann, s, n, pn, _, (origin_desc, origin_loc, _)) ->
let kind_s, description = match ann with let kind_s, description = match ann with
| Annotations.Nullable -> | Annotations.Nullable ->
"ERADICATE_PARAMETER_NOT_NULLABLE", "ERADICATE_PARAMETER_NOT_NULLABLE",
@ -524,8 +523,7 @@ let report_error st_report_error find_canonical_duplicate node
let should_report_now = let should_report_now =
add_err find_canonical_duplicate err_instance instr_ref_opt loc in add_err find_canonical_duplicate err_instance instr_ref_opt loc in
if should_report_now then if should_report_now then
report_error_now report_error_now st_report_error node err_instance loc proc_name
st_report_error node err_instance instr_ref_opt loc proc_name
(** Report the forall checks at the end of the analysis and reset the error table *) (** Report the forall checks at the end of the analysis and reset the error table *)
let report_forall_checks_and_reset st_report_error proc_name = let report_forall_checks_and_reset st_report_error proc_name =
@ -535,8 +533,7 @@ let report_forall_checks_and_reset st_report_error proc_name =
let node = InstrRef.get_node instr_ref in let node = InstrRef.get_node instr_ref in
State.set_node node; State.set_node node;
if is_forall && err_state.always if is_forall && err_state.always
then report_error_now then report_error_now st_report_error node err_instance err_state.loc proc_name
st_report_error node err_instance instr_ref_opt err_state.loc proc_name
| None, _ -> () in | None, _ -> () in
H.iter iter err_tbl; H.iter iter err_tbl;
reset () reset ()

4
infer/src/eradicate/typeOrigin.ml
Unescape View File

@ -64,8 +64,8 @@ let equal o1 o2 = match o1, o2 with
| Undef, Undef -> true | Undef, Undef -> true
let to_string = function let to_string = function
| Const loc -> "Const" | Const _ -> "Const"
| Field (fn, loc) -> "Field " ^ Ident.fieldname_to_simplified_string fn | Field (fn, _) -> "Field " ^ Ident.fieldname_to_simplified_string fn
| Formal s -> "Formal " ^ Mangled.to_string s | Formal s -> "Formal " ^ Mangled.to_string s
| Proc po -> | Proc po ->
Printf.sprintf Printf.sprintf

3
infer/src/eradicate/typeState.ml
Unescape View File

@ -23,8 +23,7 @@ type 'a ext =
{ {
empty : 'a; (** empty extension *) empty : 'a; (** empty extension *)
check_instr : (** check the extension for an instruction *) check_instr : (** check the extension for an instruction *)
get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> 'a -> Sil.instr -> parameters -> 'a;
-> 'a -> Sil.instr -> parameters -> 'a;
join : 'a -> 'a -> 'a; (** join two extensions *) join : 'a -> 'a -> 'a; (** join two extensions *)
pp : Format.formatter -> 'a -> unit (** pretty print an extension *) pp : Format.formatter -> 'a -> unit (** pretty print an extension *)
} }

3
infer/src/eradicate/typeState.mli
Unescape View File

@ -19,8 +19,7 @@ type 'a ext =
{ {
empty : 'a; (** empty extension *) empty : 'a; (** empty extension *)
check_instr : (** check the extension for an instruction *) check_instr : (** check the extension for an instruction *)
get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t get_proc_desc -> Procname.t -> Cfg.Procdesc.t ->'a -> Sil.instr -> parameters -> 'a;
->'a -> Sil.instr -> parameters -> 'a;
join : 'a -> 'a -> 'a; (** join two extensions *) join : 'a -> 'a -> 'a; (** join two extensions *)
pp : Format.formatter -> 'a -> unit (** pretty print an extension *) pp : Format.formatter -> 'a -> unit (** pretty print an extension *)
} }

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

@ -256,14 +256,14 @@ let get_all_supertypes typ tenv =
| _ -> [] in | _ -> [] in
let rec add_typ class_name typs = let rec add_typ class_name typs =
match Sil.tenv_lookup tenv class_name with match Sil.tenv_lookup tenv class_name with
| Some typ -> get_supers_rec typ tenv (TypSet.add typ typs) | Some typ -> get_supers_rec typ (TypSet.add typ typs)
| None -> typs | None -> typs
and get_supers_rec typ tenv all_supers = and get_supers_rec typ all_supers =
let direct_supers = get_direct_supers typ in let direct_supers = get_direct_supers typ in
IList.fold_left IList.fold_left
(fun typs class_name -> add_typ class_name typs) (fun typs class_name -> add_typ class_name typs)
all_supers direct_supers in all_supers direct_supers in
get_supers_rec typ tenv (TypSet.add typ TypSet.empty) get_supers_rec typ (TypSet.add typ TypSet.empty)
(** return true if [typ0] <: [typ1] *) (** return true if [typ0] <: [typ1] *)
let is_subtype (typ0 : Sil.typ) (typ1 : Sil.typ) tenv = let is_subtype (typ0 : Sil.typ) (typ1 : Sil.typ) tenv =
@ -339,8 +339,8 @@ let get_callback_registered_by procname args tenv =
(** return a list of typ's corresponding to callback classes registered by [procdesc] *) (** return a list of typ's corresponding to callback classes registered by [procdesc] *)
let get_callbacks_registered_by_proc procdesc tenv = let get_callbacks_registered_by_proc procdesc tenv =
let collect_callback_typs callback_typs node instr = match instr with let collect_callback_typs callback_typs _ instr = match instr with
| Sil.Call([], Sil.Const (Sil.Cfun callee), args, loc, _) -> | Sil.Call([], Sil.Const (Sil.Cfun callee), args, _, _) ->
begin begin
match get_callback_registered_by callee args tenv with match get_callback_registered_by callee args tenv with
| Some (_, callback_typ) -> callback_typ :: callback_typs | Some (_, callback_typ) -> callback_typ :: callback_typs

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

@ -35,7 +35,7 @@ let is_generated_field fieldname =
(** find callees that register callbacks and add instrumentation to extract the callback. (** find callees that register callbacks and add instrumentation to extract the callback.
return the set of new global static fields created to extract callbacks and their types *) return the set of new global static fields created to extract callbacks and their types *)
let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callback_fields = let extract_callbacks procdesc cfg_file cfg tenv harness_lvar callback_fields =
(* try to turn a nasty callback name like MyActivity$1 into a nice callback name like (* try to turn a nasty callback name like MyActivity$1 into a nice callback name like
* Button.OnClickListener[line 7]*) * Button.OnClickListener[line 7]*)
let create_descriptive_callback_name callback_typ loc = let create_descriptive_callback_name callback_typ loc =
@ -108,14 +108,14 @@ let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv =
match Cfg.load_cfg_from_file cfg_file with match Cfg.load_cfg_from_file cfg_file with
| Some cfg -> | Some cfg ->
IList.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 extract_callbacks procdesc cfg_file cfg tenv harness_lvar registered_callbacks
) registered_callbacks (Cfg.get_all_procs cfg) ) registered_callbacks (Cfg.get_all_procs cfg)
| None -> registered_callbacks | None -> registered_callbacks
) lifecycle_cfg_files [] ) lifecycle_cfg_files []
(** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a (** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a
lifecycle trace *) lifecycle trace *)
let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map tenv = match typ with let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs tenv = match typ with
| Sil.Tstruct { Sil.csu = Csu.Class Csu.Java; struct_name = Some name } -> | Sil.Tstruct { Sil.csu = Csu.Class Csu.Java; struct_name = Some name } ->
let class_name = Typename.TN_csu (Csu.Class Csu.Java, name) in let class_name = Typename.TN_csu (Csu.Class Csu.Java, name) in
if AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv && if AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv &&
@ -176,7 +176,7 @@ let create_android_harness proc_file_map tenv =
(* iterate through the type environment and generate a lifecycle harness for each subclass of (* iterate through the type environment and generate a lifecycle harness for each subclass of
* [lifecycle_typ] *) * [lifecycle_typ] *)
Sil.tenv_iter (fun _ typ -> Sil.tenv_iter (fun _ typ ->
match try_create_lifecycle_trace typ framework_typ framework_procs proc_file_map tenv with match try_create_lifecycle_trace typ framework_typ framework_procs tenv with
| [] -> () | [] -> ()
| lifecycle_trace -> | lifecycle_trace ->
(* we have identified an application lifecycle type and created a trace for it. now, (* we have identified an application lifecycle type and created a trace for it. now,
@ -187,7 +187,8 @@ let create_android_harness proc_file_map tenv =
Procname.mangled_java (None, harness_cls_name) None "InferGeneratedHarness" [] Procname.Static in Procname.mangled_java (None, harness_cls_name) None "InferGeneratedHarness" [] Procname.Static in
let callback_fields = let callback_fields =
extract_callbacks lifecycle_trace harness_procname proc_file_map tenv in extract_callbacks lifecycle_trace harness_procname proc_file_map tenv in
Inhabit.inhabit_trace lifecycle_trace callback_fields harness_procname proc_file_map tenv Inhabit.inhabit_trace
lifecycle_trace callback_fields harness_procname proc_file_map
) tenv ) tenv
| None -> () | None -> ()
) AndroidFramework.get_lifecycles ) AndroidFramework.get_lifecycles

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

@ -96,7 +96,7 @@ let rec inhabit_typ typ proc_file_map env =
try (TypMap.find typ env.cache, env) try (TypMap.find typ env.cache, env)
with Not_found -> with Not_found ->
let inhabit_internal typ env = match typ with let inhabit_internal typ env = match typ with
| Sil.Tptr (Sil.Tarray (inner_typ, Sil.Const (Sil.Cint size)), Sil.Pk_pointer) -> | Sil.Tptr (Sil.Tarray (inner_typ, Sil.Const (Sil.Cint _)), Sil.Pk_pointer) ->
let arr_size = Sil.Const (Sil.Cint (Sil.Int.one)) in let arr_size = Sil.Const (Sil.Cint (Sil.Int.one)) in
let arr_typ = Sil.Tarray (inner_typ, arr_size) in let arr_typ = Sil.Tarray (inner_typ, arr_size) in
inhabit_alloc arr_typ typ SymExec.ModelBuiltins.__new_array env inhabit_alloc arr_typ typ SymExec.ModelBuiltins.__new_array env
@ -151,7 +151,7 @@ let rec inhabit_typ typ proc_file_map env =
(** inhabit each of the types in the formals list *) (** inhabit each of the types in the formals list *)
and inhabit_args formals proc_file_map env = and inhabit_args formals proc_file_map env =
let inhabit_arg (formal_name, formal_typ) (args, env) = let inhabit_arg (_, formal_typ) (args, env) =
let (exp, env) = inhabit_typ formal_typ proc_file_map env in let (exp, env) = inhabit_typ formal_typ proc_file_map env in
((exp, formal_typ) :: args, env) in ((exp, formal_typ) :: args, env) in
IList.fold_right inhabit_arg formals ([], env) IList.fold_right inhabit_arg formals ([], env)
@ -187,9 +187,9 @@ let inhabit_call (procname, receiver) proc_file_map env =
let procdesc = procdesc_from_name procname proc_file_map in let procdesc = procdesc_from_name procname proc_file_map in
(* swap the type of the 'this' formal with the receiver type, if there is one *) (* swap the type of the 'this' formal with the receiver type, if there is one *)
let formals = match (Cfg.Procdesc.get_formals procdesc, receiver) with let formals = match (Cfg.Procdesc.get_formals procdesc, receiver) with
| ((name, typ) :: formals, Some receiver) -> (name, receiver) :: formals | ((name, _) :: formals, Some receiver) -> (name, receiver) :: formals
| (formals, None) -> formals | (formals, None) -> formals
| ([], Some receiver) -> | ([], Some _) ->
L.err L.err
"Expected at least one formal to bind receiver to in method %a@." Procname.pp procname; "Expected at least one formal to bind receiver to in method %a@." Procname.pp procname;
assert false in assert false in
@ -224,7 +224,7 @@ let inhabit_fld_trace flds proc_file_map env =
IList.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 *) (** create a dummy file for the harness and associate them in the exe_env *)
let create_dummy_harness_file harness_name harness_cfg tenv = let create_dummy_harness_file harness_name =
let dummy_file_name = let dummy_file_name =
let dummy_file_dir = let dummy_file_dir =
let sources_dir = DB.sources_dir () in let sources_dir = DB.sources_dir () in
@ -248,13 +248,13 @@ let write_harness_to_file harness_instrs harness_file =
close_outf outf) close_outf outf)
(** add the harness proc to the cg and make sure its callees can be looked up by sym execution *) (** add the harness proc to the cg and make sure its callees can be looked up by sym execution *)
let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv = let add_harness_to_cg harness_name harness_node cg =
Cg.add_defined_node cg harness_name; Cg.add_defined_node cg harness_name;
IList.iter (fun p -> Cg.add_edge cg harness_name p) (Cfg.Node.get_callees harness_node) IList.iter (fun p -> Cg.add_edge cg harness_name p) (Cfg.Node.get_callees harness_node)
(** create and fill the appropriate nodes and add them to the harness cfg. also add the harness (** create and fill the appropriate nodes and add them to the harness cfg. also add the harness
* proc to the cg *) * proc to the cg *)
let setup_harness_cfg harness_name harness_cfg env source_dir cg tenv = let setup_harness_cfg harness_name env source_dir cg =
(* each procedure has different scope: start names from id 0 *) (* each procedure has different scope: start names from id 0 *)
Ident.NameGenerator.reset (); Ident.NameGenerator.reset ();
@ -287,14 +287,14 @@ let setup_harness_cfg harness_name harness_cfg env source_dir cg tenv =
Cfg.Node.set_succs_exn harness_node [exit_node] [exit_node]; Cfg.Node.set_succs_exn harness_node [exit_node] [exit_node];
Cfg.add_removetemps_instructions harness_cfg; Cfg.add_removetemps_instructions harness_cfg;
Cfg.add_abstraction_instructions harness_cfg; Cfg.add_abstraction_instructions harness_cfg;
add_harness_to_cg harness_name harness_cfg harness_node env.pc cg tenv; add_harness_to_cg harness_name harness_node cg;
(* save out the cg and cfg so that they will be accessible in the next phase of the analysis *) (* save out the cg and cfg so that they will be accessible in the next phase of the analysis *)
Cg.store_to_file cg_file cg; Cg.store_to_file cg_file cg;
Cfg.store_cfg_to_file cfg_file false harness_cfg Cfg.store_cfg_to_file cfg_file false harness_cfg
(** create a procedure named harness_name that calls each of the methods in trace in the specified (** 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 *) * order with the specified receiver and add it to the execution environment *)
let inhabit_trace trace cb_flds harness_name proc_file_map tenv = let inhabit_trace trace cb_flds harness_name proc_file_map =
if IList.length trace > 0 then if IList.length trace > 0 then
(* pick an arbitrary cg and cfg to piggyback the harness code onto *) (* pick an arbitrary cg and cfg to piggyback the harness code onto *)
let (source_dir, source_file, cg) = let (source_dir, source_file, cg) =
@ -302,8 +302,7 @@ let inhabit_trace trace cb_flds harness_name proc_file_map tenv =
let cg = cg_from_name proc_name proc_file_map in let cg = cg_from_name proc_name proc_file_map in
(source_dir_from_name proc_name proc_file_map, source_file, cg) in (source_dir_from_name proc_name proc_file_map, source_file, cg) in
let harness_cfg = Cfg.Node.create_cfg () in let harness_file = create_dummy_harness_file harness_name in
let harness_file = create_dummy_harness_file harness_name harness_cfg tenv in
let start_line = (Cg.get_nLOC cg) + 1 in let start_line = (Cg.get_nLOC cg) + 1 in
let empty_env = let empty_env =
let pc = { Location.line = start_line; col = 1; file = source_file; nLOC = 0; } in let pc = { Location.line = start_line; col = 1; file = source_file; nLOC = 0; } in
@ -321,6 +320,6 @@ let inhabit_trace trace cb_flds harness_name proc_file_map tenv =
(* invoke callbacks *) (* invoke callbacks *)
inhabit_fld_trace cb_flds proc_file_map env' in inhabit_fld_trace cb_flds proc_file_map env' in
try try
setup_harness_cfg harness_name harness_cfg env'' source_dir cg tenv; setup_harness_cfg harness_name env'' source_dir cg;
write_harness_to_file (IList.rev env''.instrs) harness_file write_harness_to_file (IList.rev env''.instrs) harness_file
with Not_found -> () with Not_found -> ()

3
infer/src/harness/inhabit.mli
Unescape View File

@ -16,8 +16,7 @@ type callback_trace = (Sil.exp * Sil.typ) list
(** create a procedure named harness_name that calls each of the methods in trace in the specified (** 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 *) order with the specified receiver and add it to the execution environment *)
val inhabit_trace : lifecycle_trace -> callback_trace -> Procname.t -> val inhabit_trace : lifecycle_trace -> callback_trace -> Procname.t ->
DB.source_file Procname.Map.t -> unit
DB.source_file Procname.Map.t -> Sil.tenv -> unit
val source_dir_from_name : Procname.t -> DB.source_file Procname.Map.t -> DB.source_dir val source_dir_from_name : Procname.t -> DB.source_file Procname.Map.t -> DB.source_dir

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

@ -13,7 +13,7 @@ open Javalib_pack
(** Translate an annotation. *) (** Translate an annotation. *)
let translate a : Sil.annotation = let translate a : Sil.annotation =
let class_name = JBasics.cn_name a.JBasics.kind in let class_name = JBasics.cn_name a.JBasics.kind in
let translate_value_pair (name, value) = let translate_value_pair (_, value) =
match value with match value with
| JBasics.EVArray [JBasics.EVCstString s] -> | JBasics.EVArray [JBasics.EVCstString s] ->
s s

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

@ -93,13 +93,13 @@ let set_pvar context var typ = fst (get_or_set_pvar_type context var typ)
let reset_pvar_type context = let reset_pvar_type context =
let var_map = get_var_map context in let var_map = get_var_map context in
let aux var item = let aux var item =
match item with (pvar, otyp, typ) -> match item with (pvar, otyp, _) ->
set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in
JBir.VarMap.iter aux var_map JBir.VarMap.iter aux var_map
let get_var_type context var = let get_var_type context var =
try try
let (_, otyp', otyp) = JBir.VarMap.find var (get_var_map context) in let (_, _, otyp) = JBir.VarMap.find var (get_var_map context) in
Some otyp Some otyp
with Not_found -> None with Not_found -> None

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

@ -42,7 +42,7 @@ let add_edges context start_node exn_node exit_nodes method_body_nodes impl supe
| None -> direct_successors pc | None -> direct_successors pc
| Some jump_pc -> get_body_nodes jump_pc in | Some jump_pc -> get_body_nodes jump_pc in
let get_exn_nodes = let get_exn_nodes =
if super_call then (fun x -> exit_nodes) if super_call then (fun _ -> exit_nodes)
else JTransExn.create_exception_handlers context [exn_node] get_body_nodes impl in else JTransExn.create_exception_handlers context [exn_node] get_body_nodes impl in
let connect node pc = let connect node pc =
Cfg.Node.set_succs_exn node (get_succ_nodes node pc) (get_exn_nodes pc) in Cfg.Node.set_succs_exn node (get_succ_nodes node pc) (get_exn_nodes pc) in
@ -103,7 +103,7 @@ let add_cmethod never_null_matcher program icfg node cm is_static =
(** Add an abstract method. *) (** Add an abstract method. *)
let add_amethod program icfg node am is_static = let add_amethod program icfg am is_static =
let cfg = icfg.JContext.cfg in let cfg = icfg.JContext.cfg in
let tenv = icfg.JContext.tenv in let tenv = icfg.JContext.tenv in
let cn, ms = JBasics.cms_split am.Javalib.am_class_method_signature in let cn, ms = JBasics.cms_split am.Javalib.am_class_method_signature in
@ -164,7 +164,7 @@ let create_icfg never_null_matcher linereader program icfg cn node =
| Javalib.ConcreteMethod cm -> | Javalib.ConcreteMethod cm ->
add_cmethod never_null_matcher program icfg node cm method_kind add_cmethod never_null_matcher program icfg node cm method_kind
| Javalib.AbstractMethod am -> | Javalib.AbstractMethod am ->
add_amethod program icfg node am method_kind add_amethod program icfg am method_kind
) node ) node
end end
@ -225,7 +225,7 @@ let compute_source_icfg
(JClasspath.get_classmap program) in (JClasspath.get_classmap program) in
(icfg.JContext.cg, icfg.JContext.cfg) (icfg.JContext.cg, icfg.JContext.cfg)
let compute_class_icfg never_null_matcher linereader program tenv node fake_source_file = let compute_class_icfg never_null_matcher linereader program tenv node =
let icfg = let icfg =
{ JContext.cg = Cg.create (); { JContext.cg = Cg.create ();
JContext.cfg = Cfg.Node.create_cfg (); JContext.cfg = Cfg.Node.create_cfg ();

1
infer/src/java/jFrontend.mli
Unescape View File

@ -37,5 +37,4 @@ val compute_class_icfg :
JClasspath.program -> JClasspath.program ->
Sil.tenv -> Sil.tenv ->
JCode.jcode Javalib.interface_or_class -> JCode.jcode Javalib.interface_or_class ->
DB.source_file ->
Cg.t * Cfg.cfg Cg.t * Cfg.cfg

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

@ -73,7 +73,7 @@ let print_usage_exit () =
exit(1) exit(1)
let () = let () =
Arg.parse arg_desc (fun arg -> ()) usage; Arg.parse arg_desc (fun _ -> ()) usage;
if Config.analyze_models && !JClasspath.models_jar <> "" then if Config.analyze_models && !JClasspath.models_jar <> "" then
failwith "Not expecting model file when analyzing the models"; failwith "Not expecting model file when analyzing the models";
if not Config.analyze_models && !JClasspath.models_jar = "" then if not Config.analyze_models && !JClasspath.models_jar = "" then
@ -91,7 +91,7 @@ let init_global_state source_file =
Config.nLOC := nLOC Config.nLOC := nLOC
let store_icfg tenv cg cfg source_file program = let store_icfg tenv cg cfg program =
let f_translate_typ tenv typ_str = let f_translate_typ tenv typ_str =
let cn = JBasics.make_cn typ_str in let cn = JBasics.make_cn typ_str in
ignore (JTransType.get_class_type program tenv cn) in ignore (JTransType.get_class_type program tenv cn) in
@ -125,7 +125,7 @@ let do_source_file
JFrontend.compute_source_icfg JFrontend.compute_source_icfg
never_null_matcher linereader classes program tenv never_null_matcher linereader classes program tenv
source_basename package_opt in source_basename package_opt in
store_icfg tenv call_graph cfg source_file program; store_icfg tenv call_graph cfg program;
if !JConfig.create_harness then if !JConfig.create_harness then
IList.fold_left IList.fold_left
(fun proc_file_map pdesc -> (fun proc_file_map pdesc ->
@ -144,16 +144,15 @@ let capture_libs never_null_matcher linereader program tenv =
let fake_source_file = JClasspath.java_source_file_from_path (JFrontend.path_of_cached_classname cn) in let fake_source_file = JClasspath.java_source_file_from_path (JFrontend.path_of_cached_classname cn) in
init_global_state fake_source_file; init_global_state fake_source_file;
let call_graph, cfg = let call_graph, cfg =
JFrontend.compute_class_icfg JFrontend.compute_class_icfg never_null_matcher linereader program tenv node in
never_null_matcher linereader program tenv node fake_source_file in store_icfg tenv call_graph cfg program;
store_icfg tenv call_graph cfg fake_source_file program;
JFrontend.cache_classname cn; JFrontend.cache_classname cn;
end in end in
JBasics.ClassMap.iter (capture_class tenv) (JClasspath.get_classmap program) JBasics.ClassMap.iter (capture_class tenv) (JClasspath.get_classmap program)
(* load a stored global tenv if the file is found, and create a new one otherwise *) (* load a stored global tenv if the file is found, and create a new one otherwise *)
let load_tenv program = let load_tenv () =
let tenv_filename = DB.global_tenv_fname () in let tenv_filename = DB.global_tenv_fname () in
let tenv = let tenv =
if DB.file_exists tenv_filename then if DB.file_exists tenv_filename then
@ -174,7 +173,7 @@ let load_tenv program =
(* Store to a file the type environment containing all the types required to perform the analysis *) (* Store to a file the type environment containing all the types required to perform the analysis *)
let save_tenv classpath tenv = let save_tenv tenv =
if not Config.analyze_models then JTransType.add_models_types tenv; if not Config.analyze_models then JTransType.add_models_types tenv;
let tenv_filename = DB.global_tenv_fname () in let tenv_filename = DB.global_tenv_fname () in
(* TODO: this prevents per compilation step incremental analysis at this stage *) (* TODO: this prevents per compilation step incremental analysis at this stage *)
@ -189,7 +188,7 @@ let do_all_files classpath sources classes =
(StringMap.cardinal sources) (StringMap.cardinal sources)
(JBasics.ClassSet.cardinal classes); (JBasics.ClassSet.cardinal classes);
let program = JClasspath.load_program classpath classes in let program = JClasspath.load_program classpath classes in
let tenv = load_tenv program in let tenv = load_tenv () in
let linereader = Printer.LineReader.create () in let linereader = Printer.LineReader.create () in
let skip_translation_matcher = let skip_translation_matcher =
Inferconfig.SkipTranslationMatcher.load_matcher (Inferconfig.inferconfig ()) in Inferconfig.SkipTranslationMatcher.load_matcher (Inferconfig.inferconfig ()) in
@ -198,7 +197,7 @@ let do_all_files classpath sources classes =
let proc_file_map = let proc_file_map =
let skip source_file = let skip source_file =
skip_translation_matcher source_file Procname.empty in skip_translation_matcher source_file Procname.empty in
let translate_source_file basename (package_opt, source_file) source_file map = let translate_source_file basename (package_opt, _) source_file map =
init_global_state source_file; init_global_state source_file;
if skip source_file then map if skip source_file then map
else do_source_file else do_source_file
@ -219,7 +218,7 @@ let do_all_files classpath sources classes =
if !JConfig.dependency_mode then if !JConfig.dependency_mode then
capture_libs never_null_matcher linereader program tenv; capture_libs never_null_matcher linereader program tenv;
if !JConfig.create_harness then Harness.create_harness proc_file_map tenv; if !JConfig.create_harness then Harness.create_harness proc_file_map tenv;
save_tenv classpath tenv; save_tenv tenv;
JClasspath.cleanup program; JClasspath.cleanup program;
JUtils.log "done @." JUtils.log "done @."

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

@ -59,7 +59,7 @@ let get_location impl pc meth_kind cn =
let line_number = let line_number =
let ln = let ln =
try JBir.get_source_line_number pc impl try JBir.get_source_line_number pc impl
with Invalid_argument e -> None in with Invalid_argument _ -> None in
match ln with match ln with
| None -> 0 | None -> 0
| Some n -> n in | Some n -> n in
@ -78,7 +78,7 @@ let get_undefined_method_call ovt =
| JBasics.TObject ot -> | JBasics.TObject ot ->
begin begin
match ot with match ot with
| JBasics.TArray vt -> assert false | JBasics.TArray _ -> assert false
| JBasics.TClass cn -> | JBasics.TClass cn ->
if JBasics.cn_name cn = JConfig.string_cl then if JBasics.cn_name cn = JConfig.string_cl then
"string_undefined" "string_undefined"
@ -100,10 +100,10 @@ let retrieve_fieldname fieldname =
assert false assert false
else else
IList.hd (IList.rev subs) IList.hd (IList.rev subs)
with hd -> assert false with _ -> assert false
let get_field_name program static tenv cn fs context = let get_field_name program static tenv cn fs =
match JTransType.get_class_type_no_pointer program tenv cn with match JTransType.get_class_type_no_pointer program tenv cn with
| Sil.Tstruct { Sil.instance_fields; static_fields; csu = Csu.Class _ } -> | Sil.Tstruct { Sil.instance_fields; static_fields; csu = Csu.Class _ } ->
let fieldname, _, _ = let fieldname, _, _ =
@ -195,9 +195,9 @@ let get_binop binop =
| JBir.LXor -> Sil.BXor | JBir.LXor -> Sil.BXor
| JBir.LUshr -> | JBir.LUshr ->
raise (Frontend_error "Unsigned right shift operator") raise (Frontend_error "Unsigned right shift operator")
| JBir.CMP comp -> | JBir.CMP _ ->
raise (Frontend_error "Unsigned right shift operator") raise (Frontend_error "Unsigned right shift operator")
| JBir.ArrayLoad vt -> | JBir.ArrayLoad _ ->
raise (Frontend_error "Array load operator") raise (Frontend_error "Array load operator")
let get_test_operator op = let get_test_operator op =
@ -354,7 +354,7 @@ let create_local_procdesc program linereader cfg tenv node m =
| Created defined_status -> | Created defined_status ->
begin begin
match defined_status with match defined_status with
| Defined procdesc -> assert false | Defined _ -> assert false
| Called procdesc -> | Called procdesc ->
Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name procdesc) false; Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name procdesc) false;
create_new_procdesc () create_new_procdesc ()
@ -406,23 +406,22 @@ let rec expression context pc expr =
let loc = get_location (JContext.get_impl context) pc (JContext.get_meth_kind context) cn in let loc = get_location (JContext.get_impl context) pc (JContext.get_meth_kind context) cn in
let tenv = JContext.get_tenv context in let tenv = JContext.get_tenv context in
let type_of_expr = JTransType.expr_type context expr in let type_of_expr = JTransType.expr_type context expr in
let trans_var pvar var_type = let trans_var pvar =
let id = Ident.create_fresh Ident.knormal in let id = Ident.create_fresh Ident.knormal in
let sil_instr = Sil.Letderef (id, Sil.Lvar pvar, type_of_expr, loc) in let sil_instr = Sil.Letderef (id, Sil.Lvar pvar, type_of_expr, loc) in
([id], [sil_instr], Sil.Var id) in ([id], [sil_instr], Sil.Var id) in
match expr with match expr with
| JBir.Var (vt, var) -> | JBir.Var (_, var) ->
let pvar = (JContext.set_pvar context var type_of_expr) in let pvar = (JContext.set_pvar context var type_of_expr) in
trans_var pvar type_of_expr trans_var pvar
| JBir.Const c -> | JBir.Const c ->
begin begin
match c with (* We use the constant <field> internally to mean a variable. *) match c with (* We use the constant <field> internally to mean a variable. *)
| `String s when (JBasics.jstr_pp s) = JConfig.field_cst -> | `String s when (JBasics.jstr_pp s) = JConfig.field_cst ->
let varname = JConfig.field_st in let varname = JConfig.field_st in
let string_type = (JTransType.get_class_type program tenv (JBasics.make_cn JConfig.string_cl)) in
let procname = (Cfg.Procdesc.get_proc_name (JContext.get_procdesc context)) in let procname = (Cfg.Procdesc.get_proc_name (JContext.get_procdesc context)) in
let pvar = Sil.mk_pvar varname procname in let pvar = Sil.mk_pvar varname procname in
trans_var pvar string_type trans_var pvar
| _ -> ([], [], Sil.Const (get_constant c)) | _ -> ([], [], Sil.Const (get_constant c))
end end
| JBir.Unop (unop, ex) -> | JBir.Unop (unop, ex) ->
@ -454,8 +453,8 @@ let rec expression context pc expr =
JTransType.sizeof_of_object_type program tenv ot subtypes in JTransType.sizeof_of_object_type program tenv ot subtypes in
let builtin = let builtin =
(match unop with (match unop with
| JBir.InstanceOf ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) | JBir.InstanceOf _ -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof)
| JBir.Cast ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast) | JBir.Cast _ -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast)
| _ -> assert false) in | _ -> assert false) in
let args = [(sil_ex, type_of_ex); (sizeof_expr, Sil.Tvoid)] in let args = [(sil_ex, type_of_ex); (sizeof_expr, Sil.Tvoid)] in
let ret_id = Ident.create_fresh Ident.knormal in let ret_id = Ident.create_fresh Ident.knormal in
@ -468,7 +467,7 @@ let rec expression context pc expr =
and (idl2, instrs2, sil_ex2) = expression context pc ex2 in and (idl2, instrs2, sil_ex2) = expression context pc ex2 in
begin begin
match binop with match binop with
| JBir.ArrayLoad vt -> | JBir.ArrayLoad _ ->
(* add an instruction that dereferences the array *) (* add an instruction that dereferences the array *)
let array_typ = Sil.Tarray(type_of_expr, Sil.Var (Ident.create_fresh Ident.kprimed)) in let array_typ = Sil.Tarray(type_of_expr, Sil.Var (Ident.create_fresh Ident.kprimed)) in
let fresh_id, deref_array_instr = create_sil_deref sil_ex1 array_typ loc in let fresh_id, deref_array_instr = create_sil_deref sil_ex1 array_typ loc in
@ -485,7 +484,7 @@ let rec expression context pc expr =
end end
| JBir.Field (ex, cn, fs) -> | JBir.Field (ex, cn, fs) ->
let (idl, instrs, sil_expr) = expression context pc ex in let (idl, instrs, sil_expr) = expression context pc ex in
let field_name = get_field_name program false tenv cn fs context in let field_name = get_field_name program false tenv cn fs in
let sil_type = JTransType.get_class_type_no_pointer program tenv cn in let sil_type = JTransType.get_class_type_no_pointer program tenv cn in
let sil_expr = Sil.Lfield (sil_expr, field_name, sil_type) in let sil_expr = Sil.Lfield (sil_expr, field_name, sil_type) in
let tmp_id = Ident.create_fresh Ident.knormal in let tmp_id = Ident.create_fresh Ident.knormal in
@ -497,7 +496,7 @@ let rec expression context pc expr =
let var_name = Sil.mk_pvar_global classname in let var_name = Sil.mk_pvar_global classname in
Sil.Lvar var_name in Sil.Lvar var_name in
let (idl, instrs, sil_expr) = [], [], class_exp in let (idl, instrs, sil_expr) = [], [], class_exp in
let field_name = get_field_name program true tenv cn fs context in let field_name = get_field_name program true tenv cn fs in
let sil_type = JTransType.get_class_type_no_pointer program tenv cn in let sil_type = JTransType.get_class_type_no_pointer program tenv cn in
if JTransStaticField.is_static_final_field context cn fs && use_static_final_fields context if JTransStaticField.is_static_final_field context cn fs && use_static_final_fields context
then then
@ -533,7 +532,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
if Javalib.defines_method node ms then cn if Javalib.defines_method node ms then cn
else else
match node with match node with
| Javalib.JInterface jinterface -> fallback_cn | Javalib.JInterface _ -> fallback_cn
| Javalib.JClass jclass -> | Javalib.JClass jclass ->
begin begin
match jclass.Javalib.c_super_class with match jclass.Javalib.c_super_class with
@ -564,7 +563,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
| I_Special -> false | I_Special -> false
| _ -> true in | _ -> true in
match sil_obj_expr with match sil_obj_expr with
| Sil.Var id when is_non_constructor_call && not !JConfig.translate_checks -> | Sil.Var _ when is_non_constructor_call && not !JConfig.translate_checks ->
let obj_typ_no_ptr = let obj_typ_no_ptr =
match sil_obj_type with match sil_obj_type with
| Sil.Tptr (typ, _) -> typ | Sil.Tptr (typ, _) -> typ
@ -609,7 +608,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
| _ when Config.analyze_models || JClasspath.is_model callee_procname -> call_instrs | _ when Config.analyze_models || JClasspath.is_model callee_procname -> call_instrs
(* add a file attribute when calling the constructor of a subtype of Closeable *) (* add a file attribute when calling the constructor of a subtype of Closeable *)
| (var, typ) as exp :: _ | (_, typ) as exp :: _
when Procname.is_constructor callee_procname && JTransType.is_closeable program tenv typ -> when Procname.is_constructor callee_procname && JTransType.is_closeable program tenv typ ->
let set_file_attr = let set_file_attr =
let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_file_attribute) in let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_file_attribute) in
@ -618,7 +617,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
call_instrs @ [set_file_attr] call_instrs @ [set_file_attr]
(* remove file attribute when calling the close method of a subtype of Closeable *) (* remove file attribute when calling the close method of a subtype of Closeable *)
| (var, typ) as exp :: [] | (_, typ) as exp :: []
when Procname.java_is_close callee_procname && JTransType.is_closeable program tenv typ -> when Procname.java_is_close callee_procname && JTransType.is_closeable program tenv typ ->
let set_mem_attr = let set_mem_attr =
let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_mem_attribute) in let set_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__set_mem_attribute) in
@ -718,7 +717,7 @@ let extends context node1 node2 =
IList.exists per_classname cn_list in IList.exists per_classname cn_list in
check [Javalib.get_name node1] check [Javalib.get_name node1]
let instruction_array_call ms obj_type obj args var_opt vt = let instruction_array_call ms obj_type obj args var_opt =
if is_clone ms then if is_clone ms then
(let cn = JBasics.make_cn JConfig.infer_array_cl in (let cn = JBasics.make_cn JConfig.infer_array_cl in
let vt = (JBasics.TObject obj_type) in let vt = (JBasics.TObject obj_type) in
@ -833,7 +832,7 @@ let rec instruction context pc instr : translation =
| JBir.AffectField (e_lhs, cn, fs, e_rhs) -> | JBir.AffectField (e_lhs, cn, fs, e_rhs) ->
let (idl1, stml1, sil_expr_lhs) = expression context pc e_lhs in let (idl1, stml1, sil_expr_lhs) = expression context pc e_lhs in
let (idl2, stml2, sil_expr_rhs) = expression context pc e_rhs in let (idl2, stml2, sil_expr_rhs) = expression context pc e_rhs in
let field_name = get_field_name program false tenv cn fs context in let field_name = get_field_name program false tenv cn fs in
let type_of_the_surrounding_class = JTransType.get_class_type_no_pointer program tenv cn in let type_of_the_surrounding_class = JTransType.get_class_type_no_pointer program tenv cn in
let type_of_the_root_of_e_lhs = type_of_the_surrounding_class in let type_of_the_root_of_e_lhs = type_of_the_surrounding_class in
let expr_off = Sil.Lfield(sil_expr_lhs, field_name, type_of_the_surrounding_class) in let expr_off = Sil.Lfield(sil_expr_lhs, field_name, type_of_the_surrounding_class) in
@ -848,7 +847,7 @@ let rec instruction context pc instr : translation =
Sil.Lvar var_name in Sil.Lvar var_name in
let (idl1, stml1, sil_expr_lhs) = [], [], class_exp in let (idl1, stml1, sil_expr_lhs) = [], [], class_exp in
let (idl2, stml2, sil_expr_rhs) = expression context pc e_rhs in let (idl2, stml2, sil_expr_rhs) = expression context pc e_rhs in
let field_name = get_field_name program true tenv cn fs context in let field_name = get_field_name program true tenv cn fs in
let type_of_the_surrounding_class = JTransType.get_class_type_no_pointer program tenv cn in let type_of_the_surrounding_class = JTransType.get_class_type_no_pointer program tenv cn in
let type_of_the_root_of_e_lhs = type_of_the_surrounding_class in let type_of_the_root_of_e_lhs = type_of_the_surrounding_class in
let expr_off = Sil.Lfield(sil_expr_lhs, field_name, type_of_the_surrounding_class) in let expr_off = Sil.Lfield(sil_expr_lhs, field_name, type_of_the_surrounding_class) in
@ -967,8 +966,8 @@ let rec instruction context pc instr : translation =
begin begin
match obj_type with match obj_type with
| JBasics.TClass cn -> trans_virtual_call cn I_Virtual | JBasics.TClass cn -> trans_virtual_call cn I_Virtual
| JBasics.TArray vt -> | JBasics.TArray _ ->
let instr = instruction_array_call ms obj_type obj args var_opt vt in let instr = instruction_array_call ms obj_type obj args var_opt in
instruction context pc instr instruction context pc instr
end end
| JBir.InterfaceCall cn -> | JBir.InterfaceCall cn ->
@ -1013,7 +1012,7 @@ let rec instruction context pc instr : translation =
let ret_id = Ident.create_fresh Ident.knormal in let ret_id = Ident.create_fresh Ident.knormal in
let new_instr = Sil.Call([ret_id], builtin_new, args, loc, Sil.cf_default) in let new_instr = Sil.Call([ret_id], builtin_new, args, loc, Sil.cf_default) in
let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in
let constr_procname, call_ids, call_instrs = let _, call_ids, call_instrs =
let ret_opt = Some (Sil.Var ret_id, class_type) in let ret_opt = Some (Sil.Var ret_id, class_type) in
method_invocation context loc pc None npe_cn constr_ms ret_opt [] I_Special Procname.Static in method_invocation context loc pc None npe_cn constr_ms ret_opt [] I_Special Procname.Static in
let sil_exn = Sil.Const (Sil.Cexn (Sil.Var ret_id)) in let sil_exn = Sil.Const (Sil.Cexn (Sil.Var ret_id)) in
@ -1024,7 +1023,7 @@ let rec instruction context pc instr : translation =
| JBir.Check (JBir.CheckArrayBound (array_expr, index_expr)) when !JConfig.translate_checks -> | JBir.Check (JBir.CheckArrayBound (array_expr, index_expr)) when !JConfig.translate_checks ->
let ids, instrs, sil_array_expr, sil_length_expr, sil_index_expr = let ids, instrs, _, sil_length_expr, sil_index_expr =
let array_ids, array_instrs, sil_array_expr = let array_ids, array_instrs, sil_array_expr =
expression context pc array_expr expression context pc array_expr
and length_ids, length_instrs, sil_length_expr = and length_ids, length_instrs, sil_length_expr =
@ -1067,7 +1066,7 @@ let rec instruction context pc instr : translation =
let ret_id = Ident.create_fresh Ident.knormal in let ret_id = Ident.create_fresh Ident.knormal in
let new_instr = Sil.Call([ret_id], builtin_new, args, loc, Sil.cf_default) in let new_instr = Sil.Call([ret_id], builtin_new, args, loc, Sil.cf_default) in
let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in
let constr_procname, call_ids, call_instrs = let _, call_ids, call_instrs =
method_invocation method_invocation
context loc pc None out_of_bound_cn constr_ms context loc pc None out_of_bound_cn constr_ms
(Some (Sil.Var ret_id, class_type)) [] I_Special Procname.Static in (Some (Sil.Var ret_id, class_type)) [] I_Special Procname.Static in
@ -1106,7 +1105,7 @@ let rec instruction context pc instr : translation =
let ret_id = Ident.create_fresh Ident.knormal in let ret_id = Ident.create_fresh Ident.knormal in
let new_instr = Sil.Call([ret_id], builtin_new, args, loc, Sil.cf_default) in let new_instr = Sil.Call([ret_id], builtin_new, args, loc, Sil.cf_default) in
let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in let constr_ms = JBasics.make_ms JConfig.constructor_name [] None in
let constr_procname, call_ids, call_instrs = let _, call_ids, call_instrs =
method_invocation context loc pc None cce_cn constr_ms method_invocation context loc pc None cce_cn constr_ms
(Some (Sil.Var ret_id, class_type)) [] I_Special Procname.Static in (Some (Sil.Var ret_id, class_type)) [] I_Special Procname.Static in
let sil_exn = Sil.Const (Sil.Cexn (Sil.Var ret_id)) in let sil_exn = Sil.Const (Sil.Cexn (Sil.Var ret_id)) in

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

Write Preview
Loading…
Cancel
Save