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,@26 \
-cflags -w,@29 \
-cflags -w,+32 \
-cflags -w,@27 \
-cflags -w,@32 \
-cflags -w,@33 \
-cflags -w,@34 \
-cflags -w,@35 \
-cflags -w,@37 \
-cflags -w,@38 \
-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)" \
-lflags $(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 ids_shared =
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
let ids_tuple = (id_base, id_next, id_end, ids_shared) 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
let fav_insts_of_public_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_public_ids) in
let fav_insts_of_private_ids = IList.flatten (IList.map Sil.exp_fav_list insts_of_private_ids) in
let (fav_p_leftover, fav_in_pvars) =
let (fav_p_leftover, _) =
let sigma = Prop.get_sigma p_leftover in
(sigma_fav_list sigma, sigma_fav_in_pvars_list sigma) in
let fpv_inst_of_base = Sil.exp_fpv inst_of_base in
@ -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
(ids, para_body_hpats) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) 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
let lseg_pat = { Match.hpred = Prop.mk_lseg k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_next :: ids_exist 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
(ids, para_body_pat) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_next :: ids_exist 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
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 gen_pi_res p_start p_leftover (inst: Sil.subst) = []
let gen_pi_res _ _ (_: Sil.subst) = []
(*
let inst_base, inst_next, inst_end =
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 ids_shared =
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
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
(ids, para_body_hpats) in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
(* for the case of ptspts since iF'=iB therefore iF' cannot be private*)
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 ids_shared =
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
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
let dllseg_pat = { Match.hpred = Prop.mk_dllseg k2 para exp_iF' exp_iF exp_oF exp_iB exps_shared; Match.flag = impl_ok2 } in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_iF':: ids_exist 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 ids_shared =
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
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
let dllseg_pat = { Match.hpred = Prop.mk_dllseg k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared; Match.flag = impl_ok1 } in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_oB':: ids_exist 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 ids_shared =
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
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 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 gen_pi_res p_start p_leftover (inst: Sil.subst) = [] in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = [id_iF'; id_oB'] 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.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> []
| 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.Var _ -> [] (* type of |-> not known yet *)
| 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 process (_, nextse) =
match nextse with
| Sil.Eexp (next, inst) -> add_edge (root, next)
| Sil.Eexp (next, _) -> add_edge (root, next)
| _ -> assert false in
IList.iter process fsel' in
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 convert_to_exp acc (_, se) =
match se with
| Sil.Eexp (e, inst) -> e:: acc
| Sil.Eexp (e, _) -> e:: acc
| _ -> assert false in
let links = IList.rev (IList.fold_left convert_to_exp [] fsel') in
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)]
| Sil.Hpointsto _ as hpred :: sigma_rest ->
f ids_acc eqs_acc (hpred:: sigma_acc) sigma_rest
| Sil.Hlseg(k, para, e1, e2, es) as hpred :: sigma_rest ->
| Sil.Hlseg(_, para, e1, e2, es) as hpred :: sigma_rest ->
let empty_case =
f ids_acc ((e1, e2):: eqs_acc) sigma_acc sigma_rest in
let pointsto_case =
@ -625,7 +625,7 @@ let sigma_special_cases_eqs sigma =
let general_case =
f ids_acc eqs_acc (hpred:: sigma_acc) sigma_rest in
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 =
f ids_acc ((e1, e3):: (e2, e4):: eqs_acc) sigma_acc sigma_rest in
let pointsto_case =
@ -957,7 +957,7 @@ let abstract_pure_part p ~(from_abstract_footprint: bool) =
IList.fold_left
(fun pi a ->
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. *)
| Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Lt, _, _))
| 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 *)
(* objective-c object is positive, and whether the leak is part of the *)
(* 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
| 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 *) ->
Mleak_buckets.should_raise_objc_leak typ
| _ -> None
@ -1125,7 +1126,7 @@ let get_var_retain_cycle _prop =
let sigma = Prop.get_sigma _prop in
let is_pvar v h =
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
let is_hpred_block v h =
match h, v with
@ -1176,7 +1177,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
match t with
| Sil.Tstruct { Sil.instance_fields; static_fields } ->
let ia = ref [] in
IList.iter (fun (fn', t', ia') ->
IList.iter (fun (fn', _, ia') ->
if Ident.fieldname_equal fn fn' then ia := ia')
(instance_fields @ static_fields);
!ia
@ -1192,7 +1193,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
let rec do_cycle c =
match c with
| [] -> false
| ((e, t), fn, _):: c' ->
| ((_, t), fn, _):: c' ->
let ia = get_item_annotation t fn in
if (IList.exists do_annotation ia) then true
else do_cycle c' in
@ -1270,7 +1271,7 @@ let check_junk ?original_prop pname tenv prop =
| None -> Sil.Rmemory Sil.Mmalloc in
let ml_bucket_opt =
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 ->
Mleak_buckets.should_raise_cpp_leak ()
| _ -> None in

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

@ -36,7 +36,7 @@ module StrexpMatch : sig
val find_path : sigma -> path -> t
(** 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 *)
val get_data : t -> strexp_data
@ -66,13 +66,13 @@ end = struct
match se, t, syn_offs with
| _, _, [] -> (se, t)
| 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 t' = (fun (x,y,z) -> y)
(IList.find (fun (f', t', a') ->
let se' = snd (IList.find (fun (f', _) -> Sil.fld_equal f' fld) fsel) in
let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) ->
Sil.fld_equal f' fld) instance_fields) in
get_strexp_at_syn_offsets se' t' syn_offs'
| Sil.Earray (size, esel, _), Sil.Tarray(t', _), Index ind :: syn_offs' ->
let se' = snd (IList.find (fun (i', se') -> Sil.exp_equal i' ind) esel) in
| Sil.Earray (_, esel, _), Sil.Tarray(t', _), Index ind :: syn_offs' ->
let se' = snd (IList.find (fun (i', _) -> Sil.exp_equal i' ind) esel) in
get_strexp_at_syn_offsets se' t' syn_offs'
| _ ->
L.d_strln "Failure of get_strexp_at_syn_offsets";
@ -84,10 +84,10 @@ end = struct
let rec replace_strexp_at_syn_offsets se t syn_offs update =
match se, t, syn_offs with
| _, _, [] ->
update se t
update se
| 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 t' = (fun (x,y,z) -> y)
let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) ->
Sil.fld_equal f' fld) instance_fields) 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)
(** 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 rec find_offset_sexp sigma_other hpred root offs se typ =
let offs' = IList.rev 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
match se, typ with
| Sil.Estruct (fsel, _), Sil.Tstruct { Sil.instance_fields } ->
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
| _ -> ()
end
@ -156,7 +156,7 @@ end = struct
| (f, se) :: fsel' ->
begin
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
with Not_found ->
L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find")
@ -195,15 +195,15 @@ end = struct
| _ -> assert false
(** 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
(** Replace the strexp at the given offset in the given hpred *)
let hpred_replace_strexp footprint_part hpred syn_offs update =
let update se' t' =
let se_in = update se' t' in
let update se' =
let se_in = update se' in
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 index_is_not_new idx = IList.exists (Sil.exp_equal idx) orig_indices in
let process_index idx =
@ -222,13 +222,13 @@ end = struct
(** Replace the strexp at a given position by a new strexp *)
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
replace_hpred (sigma, hpred, syn_offs) hpred'
(** Replace the index in the array at a given position with the new index *)
let replace_index footprint_part ((sigma, hpred, syn_offs) : t) (index: Sil.exp) (index': Sil.exp) =
let update se' t' =
let update se' =
match se' with
| 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
@ -297,12 +297,12 @@ let array_abstraction_performed = ref false
let generic_strexp_abstract
(abstraction_name : string)
(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)
: Prop.normal Prop.t
=
let can_abstract s data =
let r = _can_abstract s data in
let can_abstract data =
let r = can_abstract_ data in
if r then array_abstraction_performed := true;
r in
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
let pointers = IList.flatten (IList.map add_index_to_paths indices) in
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
IList.exists filter (Prop.get_sigma p)
(** Given [p] containing an array at [path], blur [index] in it *)
let blur_array_index
(footprint_part: bool)
(p: Prop.normal Prop.t)
(path: StrexpMatch.path)
(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 *)
let blur_array_indices
(footprint_part : bool)
(p: Prop.normal Prop.t)
(root: StrexpMatch.path)
(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)
(** Given [p] containing an array at [root], only keep [indices] in it *)
let keep_only_indices
(footprint_part : bool)
(p: Prop.normal Prop.t)
(path: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool
@ -432,9 +429,9 @@ let array_typ_can_abstract = function
| _ -> true
(** 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
| Sil.Earray (size, esel, _) ->
| Sil.Earray (_, esel, _) ->
let len = IList.length esel in
len > 1
| _ -> false in
@ -442,7 +439,8 @@ let strexp_can_abstract sigma_rest ((_, se, typ) : StrexpMatch.strexp_data) : bo
(** 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 && 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 =
@ -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 ());
(p3, changed2 || changed3) in
let prune_and_blur_indices =
prune_and_blur Sil.d_exp_list
(keep_only_indices footprint_part)
(blur_array_indices footprint_part) in
prune_and_blur Sil.d_exp_list keep_only_indices blur_array_indices in
let partition_abstract should_keep abstract ksel default_keys =
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
let keep_keys' = if keep_keys == [] then default_keys else 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), _ ->
do_exp e1 typ;
do_exp e2 (Sil.Tint Sil.IULong)
| Sil.Lfield (e1, f, t), _ ->
| Sil.Lfield (e1, _, _), _ ->
do_exp e1 typ
| Sil.Sizeof _, _ -> ()
| _ ->
L.err "Unmatched exp: %a : %a@." (Sil.pp_exp pe) e (Sil.pp_typ_full pe) typ;
assert false in
let rec do_se se typ = match se, typ with
| Sil.Eexp (e, inst), _ ->
| Sil.Eexp (e, _), _ ->
do_exp e typ
| Sil.Estruct (fsel, _), Sil.Tstruct { Sil.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_array esel typ
| _ ->
@ -313,10 +313,10 @@ let create_idmap sigma : idmap =
assert false
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_struct fsel' ftl'
| (f1, se) :: fsel', (f2, typ, a2) :: ftal' ->
| _ :: _, _ :: ftal' ->
do_struct fsel ftal'
| _:: _, [] -> assert false
and do_array esel typ = match esel with
@ -333,7 +333,7 @@ let create_idmap sigma : idmap =
| Sil.Hpointsto (e, se, Sil.Sizeof (typ, _)) ->
do_lhs_e e (Sil.Tptr (typ, Sil.Pk_pointer));
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_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
@ -377,7 +377,7 @@ type code = Code.t
let pp_code = Code.pp
(** 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 stamp = Ident.get_stamp id 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 *)
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
| Sil.Var id ->
pp_id_c pe fmt id
pp_id_c fmt id
| e ->
Sil.pp_exp pe fmt e
(** pretty print a type in C *)
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
(** 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
(* 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 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 pp f () = F.fprintf f "%s = %a;" lhs (pp_exp_c pe) e in
Code.add_from_pp code' pp
| Sil.Estruct (fsel, _) ->
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
| Sil.Earray (size, esel, _) ->
| Sil.Earray (_, esel, _) ->
IList.iter (fun (e, se) ->
let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in
let index = pp_to_string pp () in
@ -453,15 +453,15 @@ let gen_sigma code proc_name spec_num env idmap sigma =
do_strexp post_code base false se
| Sil.Hpointsto (Sil.Var id, se, te) ->
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 () =
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 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
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 size_var = mk_size_name hpara_id 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 () =
F.fprintf fmt "int %s = 42;" size_var in
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 pp2
| hpred ->
@ -482,7 +482,7 @@ let gen_sigma code proc_name spec_num env idmap sigma =
let gen_init_equalities code pure =
let do_atom = function
| 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
| _ -> () in
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 f () = F.fprintf f "%a;" (Sil.pp_type_decl pe pp_name pp_exp_c) typ in
Code.add_from_pp code pp in
let do_vinfo id { typ = typ; alloc = alloc } =
let pp_var f () = pp_id_c pe f id in
let do_vinfo id { typ } =
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
Code.add_from_pp code pp in
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;
assert false in
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
IdMap.iter do_vinfo idmap
@ -531,16 +532,18 @@ let filter_idmap filter idmap =
!idmap'
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 mk_name = mk_lseg_name id proc_name spec_num in
let size_name = mk_size_name id in
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 () =
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 idmap = create_idmap hpara.Sil.body in
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
filter_idmap filter idmap 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 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
Code.add_line code line1;
Code.set_indent " ";
@ -568,7 +571,7 @@ let gen_hpara code proc_name spec_num env id hpara =
Code.set_indent " ";
Code.add_line code line14;
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.set_indent " ";
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 ""
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 *)
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 vars = ref [] in
let do_vinfo id { typ = typ; alloc = alloc } =
let do_vinfo id { alloc } =
if not alloc then vars := !vars @ [id] in
IdMap.iter do_vinfo idmap;
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_init_vars code (solve_constraints pure idmap) idmap;
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;
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))); *)
loop_visits_log := b :: !loop_visits_log
| _ -> () in
let do_any_node level node =
let do_any_node _level _node =
incr trace_length;
(* L.d_strln ("level " ^ string_of_int level ^ " (Cfg.Node.get_id node) " ^ string_of_int nid); *)
() in
let f level p session exn_opt = match Paths.Path.curr_node p with
(* L.d_strln *)
(* ("level " ^ string_of_int _level ^ *)
(* " (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 ->
do_any_node level node;
if level = 0 then do_node_caller node
@ -80,7 +82,7 @@ let check_access access_opt de_opt =
let filter = function
| Sil.Call (_, _, etl, _, _) ->
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
| _ -> false in
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
| Some (Localise.Returned_from_call n) ->
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
| _ ->
begin

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

@ -79,7 +79,7 @@ let iterate_procedure_callbacks exe_env proc_name =
| None -> () in
Option.may
(fun (idenv, tenv, proc_name, proc_desc, language) ->
(fun (idenv, tenv, proc_name, proc_desc, _) ->
IList.iter
(fun (language_opt, proc_callback) ->
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
let remove_node' filter_out_fun cfg node =
let remove_node' filter_out_fun cfg =
let remove_node_in_cfg nodes =
IList.filter filter_out_fun nodes in
cfg.node_list := remove_node_in_cfg !(cfg.node_list)
let remove_node_set cfg nodes =
remove_node' (fun node' -> not (NodeSet.mem node' nodes))
cfg nodes
remove_node' (fun node' -> not (NodeSet.mem node' nodes)) cfg
let proc_desc_remove cfg name remove_nodes =
(if remove_nodes then
@ -500,7 +499,7 @@ module Node = struct
| Stmt_node s ->
if sub_instrs then print_sub_instrs ()
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 ()
else F.fprintf fmt "assume %s %a" descr pp_loc ()
| Exit_node _ ->
@ -526,11 +525,11 @@ module Node = struct
match get_kind node with
| Stmt_node _ ->
"Instructions"
| Prune_node (is_true_branch, if_kind, descr) ->
| Prune_node (_, _, descr) ->
"Conditional" ^ " " ^ descr
| Exit_node _ ->
"Exit"
| Skip_node s ->
| Skip_node _ ->
"Skip"
| Start_node _ ->
"Start"
@ -568,7 +567,7 @@ module Node = struct
do_node (proc_desc_get_start_node proc_desc)
(** 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 rec do_node node = begin
visited := NodeSet.add node !visited;
@ -672,7 +671,7 @@ let rec pp_node_list f = function
(** Get all the procdescs (defined and declared) *)
let get_all_procs cfg =
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
(** 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
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)
(* 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
| 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 add_hpred_if_reachable (reach, exps) = function
| 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,
unless an updated copy already exists *)
let save_source_files cfg =
let process_proc pname pdesc =
let process_proc _ pdesc =
let loc = Node.proc_desc_get_loc pdesc in
let source_file = loc.Location.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
(** 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 attributes = Procdesc.get_attributes proc_desc in
let loc = attributes.ProcAttributes.loc in
@ -966,7 +965,7 @@ let save_attributes filename cfg =
IList.iter save_proc (get_all_procs cfg)
(** 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 debug = false in
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 instr': %a@." (Sil.pp_instr pe_text) instr'
end in
let do_instr node instr =
let do_instr _ instr =
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],
[(e1, t1)] -> (* getter for fields *)
[(e1, _)] -> (* getter for fields *)
let instr' = Sil.Letderef (ret_id, Sil.Lfield (e1, fn, ft), bt, loc_call) in
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 *)
let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in
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
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 *)
let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in
found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', _, cf), _, _
when IList.length ret_ids = IList.length ret_ids'
&& IList.length etl' = IList.length etl ->
let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in
found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', _, cf), _, _
when IList.length ret_ids = IList.length ret_ids'
&& IList.length etl' + 1 = IList.length etl ->
let etl1 = match IList.rev etl with (* remove last element *)
@ -1024,7 +1023,7 @@ let proc_inline_synthetic_methods cfg proc_desc : unit =
let is_synthetic = attributes.ProcAttributes.is_synthetic_method in
let is_bridge = attributes.ProcAttributes.is_bridge_method in
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
| None -> None)
| _ -> 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
| None -> ()
end;
save_attributes filename cfg;
save_attributes 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
(** 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

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 nodes = ref Procname.Set.empty in
let f node info =
let f node _ =
nodes := Procname.Set.add node !nodes in
node_map_iter f g;
!nodes
@ -204,7 +204,7 @@ let get_all_nodes (g: t) =
IList.map (fun node -> (node, get_calls g node)) nodes
let get_nodes_and_calls (g: t) =
IList.filter (fun (n, 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 =
(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 nodes = ref [] in
let edges = ref [] in
let do_children node info nto =
let do_children node nto =
edges := (node, nto) :: !edges in
let f node info =
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;
(!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 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 get_color (n, calls) =
let get_color (n, _) =
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
let pp_node fmt (n, calls) =
let pp_node fmt (n, _) =
F.fprintf fmt "\"%s\"" (Procname.to_filename n) in
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

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

@ -268,7 +268,7 @@ module CheckJoinPre : InfoLossCheckerSig = struct
match e with
| Sil.Lvar _ -> false
| Sil.Var id when Ident.is_normal id -> IList.length es >= 1
| Sil.Var id ->
| Sil.Var _ ->
if !Config.join_cond = 0 then
IList.exists (Sil.exp_equal Sil.exp_zero) es
else if Dangling.check side e then
@ -307,17 +307,17 @@ end
module CheckJoinPost : InfoLossCheckerSig = struct
let init sigma1 sigma2 =
let init _ _ =
NonInj.init ()
let final () =
NonInj.final ()
let fail_case side e es =
let fail_case _ e es =
match e with
| Sil.Lvar _ -> false
| Sil.Var id when Ident.is_normal id -> IList.length es >= 1
| Sil.Var id -> false
| Sil.Var _ -> false
| _ -> false
let lost_little side e es =
@ -463,7 +463,7 @@ end = struct
let init () = 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
if n1 <> 0 then n1 else Sil.exp_compare e2 e2'
@ -628,7 +628,7 @@ end = struct
begin
let r = lookup_side' side e in
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
end
| 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)
renaming_restricted in
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 =
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
if find_duplicates sub_list_side_sorted then (L.d_strln "failure reason 11"; raise IList.Fail)
else Sil.sub_of_list sub_list_side
let to_subst_emb (side : side) =
let renaming_restricted =
let pick_id_case (e1, e2, e) =
let pick_id_case (e1, e2, _) =
match select side e1 e2 with
| Sil.Var i -> can_rename i
| _ -> false in
@ -672,7 +672,7 @@ end = struct
let compare (i, _) (i', _) = Ident.compare i i' in
IList.sort compare sub_list in
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
if find_duplicates sub_list_sorted then (L.d_strln "failure reason 12"; raise IList.Fail)
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 ->
ident_partial_join id1 id2
| Sil.Var id, Sil.Const c
| Sil.Const c, Sil.Var id ->
| Sil.Var id, Sil.Const _
| Sil.Const _, Sil.Var id ->
if Ident.is_normal id then
(L.d_strln "failure reason 20"; raise IList.Fail)
else
@ -938,7 +938,7 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
else
let e1'' = exp_partial_join e1 e2 in
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)
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') ->
@ -956,7 +956,7 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.Lvar(pvar1), Sil.Lvar(pvar2) ->
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 25"; raise IList.Fail)
else e1
| Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, t2) ->
| 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)
else Sil.Lfield(exp_partial_join e1 e2, f1, t1) (* should be t1 = t2 *)
| 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
let e1'' = exp_partial_meet e1 e2 in
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)
else Sil.UnOp (unop1, exp_partial_meet e1 e2, topt1) (* should be topt1 = topt2 *)
| 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) ->
if not (Sil.pvar_equal pvar1 pvar2) then (L.d_strln "failure reason 35"; raise IList.Fail)
else e1
| Sil.Lfield(e1, f1, t1), Sil.Lfield(e2, f2, t2) ->
| 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)
else Sil.Lfield(exp_partial_meet e1 e2, f1, t1) (* should be t1 = t2 *)
| 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 =
match fld_se_list1, fld_se_list2 with
| [], [] -> Sil.Estruct (IList.rev acc, inst)
| [], other_fsel | other_fsel, [] ->
| [], _ | _, [] ->
begin
match mode with
| 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 =
match idx_se_list1, idx_se_list2 with
| [], [] -> Sil.Earray (size, IList.rev idx_se_list_acc, inst)
| [], other_isel | other_isel, [] ->
| [], _ | _, [] ->
begin
match mode with
| JoinState.Pre -> (L.d_strln "failure reason 44"; raise 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 e1, e2, e = todo in
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
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 next' = exp_partial_join next1 next2 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 e1, e2, e = todo in
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
| Sil.Hpointsto _, _ | _, Sil.Hpointsto _ ->
(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 next' = exp_partial_meet next1 next2 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;
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 ->
let oF' = do_side side exp_partial_join oF opposite 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;
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 ->
let oB' = do_side side exp_partial_join oB opposite in
let shared' = Rename.lookup_list side shared in
@ -1587,7 +1587,7 @@ let pi_partial_join mode
else widening_top in
let a' = Prop.mk_inequality (Sil.BinOp(Sil.Le, e, Sil.exp_int bound)) in
Some a'
| Some (e, n), [] ->
| Some (e, _), [] ->
let bound = widening_top in
let a' = Prop.mk_inequality (Sil.BinOp(Sil.Le, e, Sil.exp_int bound)) in
Some a'
@ -1651,8 +1651,8 @@ let pi_partial_join mode
| Sil.Aneq(e, e') | Sil.Aeq(e, e')
when (exp_is_const e && exp_is_const e') ->
true
| Sil.Aneq(Sil.Var id, e') | Sil.Aneq(e', Sil.Var id)
| Sil.Aeq(Sil.Var id, e') | Sil.Aeq(e', Sil.Var id)
| Sil.Aneq(Sil.Var _, e') | Sil.Aneq(e', Sil.Var _)
| Sil.Aeq(Sil.Var _, e') | Sil.Aeq(e', Sil.Var _)
when (exp_is_const e') ->
true
| Sil.Aneq _ -> false
@ -1913,8 +1913,8 @@ let jplist_collapse mode jplist =
let jprop_list_add_ids jplist =
let seq_number = ref 0 in
let rec do_jprop = function
| Specs.Jprop.Prop (n, p) -> incr seq_number; Specs.Jprop.Prop (!seq_number, p)
| Specs.Jprop.Joined (n, p, jp1, jp2) ->
| Specs.Jprop.Prop (_, p) -> incr seq_number; Specs.Jprop.Prop (!seq_number, p)
| Specs.Jprop.Joined (_, p, jp1, jp2) ->
let jp1' = do_jprop jp1 in
let jp2' = do_jprop jp2 in
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 =
match se with
| Sil.Eexp (Sil.Lvar pvar, inst) -> F.fprintf f "%a" (Sil.pp_pvar pe) pvar
| Sil.Eexp (Sil.Var id, inst) ->
| Sil.Eexp (Sil.Lvar pvar, _) -> F.fprintf f "%a" (Sil.pp_pvar pe) pvar
| Sil.Eexp (Sil.Var id, _) ->
if !print_full_prop then
F.fprintf f "%a" (Ident.pp pe) id
else ()
| Sil.Eexp (e, inst) ->
| Sil.Eexp (e, _) ->
if !print_full_prop then
F.fprintf f "%a" (Sil.pp_exp pe) e
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 =
match se with
| Sil.Eexp (e', inst') ->
| Sil.Eexp (e', _) ->
F.fprintf f "%a" (Sil.pp_exp pe) e'
| Sil.Estruct (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;
let coo = mk_coordinate n lambda in
(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 ->
let e_color_str = color_to_str (exp_color hpred e) in
[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
[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 e3_color_str = color_to_str (exp_color hpred e3) in
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
incr dotty_state_count;
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 *)
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
if IList.mem Sil.exp_equal e !struct_exp_nodes then [] else
[Dotpointsto((mk_coordinate n lambda), e, e_color_str)]
| (Sil.Hlseg (k, hpara, e1, e2, elist), lambda) ->
| (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 *)
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)]
| (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
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
@ -349,7 +349,7 @@ let compute_fields_struct sigma =
fields_structs:=[];
let rec do_strexp se in_struct =
match se with
| Sil.Eexp (e, inst) -> if in_struct then fields_structs:= e ::!fields_structs else ()
| Sil.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.Earray (_, l, _) -> IList.iter (fun e -> do_strexp e false) (snd (IList.split l)) in
let rec fs s =
@ -384,7 +384,7 @@ let in_cycle cycle edge =
let node_in_cycle cycle node =
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
| _ -> 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 find_target_one_fld (fn, se) =
match se with
| Sil.Eexp (e, inst) ->
| Sil.Eexp (e, _) ->
if is_nil e p then begin
let n'= make_nil_node lambda in
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,"")]
| _ -> (* by construction there must be at most 2 nodes for an expression*)
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 *)
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 find_target_one_element (idx, se) =
match se with
| Sil.Eexp (e, inst) ->
| Sil.Eexp (e, _) ->
if is_nil e p then begin
let n'= make_nil_node lambda in
[(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*)
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 *)
in
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
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
let n'= make_nil_node lambda in
[(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' ->
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
(match src with
| [] -> assert false
@ -522,12 +522,12 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle =
else [] in
lnk_from_address_struct @ links_from_fields @
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
(match src with
| [] -> assert false
| 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) ->
mk_link k (mk_coordinate n lambda) ""
(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
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
(match src with
| [] -> assert false
| 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
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
(match src with
| [] -> assert false
@ -571,7 +571,7 @@ let print_kind f kind =
current_pre:=!dotty_state_count;
F.fprintf f "\n PRE%iL0 [label=\"PRE %i \", style=filled, color= yellow]\n" !dotty_state_count !spec_counter;
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;
print_stack_info:= true;
| 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;
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 lambda = coo.lambda 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 "}\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 lambda = coo.lambda in
let n' = !dotty_state_count in
@ -721,7 +721,7 @@ and print_sll f pe nesting k e1 e2 coo =
incr lambda_counter;
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 lambda = coo.lambda 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
else IList.filter (fun edge -> in_cycle cycle edge) l in
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
| Dotlseg(coo, e1, e2, Sil.Lseg_NE, nesting, c) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_NE e1 e2 coo
| Dotlseg(coo, e1, e2, Sil.Lseg_PE, nesting, c) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_PE e1 e2 coo
| Dotdllseg(coo, e1, e2, e3, e4, Sil.Lseg_NE, nesting, c) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_NE e1 e2 e3 e4 coo
| Dotdllseg(coo, e1, e2, e3, e4, Sil.Lseg_PE, nesting, c) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_PE e1 e2 e3 e4 coo
| Dotarray(coo, e1, e2, l, _, c) when !print_full_prop -> print_array f pe e1 e2 l coo c
| Dotlseg(coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_NE e1 coo
| Dotlseg(coo, e1, _, Sil.Lseg_PE, nesting, _) when !print_full_prop ->
print_sll f pe nesting Sil.Lseg_PE e1 coo
| Dotdllseg(coo, e1, _, _, e4, Sil.Lseg_NE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_NE e1 e4 coo
| Dotdllseg(coo, e1, _, _, e4, Sil.Lseg_PE, nesting, _) when !print_full_prop ->
print_dll f pe nesting Sil.Lseg_PE e1 e4 coo
| _ -> ()
(* Build the graph data structure to be printed *)
@ -856,7 +856,7 @@ let pp_dotty_one_spec f pre posts =
invisible_arrows:= true;
pp_dotty f (Spec_precondition) pre None;
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
F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre;
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))
| Cfg.Node.Join_node ->
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.Skip_node s -> Format.fprintf fmt "Skip %s" s in
let instr_string i =
@ -1116,10 +1117,10 @@ let rec make_visual_heap_nodes sigma =
| [] -> []
| Sil.Hpointsto (e, se, t):: 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;
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;
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
let get_rhs_predicate hpred =
(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.Hdllseg (_, _, e1, e2, e3, _, _) ->
| Sil.Hdllseg (_, _, _, e2, e3, _, _) ->
if (Sil.exp_equal e2 Sil.exp_zero) then
if (Sil.exp_equal e3 Sil.exp_zero) then []
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)*)
let rec compute_target_nodes_from_sexp nodes se prop field_lab =
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, inst) ->
| Sil.Eexp (e, _) when is_nil e prop ->
(* 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
(match e_node with
| 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
match sigma with
| [] -> []
| Sil.Hpointsto (e, se, t):: sigma' ->
| Sil.Hpointsto (e, se, _):: sigma' ->
let e_node = select_node_at_address nodes e in
(match e_node with
| 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
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
(match e1_node with
| None -> assert false
@ -1244,7 +1247,7 @@ let rec 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
(match e1_node with
| 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 =
match co with
| Sil.Eexp (e, inst) ->
| Sil.Eexp (e, _) ->
Io_infer.Xml.create_tree "cell" [("content-value", exp_to_xml_string e)] []
| Sil.Estruct (fel, _) ->
let f (fld, exp) = Io_infer.Xml.create_tree "struct-field" [("id", Ident.fieldname_to_string fld)] [(pointsto_contents_to_xml exp)] in
@ -1317,17 +1320,17 @@ let heap_node_to_xml node =
| 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
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 contents = pointsto_contents_to_xml cont in
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
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
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 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
@ -1359,12 +1362,17 @@ let print_specs_xml signature specs loc fmt =
reset_node_counter ();
let do_one_spec pre posts n =
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
Prop.normalize _prop' in
let jj = ref 0 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
let j = ref 0 in
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 node_instrs = Cfg.Node.get_instrs node in
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;
true
| _ -> false in
@ -275,7 +275,7 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
end
end
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
begin
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
| None -> None
| Some de -> Some (Sil.Darrow (de, f)))
| Sil.Lfield (e1, f, typ) ->
| Sil.Lfield (e1, f, _) ->
if !verbose then
begin
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 ->
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
| Sil.Lfield (e1, f, typ) ->
| Sil.Lfield (e1, f, _) ->
if !verbose then
begin
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
| Some texp' when Sil.exp_equal texp texp' -> found := true
| _ -> () in
let check_hpara texp n hpara =
let check_hpara texp _ hpara =
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
match hpred_type hpred with
| Some texp ->
@ -430,7 +430,7 @@ let find_hpred_typ hpred = match hpred with
| _ -> None
(** 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 do_hpred = function
| 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 *)
(Sil.pvar_is_local pvar || Sil.pvar_is_global pvar) &&
not (pvar_is_frontend_tmp pvar) &&
match hpred_typ_opt, find_pvar_typ_without_ptr tenv prop pvar with
| Some (Sil.Sizeof (t1, st1)), Some (Sil.Sizeof (Sil.Tptr (_t2, _), st2)) ->
match hpred_typ_opt, find_pvar_typ_without_ptr prop pvar with
| Some (Sil.Sizeof (t1, _)), Some (Sil.Sizeof (Sil.Tptr (_t2, _), _)) ->
(try
let t2 = Sil.expand_type tenv _t2 in
Sil.typ_equal t1 t2
@ -483,7 +483,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
| None ->
if !verbose then (L.d_str "explain_leak: no current instruction"; L.d_ln ());
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 ());
(match exp_lv_dexp (State.get_node ()) (Sil.Lvar pvar) with
| None -> None
@ -564,7 +564,7 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
let res = ref (None, None) in
IList.iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel;
!res
| sexp ->
| _ ->
None, None in
let do_hpred sigma_acc' sigma_todo' =
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
| 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
| hpred ->
| _ ->
(* if !verbose then (L.d_str "vpath_find do_hpred: no match "; Sil.d_hpred hpred; L.d_ln ()); *)
None, None in
match sigma_todo with
@ -664,13 +664,13 @@ let explain_dexp_access prop dexp is_nullable =
| None -> None
| Some (Sil.Eexp (e, _)) -> find_ptsto e
| 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));
None
| Sil.Dfcall (Sil.Dconst c, _, loc, _) ->
if !verbose then (L.d_strln "lookup: found Dfcall ");
(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))
| _ -> None)
| de ->
@ -680,9 +680,9 @@ let explain_dexp_access prop dexp is_nullable =
| None ->
if !verbose then (L.d_strln ("explain_dexp_access: cannot find inst of " ^ Sil.dexp_to_string dexp));
None
| Some (Sil.Iupdate (_, ncf, n, pos)) ->
| Some (Sil.Iupdate (_, ncf, n, _)) ->
Some (Localise.Last_assigned (n, ncf))
| Some (Sil.Irearrange (_, _, n, pos)) ->
| Some (Sil.Irearrange (_, _, n, _)) ->
Some (Localise.Last_accessed (n, is_nullable))
| Some (Sil.Ireturn_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 de_opt =
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
| 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
| Sil.Darray(de1, de2) -> (* remove array access *)
| Sil.Darray(de1, _) -> (* remove array access *)
de1
| Sil.Dderef de -> (* remove implicit array access *)
de
@ -758,16 +758,16 @@ let _explain_access
?(is_premature_nil = false)
deref_str prop loc =
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 ());
exp_lv_dexp node e
| 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 ());
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 ());
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 ());
find_outermost_dereference node e'
| 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 ());
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, _, _, _) ->
if !verbose then (L.d_str "explain_dereference Sil.Set "; Sil.d_exp e; L.d_ln ());
Some e
| Some Sil.Letderef (_, e, _, _) ->
if !verbose then (L.d_str "explain_dereference Sil.Leteref "; Sil.d_exp e; L.d_ln ());
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 ());
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 ());
Some e
| _ -> None in
let node = State.get_node () in
match find_exp_dereferenced node with
match find_exp_dereferenced () with
| None ->
if !verbose then L.d_strln "_explain_access: find_exp_dereferenced returned None";
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
let err_data_compare
((nodeid1, key1), session1, loc1, ml_loc_opt1, ltr1, po1, ec1)
((nodeid2, key2), session2, loc2, ml_loc_opt2, ltr2, po2, ec2) =
(_, _, loc1, _, _, _, _)
(_, _, loc2, _, _, _, _) =
Location.compare loc1 loc2
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
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)
let equal
(ekind1, in_footprint1, err_name1, desc1, severity1)
(ekind2, in_footprint2, err_name2, desc2, severity2) =
(ekind1, in_footprint1, err_name1, desc1, _)
(ekind2, in_footprint2, err_name2, desc2, _) =
(ekind1, in_footprint1, err_name1) = (ekind2, in_footprint2, err_name2) &&
Localise.error_desc_equal desc1 desc2
@ -78,7 +78,7 @@ type iter_fun =
let iter (f: iter_fun) (err_log: t) =
ErrLogHash.iter (fun (ekind, in_footprint, err_name, desc, severity) set ->
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
node_id_key loc ml_loc_opt ekind in_footprint err_name
desc severity ltr pre_opt eclass)
@ -94,14 +94,14 @@ let size filter (err_log: t) =
(** Print errors from error log *)
let pp_errors fmt (errlog : t) =
let f (ekind, _, ename, _, _) locs =
let f (ekind, _, ename, _, _) _ =
if ekind == Exceptions.Kerror then
F.fprintf fmt "%a@ " Localise.pp ename in
ErrLogHash.iter f errlog
(** Print warnings from error log *)
let pp_warnings fmt (errlog : t) =
let f (ekind, _, ename, desc, _) locs =
let f (ekind, _, ename, desc, _) _ =
if ekind == Exceptions.Kwarning then
F.fprintf fmt "%a %a@ " Localise.pp ename Localise.pp_error_desc desc in
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_eds fmt eds =
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
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
then
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 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
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
ErrLogHash.iter count err_table;
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_re = 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
| true, Exceptions.Kerror -> map_err_fp
| 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
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) ->
Exceptions.pp_err nodeidkey loc ekind err_name desc ml_loc_opt fmt ()) err_names in
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)
| Dangling_pointer_dereference (dko, desc, ml_loc) ->
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
(Localise.dangling_pointer_dereference,
desc, Some ml_loc, visibility, High, None, Prover)
@ -192,7 +192,7 @@ let recognize_exception exn =
| Invalid_argument s ->
let desc = Localise.verbatim_desc s in
(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
(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) ->
@ -231,7 +231,7 @@ let recognize_exception exn =
| Precondition_not_met (desc, ml_loc) ->
(Localise.precondition_not_met,
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,
desc, Some ml_loc, Exn_user, High, None, Prover)
| Return_expression_required (desc, ml_loc) ->
@ -320,7 +320,7 @@ let err_class_string = function
let print_key = false
(** 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 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"

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

@ -155,7 +155,7 @@ let file_data_to_tenv file_data =
assert false
| Some tenv -> tenv
let file_data_to_cfg exe_env file_data =
let file_data_to_cfg file_data =
match file_data.cfg with
| None ->
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 *)
let get_cfg exe_env pname =
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] *)
let iter_files f exe_env =
@ -189,7 +189,7 @@ let iter_files f exe_env =
begin
DB.current_source := fname;
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
end in
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
(** [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 *)
val proc_is_active : t -> Procname.t -> bool

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

@ -22,7 +22,7 @@ module WeightedPnameSet =
end)
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
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.
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 elem = WeightedPnameSet.max_elt set in
if filter elem then
@ -322,7 +322,7 @@ end
propagates results, and handles fixpoints in the call graph. *)
let main_algorithm exe_env analyze_proc filter_out process_result : unit =
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
Specs.get_timestamp summary = 0 in
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;
num_procs_done := 0;
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 *)
Procname.Set.for_all
(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
let pname, calls =
(** 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
with Not_found -> (* no analyzable procs *)
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 *)
try _process_result exe_env (pname, calls) summary with
| 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
L.err "Error: %s@." err_str;
let exn' = Exceptions.Internal_error (Localise.verbatim_desc err_str) in
Reporting.log_error pname exn';
post_process_procs exe_env [pname] in
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
| xs when n == 0 -> xs
| x:: xs -> drop_first (n - 1) xs
| _ :: xs -> drop_first (n - 1) xs
| [] -> []
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
| Some s1, s2 ->
(match string_split_character s1 '.' with
| Some s3, s4 -> s4 ^ "." ^ s2
| Some _, s4 -> s4 ^ "." ^ s2
| _ -> s)
| _ -> s
@ -143,7 +143,7 @@ let fieldname_to_simplified_string fn =
let fieldname_to_flat_string fn =
let s = Mangled.to_string fn.fname in
match string_split_character s '.' with
| Some s1, s2 -> s2
| Some _, s2 -> s2
| _ -> s
(** 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)
let () = (* parse command-line arguments *)
let f arg =
let f _ =
() (* ignore anonymous arguments *) in
Arg.parse arg_desc f usage;
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 *)
let reset_summaries cg =
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)
(** 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
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;
(* for i = 1 to Random.int 1000000 do () done; *)
let prev_summary = Specs.get_summary_unsafe "Simulator" proc_name in
let timestamp = max 1 (prev_summary.Specs.timestamp) in
{ prev_summary with Specs.timestamp = timestamp }
let filter_out cg proc_name = false
let filter_out _ _ = false
end
let analyze exe_env =
@ -412,7 +412,7 @@ let analyze exe_env =
Simulator.reset_summaries (Exe_env.get_cg exe_env);
Fork.interprocedural_algorithm
exe_env
(Simulator.analyze_proc exe_env)
Simulator.analyze_proc
Simulator.process_result
Simulator.filter_out
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 total_nodes = IList.length nodes 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;
if defined then
Cg.add_defined_node file_cg
@ -711,7 +711,7 @@ let compute_clusters exe_env files_changed : Cluster.t list =
clusters'
(** 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_opt = Cfg.load_cfg_from_file cfg_fname in
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)
[]
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 changed_procs =
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
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
@ -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 files_changed =
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
(** Create an exe_env from a cluster. *)
@ -824,7 +824,7 @@ let open_output_file f fname =
let close_output_file = function
| None -> ()
| Some (fmt, cout) -> close_out cout
| Some (_, cout) -> close_out cout
let setup_logging () =
if !Config.developer_mode then

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

@ -31,9 +31,9 @@ type filters =
proc_filter : proc_filter;
}
let default_path_filter : path_filter = function path -> true
let default_error_filter : error_filter = function error_name -> true
let default_proc_filter : proc_filter = function proc_name -> true
let default_path_filter : path_filter = function _ -> true
let default_error_filter : error_filter = function _ -> true
let default_proc_filter : proc_filter = function _ -> true
let do_not_filter : filters =
{
@ -63,7 +63,7 @@ let is_matching patterns =
module FileContainsStringMatcher = struct
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 rec loop () =
@ -104,7 +104,7 @@ struct
type matcher = DB.source_file -> Procname.t -> bool
let default_matcher : matcher =
fun source_file proc_name -> false
fun _ _ -> false
type method_pattern = {
class_name : string;
@ -158,7 +158,7 @@ struct
| `String s -> s:: accu
| _ -> failwith ("Unrecognised parameters in " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.rev (IList.fold_left collect [] l) in
let create_method_pattern mp assoc =
let create_method_pattern assoc =
let loop mp = function
| (key, `String s) when key = "class" ->
{ mp with class_name = s }
@ -169,17 +169,17 @@ struct
| (key, _) when key = "language" -> mp
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.fold_left loop default_method_pattern assoc
and create_string_contains sc assoc =
and create_string_contains assoc =
let loop sc = function
| (key, `String pattern) when key = "source_contains" -> pattern
| (key, _) when key = "language" -> sc
| _ -> failwith ("Fails to parse " ^ Yojson.Basic.to_string (`Assoc assoc)) in
IList.fold_left loop default_source_contains assoc in
match detect_pattern assoc with
| Method_pattern (language, mp) ->
Method_pattern (language, create_method_pattern mp assoc)
| Source_contains (language, sc) ->
Source_contains (language, create_string_contains sc assoc)
| Method_pattern (language, _) ->
Method_pattern (language, create_method_pattern assoc)
| Source_contains (language, _) ->
Source_contains (language, create_string_contains assoc)
let rec translate accu (json : Yojson.Basic.json) : pattern list =
match json with
@ -201,7 +201,7 @@ struct
StringMap.add pattern.class_name (pattern:: previous) map)
StringMap.empty
m_patterns in
fun source_file proc_name ->
fun _ proc_name ->
let class_name = Procname.java_get_class proc_name
and method_name = Procname.java_get_method proc_name in
try
@ -217,12 +217,12 @@ struct
let create_file_matcher patterns =
let s_patterns, m_patterns =
let collect (s_patterns, m_patterns) = function
| Source_contains (lang, s) -> (s:: s_patterns, m_patterns)
| Method_pattern (lang, mp) -> (s_patterns, mp :: m_patterns) in
| Source_contains (_, s) -> (s:: s_patterns, m_patterns)
| Method_pattern (_, mp) -> (s_patterns, mp :: m_patterns) in
IList.fold_left collect ([], []) patterns in
let s_matcher =
let matcher = FileContainsStringMatcher.create_matcher s_patterns in
fun source_file proc_name -> matcher source_file
fun source_file _ -> matcher source_file
and m_matcher = create_method_matcher m_patterns in
fun 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)
(** 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
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
@ -364,7 +364,7 @@ let summary_values top_proc_set summary =
let do_spec spec = visited := Specs.Visitedset.union spec.Specs.visited !visited in
IList.iter do_spec specs;
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)
!visited;
Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in
@ -437,7 +437,7 @@ module ProcsCsv = struct
Io_infer.Xml.tag_proof_trace
(** 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 sv = summary_values top_proc_set summary in
pp "\"%s\"," (Escape.escape_csv sv.vname);
@ -530,10 +530,10 @@ module BugsCsv = struct
"advice"
(** 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 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
let err_desc_string = error_desc_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@?"
(** 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 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
let kind = Exceptions.err_kind_string ekind in
let bug_type = Localise.to_string error_name in
@ -617,9 +619,9 @@ end
module BugsTxt = struct
(** 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 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
Exceptions.pp_err (node_id, node_key) loc ekind error_name error_desc None fmt () in
Errlog.iter pp_row err_log
@ -659,7 +661,8 @@ module BugsXml = struct
(** print bugs from summary in xml *)
let pp_bugs error_filter linereader fmt summary =
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
let err_desc_string = error_desc_to_xml_string error_desc in
let precondition_tree () = match pre_opt with
@ -726,7 +729,7 @@ module CallsCsv = struct
Io_infer.Xml.tag_call_trace
(** 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 stats = summary.Specs.stats in
let caller_name = Specs.get_proc_name summary in
@ -746,7 +749,7 @@ module UnitTest = struct
let procs_done = ref []
(** 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 fmt = F.std_formatter in
let do_spec spec =
@ -861,7 +864,7 @@ module Stats = struct
let process_err_log error_filter linereader err_log stats =
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
if in_footprint && error_filter error_desc error_name
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
|| always_report ()) &&
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 calls_csv (fun outf -> F.fprintf outf.fmt "%a" (CallsCsv.pp_calls fname) summary);
do_outf procs_csv (fun outf -> ProcsCsv.pp_summary top_proc_set outf.fmt 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 bugs_csv (fun outf -> BugsCsv.pp_bugs error_filter fname outf.fmt summary);
do_outf bugs_json (fun outf -> BugsJson.pp_bugs error_filter fname outf.fmt summary);
do_outf bugs_txt (fun outf -> BugsTxt.pp_bugs error_filter linereader 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 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 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 !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;
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
let specs = Specs.get_specs_from_payload summary in
let dot_file = DB.filename_add_suffix base ".dot" in
@ -1058,7 +1061,7 @@ module AnalysisResults = struct
| Some summary ->
summaries := (fname, summary) :: !summaries in
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 =
DB.source_file_compare
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 *)
let propagate_nodes_divergence
tenv (pdesc: Cfg.Procdesc.t) (pset: Paths.PathSet.t)
(path: Paths.Path.t) (kind_curr_node : Cfg.Node.nodekind) (_succ_nodes: Cfg.node list)
(exn_nodes: Cfg.node list) (wl : Worklist.t) =
(succ_nodes_: Cfg.node list) (exn_nodes: Cfg.node list) (wl : Worklist.t) =
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 succ_nodes = match State.get_goto_node () with (* handle Sil.Goto_node target, if any *)
| Some node_id ->
IList.filter (fun n -> Cfg.Node.get_id n = node_id) _succ_nodes
| None -> _succ_nodes in
IList.filter (fun n -> Cfg.Node.get_id n = node_id) succ_nodes_
| None -> succ_nodes_ in
if !Config.footprint && not (Paths.PathSet.is_empty (State.get_diverging_states_node ())) then
begin
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)
(* 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
if size > fst !prop_max_size then
(prop_max_size := (size, p);
@ -552,15 +551,14 @@ let forward_tabulate cfg tenv wl =
let pset =
do_symbolic_execution (handle_exn curr_node) cfg tenv curr_node prop path in
L.d_decrease_indent 1; L.d_ln();
propagate_nodes_divergence
tenv proc_desc pset path curr_node_kind succ_nodes exn_nodes wl;
propagate_nodes_divergence tenv proc_desc pset succ_nodes exn_nodes wl;
with
| exn when Exceptions.handle_exception exn && !Config.footprint ->
handle_exn curr_node exn;
if !Config.nonstop then
propagate_nodes_divergence
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 ())
pathset_todo in
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
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 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 sub =
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
Sil.sub_of_list sub_list in
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 =
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 nodes = Cfg.Procdesc.get_nodes proc_desc in
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 "#### Finished: Footprint Computation for %a %a ####@."
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@."
Procname.pp pname
(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
L.out "Finished re-execution for precondition %d %a (%s)@."
(Specs.Jprop.to_number p)
(pp_intra_stats wl cfg pdesc) proc_name
(pp_intra_stats wl pdesc) proc_name
outcome;
speco in
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 ->
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
Config.curr_language := language
(** reset counters before analysing a procedure *)
let reset_global_counters cfg proc_name proc_desc =
let reset_global_counters proc_desc =
Ident.NameGenerator.reset ();
SymOp.reset_total ();
reset_prop_metrics ();
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 *)
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)
(* 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, _) =
match Tabulation.lookup_custom_errors prop with
| None -> errors
@ -1038,7 +1036,7 @@ let is_unavoidable pre =
(** 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
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 is_public_method =
(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)
let report_custom_errors tenv cfg pdesc summary =
let report_custom_errors summary =
let pname = Specs.get_proc_name summary in
let report (pre, custom_error) =
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 exn = Exceptions.Custom_error (custom_error, err_desc) 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 *)
@ -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 stats_failure = match res with
| None -> prev_summary.Specs.stats.Specs.stats_failure
| Some failure_kind -> res in
| Some _ -> res in
let stats =
{ prev_summary.Specs.stats with
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
| Some proc_desc -> proc_desc
| 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 res = Fork.Timeout.exe_timeout (Specs.get_iterations proc_name) go () 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 =
update_summary prev_summary specs phase proc_name elapsed res in
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
report_runtime_exceptions tenv cfg proc_desc updated_summary;
report_runtime_exceptions tenv proc_desc updated_summary;
updated_summary
(** 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 skipped_procs = ref Procname.Set.empty in
let proc_check_skips (pname, dep) =
let proc_check_skips (pname, _) =
let process_skip () =
let call_stats =
(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 *)
let filter_skipped_procs cg procs_and_defined_children =
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 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;
@ -1223,7 +1221,7 @@ let filter_skipped_procs cg procs_and_defined_children =
filter
(** 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
then Specs.get_specs pname = []
else false
@ -1386,7 +1384,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
let _print_stats exe_env =
let proc_is_active proc_desc =
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 =
(** 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

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

@ -131,7 +131,7 @@ module Tags = struct
let create () = ref []
let add tags tag value = tags := (tag, value) :: !tags
let update tags tag value =
let tags' = IList.filter (fun (t, v) -> t <> tag) tags in
let tags' = IList.filter (fun (t, _) -> t <> tag) tags in
(tag, value) :: tags'
let get tags tag =
try
@ -184,8 +184,8 @@ let error_desc_set_bucket err_desc bucket show_in_message =
(** get the value tag, if any *)
let get_value_line_tag tags =
try
let value = snd (IList.find (fun (_tag, value) -> _tag = Tags.value) tags) in
let line = snd (IList.find (fun (_tag, value) -> _tag = Tags.line) tags) in
let value = snd (IList.find (fun (_tag, _) -> _tag = Tags.value) tags) in
let line = snd (IList.find (fun (_tag, _) -> _tag = Tags.line) tags) in
Some [value; line]
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
Tags.add tags Tags.accessed_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
Tags.add tags Tags.assigned_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 rec exp_to_string exp =
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)
| _ -> "" 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
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
@ -713,7 +713,7 @@ let desc_retain_cycle prop cycle loc cycle_dotty =
match Str.split_delim (Str.regexp_string "&old_") s with
| [_; s'] -> s'
| _ -> s in
let do_edge ((se, _), f, se') =
let do_edge ((se, _), f, _) =
match se with
| 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)^"; ";

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
(** 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 *)
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
| Sil.Sizeof _, _ | _, Sil.Sizeof _ ->
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'
| Sil.Cast _, _ | _, Sil.Cast _ ->
None
@ -68,7 +68,7 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
None (* Naive *)
| Sil.Lvar _, _ | _, Sil.Lvar _ ->
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'
| Sil.Lfield _, _ | _, Sil.Lfield _ ->
None
@ -91,7 +91,7 @@ let exp_list_match es1 sub vars es2 =
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 =
match sexp1, sexp2 with
| Sil.Eexp (exp1, inst1), Sil.Eexp (exp2, inst2) ->
| Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) ->
exp_match exp1 sub vars exp2
| Sil.Eexp _, _ | _, Sil.Eexp _ ->
None
@ -180,7 +180,7 @@ let rec instantiate_to_emp p condition sub vars = function
if not hpat.flag then None
else match hpat.hpred with
| 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)
in if (not fully_instantiated) then None else
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) ->
instantiate_to_emp p condition sub_new vars_leftover hpats
end
| Sil.Hdllseg (k, _, iF, oB, oF, iB, _) ->
| Sil.Hdllseg (_, _, iF, oB, oF, iB, _) ->
let fully_instantiated =
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
@ -484,7 +484,7 @@ type iso_mode = Exact | LFieldForget | RFieldForget
let rec generate_todos_from_strexp mode todos sexp1 sexp2 =
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
Some new_todos
| 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 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@."
!nesting
Procname.pp curr_pname
@ -170,8 +170,7 @@ let do_analysis curr_pdesc callee_pname =
when procedure_should_be_analyzed curr_pdesc callee_pname ->
begin
match callbacks.get_proc_desc callee_pname with
| Some proc_desc ->
really_do_analysis callbacks.analyze_ondemand proc_desc
| Some _ -> really_do_analysis callbacks.analyze_ondemand
| None -> ()
end
| _ ->

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

@ -99,7 +99,7 @@ end = struct
let get_description path =
match path with
| Pnode (node, exn_opt, session, path, stats, descr_opt) ->
| Pnode (_, _, _, _, _, descr_opt) ->
descr_opt
| _ -> None
@ -182,9 +182,9 @@ end = struct
(** 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 *)
let rec reset_stats = function
| Pstart (node, stats) ->
| Pstart (_, 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
begin
reset_stats path;
@ -197,7 +197,7 @@ end = struct
reset_stats path2;
set_dummy_stats stats
end
| Pcall (path1, pname, path2, stats) ->
| Pcall (path1, _, path2, stats) ->
if not (stats_is_dummy stats) then
begin
reset_stats path1;
@ -221,7 +221,7 @@ end = struct
stats.max_length <- if found then 1 else 0;
stats.linear_num <- 1.0;
end
| Pnode (node, exn_opt, session, path, stats, _) ->
| Pnode (node, _, _, path, stats, _) ->
if stats_is_dummy stats then
begin
compute_stats do_calls f path;
@ -239,7 +239,7 @@ end = struct
stats.max_length <- max stats1.max_length stats2.max_length;
stats.linear_num <- stats1.linear_num +. stats2.linear_num
end
| Pcall (path1, pname, path2, stats) ->
| Pcall (path1, _, path2, stats) ->
if stats_is_dummy stats then
begin
let stats2 = match do_calls with
@ -287,7 +287,7 @@ end = struct
(filter: Cfg.Node.t -> bool) (path: t) : unit =
let rec doit level session path prev_exn_opt = match path with
| 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 *)
doit level session' p next_exn_opt;
f level path session prev_exn_opt
@ -328,7 +328,7 @@ end = struct
let sequence_up_to_last_seen =
if !position_seen then
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)
else remove_until_seen l
| [] -> [] in
@ -352,7 +352,7 @@ end = struct
end
| None ->
() 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_num = ref 0 in
NodeMap.iter (fun node num -> if num > !max_rep_num then (max_rep_node := node; max_rep_num := num)) !map;
@ -406,10 +406,14 @@ end = struct
F.fprintf fmt "P%d" num
with Not_found ->
match path with
| Pstart (node, _) -> F.fprintf fmt "n%a" Cfg.Node.pp node
| Pnode (node, exn_top, session, path, _, _) -> 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
| Pstart (node, _) ->
F.fprintf fmt "n%a" Cfg.Node.pp node
| Pnode (node, _, session, path, _, _) ->
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 () =
if not (PathMap.is_empty !delayed) then begin
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_description = descr;
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
| Some curr_node ->
begin
@ -585,7 +589,7 @@ module PathSet : sig
end = struct
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
@ -668,7 +672,7 @@ end = struct
let size ps =
let res = ref 0 in
let add p _ = incr res in
let add _ _ = incr res in
let () = PropMap.iter add ps
in !res

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

@ -19,7 +19,7 @@ module AllPreds = struct
NodeHash.clear preds_table
let mk_table cfg =
let do_pdesc pname pdesc =
let do_pdesc _ pdesc =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in
let add_edge is_exn nfrom nto =
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 =
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
| Sil.Set (_, _, e, _)
| Sil.Letderef (_, 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.Abstract _ | Sil.Remove_temps _ | Sil.Stackop _ | Sil.Declare_locals _ -> 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 _ ->
def_instrl cfg (Cfg.Node.get_instrs node) acc
let compute_live_instr cfg tenv pdesc s instr =
use_instr cfg tenv pdesc instr (Vset.diff s (def_instr cfg instr Vset.empty))
let compute_live_instr cfg pdesc s instr =
use_instr cfg pdesc instr (Vset.diff s (def_instr cfg instr Vset.empty))
let compute_live_instrl cfg tenv pdesc instrs livel =
IList.fold_left (compute_live_instr cfg tenv pdesc) livel (IList.rev instrs)
let compute_live_instrl cfg pdesc instrs livel =
IList.fold_left (compute_live_instr cfg pdesc) livel (IList.rev instrs)
module Worklist = struct
module S = Cfg.NodeSet
@ -226,7 +226,7 @@ let compute_candidates procdesc : Vset.t * (Vset.t -> Vset.elt list) =
!candidates, get_sorted_candidates
(** 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
Worklist.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.Prune_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
done
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.
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_is_succ node =
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
aliased_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;
L.out " PROCEDURE %s@." (Procname.to_string pname); *)
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
let replace_dispatch_calls = function
| 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 ->
(* the frontend should not populate the list of 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
IList.sort (fun (_, p1) (_, p2) -> Procname.compare p1 p2) overrides in
(match sorted_overrides with
| ((_, target_pname) :: targets) as all_targets ->
| ((_, target_pname) :: _) as all_targets ->
let targets_to_add =
if Config.sound_dynamic_dispatch then
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 =
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 ();
if !Config.curr_language = Config.Java
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 *)
let create_errors_per_line err_log =
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
try
let set = Hashtbl.find err_per_line loc.Location.line in
@ -373,7 +373,7 @@ end = struct
end
(** 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 tbl = Hashtbl.create 11 in
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 =
match mangled1, mangled2 with
| Some mangled1, None -> 1
| None, Some mangled2 -> -1
| Some _, None -> 1
| None, Some _ -> -1
| None, None -> 0
| Some mangled1, Some mangled2 ->
string_compare mangled1 mangled2
@ -328,7 +328,7 @@ let java_is_anonymous_inner_class = function
let java_remove_hidden_inner_class_parameter = function
| Java_method js ->
(match IList.rev js.parameters with
| (so, s) :: par' ->
| (_, s) :: par' ->
if is_anonymous_inner_class_name s
then Some (Java_method { js with parameters = IList.rev par'})
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 *)
let is_infer_undefined pn = match pn with
| Java_method j ->
| Java_method _ ->
let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in
Str.string_match regexp (java_get_class pn) 0
| _ ->
@ -439,7 +439,7 @@ let to_simplified_string ?(withclass = false) p =
| C_function (c1, c2) ->
to_readable_string (c1, c2) false ^ "()"
| ObjC_Cpp_method osig -> c_method_to_string osig Simple
| ObjC_block name -> "block"
| ObjC_block _ -> "block"
(** Convert a proc name to a filename *)
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
(** 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
begin match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, se, te) ->
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 in
(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 pp_stack fmt _sg =
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
(match pe.pe_kind with
| 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 env = ref [] in
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
| _ -> () in
IList.iter filter sigma;
let find e =
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
find
@ -287,7 +287,7 @@ let pp_prop pe0 f prop =
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_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
then ()
else if latex then
@ -573,7 +573,7 @@ let sym_eval abs e =
eval (Sil.BinOp (Sil.PlusPI, e11, e2'))
| Sil.BinOp
(Sil.PlusA,
(Sil.Sizeof (Sil.Tstruct struct_typ, st) as e1),
(Sil.Sizeof (Sil.Tstruct struct_typ, _) as e1),
e2) ->
(* 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
@ -698,7 +698,7 @@ let sym_eval abs e =
Sil.exp_int (Sil.Int.mul n m)
| Sil.Const (Sil.Cfloat v), Sil.Const (Sil.Cfloat w) ->
Sil.exp_float (v *. w)
| Sil.Var v, Sil.Var w ->
| Sil.Var _, Sil.Var _ ->
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 (typ_normalize sub t, exp_normalize sub e)
| Sil.Tenum econsts ->
| Sil.Tenum _ ->
typ
let run_with_abs_val_eq_zero f =
@ -1003,7 +1003,7 @@ let atom_normalize sub a0 =
(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 *)
(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
then normalize_eq (e1', e2')
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. *)
let mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred =
let default_strexp () = match te with
| Sil.Sizeof (typ, st) ->
| Sil.Sizeof (typ, _) ->
create_strexp_of_type tenvo struct_init_mode typ inst
| Sil.Var id ->
| Sil.Var _ ->
Sil.Estruct ([], inst)
| 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_te = texp_normalize sub te in
begin match normalized_cnt, normalized_te with
| Sil.Earray (Sil.Sizeof (t, st1), [], inst), Sil.Sizeof (Sil.Tarray _, st2) ->
(* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *)
| 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 *)
let hpred' = mk_ptsto_exp None Fld_init (root, Sil.Sizeof (t, st1), None) inst in
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, x, Sil.Sizeof (t, st1)), esel, inst), Sil.Sizeof (Sil.Tarray _, st2) ->
(* 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
| Sil.Earray (Sil.BinOp(Sil.Mult, Sil.Sizeof (t, st1), x), esel, inst),
Sil.Sizeof (Sil.Tarray _, _)
| Sil.Earray (Sil.BinOp(Sil.Mult, x, Sil.Sizeof (t, st1)), esel, inst),
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)
| _ -> Sil.Hpointsto (normalized_root, normalized_cnt, normalized_te)
end
@ -1176,7 +1181,7 @@ let rec hpred_normalize sub hpred =
let normalized_e1 = exp_normalize sub e1 in
let normalized_e2 = exp_normalize sub e2 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.Hdllseg (k, para, e1, e2, e3, e4, elist) ->
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_e4 = exp_normalize sub e4 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)
and hpara_normalize sub para =
and hpara_normalize para =
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
{ 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 sorted_body = IList.sort Sil.hpred_compare normalized_body in
{ para with Sil.body_dll = sorted_body }
@ -1302,7 +1307,7 @@ let pi_normalize sub sigma pi0 =
not (syntactically_different (e1, e2))
| Sil.Aeq(Sil.Const c1, Sil.Const 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'' = pi_sorted_remove_redundant pi' in
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,
this function reduces x[1][1] to x[2]. The [typ] argument is used
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
| Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true
| _ -> 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 *)
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.Construct a dllseg predicate *)
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.Construct a hpara *)
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
hpara_normalize Sil.sub_empty para
hpara_normalize para
(** Sil.Construct a dll_hpara *)
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
hpara_dll_normalize Sil.sub_empty para
hpara_dll_normalize para
(** Proposition [true /\ emp]. *)
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
| _ -> false in
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
let fld, _ = IList.find (fun fld -> strexp_matches snk_exp fld) flds 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 *)
let remove_attribute att prop =
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), e) ->
| Sil.Aneq (_, Sil.Const (Sil.Cattribute att_old))
| Sil.Aneq (Sil.Const (Sil.Cattribute att_old), _) ->
if Sil.attribute_equal att_old att then
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 *)
let replace_objc_null prop lhs_exp rhs_exp =
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 = conjoin_eq rhs_exp Sil.exp_zero prop in
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 =
match exp with
| Sil.BinOp (op, exp1, exp2) ->
| Sil.BinOp (_, exp1, exp2) ->
let prop' = nullify_exp_with_objc_null prop exp1 in
nullify_exp_with_objc_null prop' exp2
| Sil.UnOp (op, exp, _) ->
| Sil.UnOp (_, exp, _) ->
nullify_exp_with_objc_null prop exp
| Sil.Var name ->
| Sil.Var _ ->
(match get_objc_null_attribute prop exp with
| Some att ->
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 rec handle_strexp = function
| Sil.Eexp (e, inst) -> ExpStack.push e
| Sil.Estruct (fld_se_list, inst) ->
| Sil.Eexp (e, _) -> ExpStack.push e
| Sil.Estruct (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
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
| Sil.Eexp _ -> acc
| Sil.Estruct (fsel, inst) ->
| Sil.Estruct (fsel, _) ->
let se_list = IList.map snd fsel in
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 se_list = IList.map snd isel in
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.Tarray (t, e) ->
Sil.Tarray (typ_captured_ren ren t, exp_captured_ren ren e)
| Sil.Tenum econsts ->
| Sil.Tenum _ ->
typ
let atom_captured_ren ren = function
@ -2600,7 +2605,7 @@ let prop_iter_make_id_primed id iter =
let rec get_eqs acc = function
| [] | [_] ->
IList.rev acc
| (_, e1) :: (((_, e2) :: pairs') as pairs) ->
| (_, e1) :: (((_, e2) :: _) as pairs) ->
get_eqs (Sil.Aeq(e1, e2):: acc) pairs in
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,
this function reduces x[1][1] to x[2]. The [typ] argument is used
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.
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
(** 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 *)
(** 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
| Ehpred (Sil.Hpointsto(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.Aneq (e1, _)) -> e1
| Esub_entry (x, e) -> Sil.Var x
| Esub_entry (x, _) -> Sil.Var x
(** Return the successor nodes of the edge *)
let edge_get_succs = function
| Ehpred hpred -> Sil.ExpSet.elements (Prop.hpred_get_targets hpred)
| Eatom (Sil.Aeq (_, e2)) -> [e2]
| Eatom (Sil.Aneq (_, e2)) -> [e2]
| Esub_entry (s, e) -> [e]
| Esub_entry (_, e) -> [e]
let get_sigma footprint_part 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] *)
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, _) ->
compute_fsel_diff fsel1 fsel2
| 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
(** 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 *)
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
then Some offlist_past
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.Lindex(sub_exp, e) -> f (Sil.Off_index e :: offlist_past) sub_exp
in f [] exp
@ -623,14 +623,14 @@ let check_disequal prop e1 e2 =
else
let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest')
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, oB, oF, iB, _) :: sigma_rest ->
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest ->
if is_root prop iF e != None || is_root prop iB e != None then
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) as hpred :: sigma_rest ->
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, _, oF, _, _) as hpred :: sigma_rest ->
(match is_root prop iF e with
| None ->
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
in f e_new [] sigma_new
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
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
then
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, 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)
| Sil.Var v1, e2 ->
| Sil.Var _, e2 ->
if calc_missing then
let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in
subs
@ -1141,7 +1142,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
| Sil.Const c1, Sil.Const c2 ->
if (Sil.const_equal c1 c2) then subs
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))))
| Sil.Const (Sil.Cint n1), Sil.BinOp (Sil.PlusA, f1, Sil.Const (Sil.Cint n2)) ->
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))
| e1, Sil.Const _ ->
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
| Sil.Lindex(e1, f1), Sil.Lindex(e2, f2) ->
do_imply (do_imply subs e1 e2) f1 f2
@ -1171,7 +1172,7 @@ let path_to_id path =
| Sil.Var id ->
if Ident.is_footprint id then None
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
| None -> None
| Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld)))
@ -1179,7 +1180,7 @@ let path_to_id path =
(match f e with
| None -> None
| Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind)))
| Sil.Lvar pv ->
| Sil.Lvar _ ->
Some (Sil.exp_to_string path)
| Sil.Const (Sil.Cstr 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) =
(* 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
| Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) ->
| Sil.Eexp (e1, _), Sil.Eexp (e2, _) ->
(exp_imply calc_missing subs e1 e2, None, None)
| Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) ->
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_missing_opt = if fld_missing != [] then Some (Sil.Estruct (fld_missing, inst1)) else None in
subs', fld_frame_opt, fld_missing_opt
| Sil.Estruct _, Sil.Eexp (e2, inst2) ->
| Sil.Estruct _, Sil.Eexp (e2, _) ->
begin
let e2' = Sil.exp_sub (snd subs) e2 in
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') ->
d_impl_err ("WARNING: function call with parameters of struct type, treating as unknown", subs, (EXC_FALSE_SEXPS (se1, se2)));
let fsel' =
let g (f, se) = (f, Sil.Eexp (Sil.Var (Ident.create_fresh Ident.knormal), inst)) in
let g (f, _) = (f, Sil.Eexp (Sil.Var (Ident.create_fresh Ident.knormal), inst)) in
IList.map g fsel in
sexp_imply source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 typ2
| Sil.Eexp _, Sil.Earray (size, esel, inst)
| Sil.Estruct _, Sil.Earray (size, esel, inst) ->
| Sil.Eexp _, Sil.Earray (size, _, inst)
| Sil.Estruct _, Sil.Earray (size, _, inst) ->
let se1' = Sil.Earray (size, [(Sil.exp_zero, se1)], inst) in
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 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 *)
@ -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 =
match se2 with
| Sil.Eexp (_e2, inst) ->
| Sil.Eexp (_e2, _) ->
let e2 = Sil.exp_sub (snd subs) _e2 in
begin
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))
end
| 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, _) ->
(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
| [],[] -> subs
@ -1357,11 +1358,11 @@ let filter_ne_lhs sub e0 = function
| _ -> None
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
| 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 *)
| 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
| 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
| Sil.Lindex (e, _) ->
find_primed e
| Sil.BinOp (Sil.PlusPI, e1, e2) ->
| Sil.BinOp (Sil.PlusPI, e1, _) ->
find_primed e1
| _ ->
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
| Sil.Hlseg (_, _, e, _, _) ->
exp_has_primed e
| Sil.Hdllseg (_, _, iF, oB, oF, iB, _) ->
| Sil.Hdllseg (_, _, iF, _, _, iB, _) ->
exp_has_primed iF && exp_has_primed iB
let move_primed_lhs_from_front subs sigma = match sigma with
| [] -> sigma
| hpred:: sigma' ->
| hpred:: _ ->
if hpred_has_primed_lhs (snd subs) hpred then
let (sigma_primed, sigma_unprimed) = IList.partition (hpred_has_primed_lhs (snd subs)) sigma
in match sigma_unprimed with
@ -1583,7 +1584,7 @@ end
let cast_exception tenv texp1 texp2 e1 subs =
let _ = match texp1, texp2 with
| Sil.Sizeof (t1, st1), Sil.Sizeof (t2, st2) ->
| Sil.Sizeof (t1, _), Sil.Sizeof (t2, st2) ->
if !Config.developer_mode ||
(Sil.Subtype.is_cast st2 &&
not (Subtyping_check.check_subtype tenv t1 t2)) then
@ -1642,7 +1643,7 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing =
begin
match pos_type_opt with
| None -> cast_exception tenv texp1 texp2 e1 subs
| Some texp1' ->
| Some _ ->
if has_changed then None, pos_type_opt (* missing *)
else pos_type_opt, None (* frame *)
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
only active in type_size mode *)
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
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'
@ -1687,7 +1688,9 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2
| _ -> false in
if IList.exists filter sigma2 then !sub_opt else None in
let add_subtype () = match texp1, texp2, se1, se2 with
| Sil.Sizeof(Sil.Tptr (_t1, _), _), Sil.Sizeof(Sil.Tptr (_t2, _), sub2), Sil.Eexp(e1', _), Sil.Eexp(e2', _) when not (is_allocated_lhs e1') ->
| Sil.Sizeof(Sil.Tptr (_t1, _), _), Sil.Sizeof(Sil.Tptr (_t2, _), _),
Sil.Eexp(e1', _), Sil.Eexp(e2', _)
when not (is_allocated_lhs e1') ->
begin
let t1, t2 = Sil.expand_type tenv _t1, Sil.expand_type tenv _t2 in
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) ->
let e2 = Sil.exp_sub (snd subs) _e2 in
let _ = match e2 with
| Sil.Lvar p -> ()
| Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2));
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'
in (subs', prop1')
with
| IMPL_EXC (s, _, body) when calc_missing ->
| IMPL_EXC (s, _, _) when calc_missing ->
raise (MISSING_EXC s))
| Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (** Unroll lseg *)
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 *)
let e2, f2 = Sil.exp_sub (snd subs) _e2, Sil.exp_sub (snd subs) _f2 in
let _ = match e2 with
| Sil.Lvar p -> ()
| Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs |-> not implemented", subs, (EXC_FALSE_HPRED hpred2));
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, _, _, _, _, _, _) ->
(d_impl_err ("rhs dllsegPE not implemented", subs, (EXC_FALSE_HPRED hpred2));
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 iB2, oB2 = Sil.exp_sub (snd subs) iB2, Sil.exp_sub (snd subs) oB2 in
let _ = match oF2 with
| Sil.Lvar p -> ()
| Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented __POS__))
| _ -> ()
in
let _ = match oB2 with
| Sil.Lvar p -> ()
| Sil.Lvar _ -> ()
| Sil.Var v -> if Ident.is_primed v then
(d_impl_err ("rhs dllseg not implemented", subs, (EXC_FALSE_HPRED hpred2));
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;
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 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
@ -2044,19 +2048,19 @@ let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
(* The commented-out condition should always hold. *)
let sub2' = extend_sub (snd subs) v2 e2 in
pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2'
| e2, f2 ->
| _ ->
let pi1' = Prop.pi_sub (fst 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));
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'
| Sil.Aneq (Sil.Var v, f2):: pi2' ->
| Sil.Aneq (Sil.Var v, _):: pi2' ->
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))
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'
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 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
| Sil.Const _ -> true
| _ -> false in
@ -73,14 +73,14 @@ let check_bad_index pname tenv p size index loc =
end
(** Perform bounds checking *)
let bounds_check pname tenv prop size e =
let bounds_check pname prop size e =
if !Config.trace_rearrange then
begin
L.d_str "Bounds check index:"; Sil.d_exp e;
L.d_str " size: "; Sil.d_exp size;
L.d_ln()
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
(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.Earray(size, [], inst), t)
| 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' =
create_struct_values
@ -191,7 +191,7 @@ let rec _strexp_extend_values
let off_new = Sil.Off_index(Sil.exp_zero):: off in
_strexp_extend_values
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
_strexp_extend_values
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 _, typ', _ =
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)
with Not_found ->
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
[(atoms', Sil.Estruct (res_fsel', inst'), struct_typ)]
end
| (Sil.Off_fld (f, _)):: off', _, _ ->
| (Sil.Off_fld (_, _)):: _, _, _ ->
raise (Exceptions.Bad_footprint __POS__)
| (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tint _
@ -252,7 +252,7 @@ let rec _strexp_extend_values
_strexp_extend_values
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') ->
bounds_check pname tenv orig_prop size e (State.get_loc ());
bounds_check pname orig_prop size e (State.get_loc ());
begin
try
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. *)
let prop_iter_check_fields_ptsto_shallow iter lexp =
let offset = Sil.exp_get_offsets lexp in
let (e, se, t) =
let (_, se, _) =
match Prop.prop_iter_current iter with
| Sil.Hpointsto (e, se, t), _ -> (e, se, t)
| _ -> assert false in
@ -461,7 +461,7 @@ let prop_iter_check_fields_ptsto_shallow iter lexp =
check_offset se' off'
with Not_found -> Some fld)
| _ -> Some fld)
| (Sil.Off_index e):: off' -> None in
| (Sil.Off_index _):: _ -> None in
check_offset se offset
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 =
IList.partition (function
| Sil.Hpointsto(e', _, _) -> Sil.exp_equal e e'
| Sil.Hlseg (_, _, e1, e2, _) -> Sil.exp_equal e e1
| Sil.Hdllseg (_, _, e_iF, e_oB, e_oF, e_iB, _) -> Sil.exp_equal e e_iF || Sil.exp_equal e e_iB
| Sil.Hlseg (_, _, e1, _, _) -> Sil.exp_equal e e1
| Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) ->
Sil.exp_equal e e_iF || Sil.exp_equal e e_iB
) footprint_sigma in
let atoms_sigma_list =
match sigma_pto with
@ -797,8 +798,8 @@ let type_at_offset texp off =
| (Sil.Off_fld (f, _)):: off', Sil.Tstruct { Sil.instance_fields } ->
(try
let typ' =
(fun (x, y, z) -> y)
(IList.find (fun (f', t', a') -> Ident.fieldname_equal f f') instance_fields) in
(fun (_, y, _) -> y)
(IList.find (fun (f', _, _) -> Ident.fieldname_equal f f') instance_fields) in
strip_offset off' typ'
with Not_found -> None)
| (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);
(* it's ok for a non-nullable local to point to deref_exp *)
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 =
match Annotations.get_field_type_and_annotation fld typ with
| 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 =
try
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 read () =
try
@ -66,7 +66,7 @@ let create_serializer (key : key) : 'a serializer =
close_in inc;
value_option
with
| Sys_error s -> None in
| Sys_error _ -> None in
let timeout = 1.0 in
let catch_exn = function
| 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. *)
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
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 *)
let get_sentinel_func_attribute_value attr_list =
(* Sentinel is the only kind of attributes *)
let is_sentinel a = true in
try
match IList.find is_sentinel attr_list with
| FA_sentinel (sentinel, null_pos) -> Some (sentinel, null_pos)
with Not_found -> None
match attr_list with
| FA_sentinel (sentinel, null_pos) :: _ -> Some (sentinel, null_pos)
| [] -> None
(** Kind of global variables *)
type pvar_kind =
@ -306,7 +303,7 @@ module Subtype = struct
let compare 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
let update_flag c1 c2 flag flag' =
@ -409,16 +406,16 @@ module Subtype = struct
else (None, Some st1) in
(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) =
if f c1 c2 then (Some st, None)
else if f c2 c1 then
match st with
| Exact, flag ->
| Exact, _ ->
if Typename.equal c1 c2
then (Some st, None)
else (None, Some st)
| Subtypes _ , flag ->
| Subtypes _ , _ ->
if Typename.equal c1 c2
then (Some st, None)
else (Some st, Some st)
@ -490,11 +487,11 @@ end = struct
if area unsigned i = 3 then None (* not representable as signed *)
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
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 area2 = area unsigned2 i2 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_int64_unsigned i unsigned = (unsigned, i, false)
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 zero = of_int 0
let one = of_int 1
let two = of_int 2
let minus_one = of_int (-1)
let isone (_, i, ptr) = i = 1L
let iszero (_, i, ptr) = i = 0L
let isone (_, i, _) = i = 1L
let iszero (_, i, _) = i = 0L
let isnull (_, i, ptr) = i = 0L && ptr
let isminusone (unsigned, i, ptr) = not unsigned && i = -1L
let isnegative (unsigned, i, ptr) = not unsigned && i < 0L
let isminusone (unsigned, i, _) = not unsigned && i = -1L
let isnegative (unsigned, i, _) = not unsigned && i < 0L
let neg (unsigned, i, ptr) = (unsigned, Int64.neg i, ptr)
@ -834,7 +831,7 @@ let objc_ref_counter_field =
(** {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)
let has_objc_ref_counter hpred =
@ -886,7 +883,7 @@ let pvar_get_simplified_name pv =
match string_split_character s '.' with
| Some s1, s2 ->
(match string_split_character s1 '.' with
| Some s3, s4 -> s4 ^ "." ^ s2
| Some _, s4 -> s4 ^ "." ^ s2
| _ -> 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 var_name = Mangled.to_string(pvar_get_name pvar) in
match Str.split_delim (Str.regexp_string pname) var_name with
| [s1; s2] -> true
| [_; _] -> true
| _ -> false
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 =
if se1 == se2 then 0
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
| 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
| Earray (e1, esel1, inst1), Earray (e2, esel2, inst2) ->
| Earray (e1, esel1, _), Earray (e2, esel2, _) ->
let n = exp_compare e1 e2 in
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
| [] -> ()
| [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;
color_post_wrapper changed pe0 f
| 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;
color_post_wrapper changed pe0 f;
F.fprintf f ", ";
@ -1769,15 +1766,15 @@ let rec _pp_pvar f pv =
let pp_pvar_latex f pv =
let name = pv.pv_name in
match pv.pv_kind with
| Local_var n ->
| Local_var _ ->
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)
(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)
(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)
(Latex.pp_string Latex.Roman) "abductedRefParam"
| Global_var ->
@ -1852,7 +1849,7 @@ let rec dexp_to_string = function
Procname.to_simplified_string pn
| Dconst c -> exp_to_string (Const c)
| 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_args fmt des =
if eradicate_java ()
@ -1882,7 +1879,7 @@ let rec dexp_to_string = function
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 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
| Ddot (de, f) ->
if Ident.fieldname_is_hidden f then "&" ^ dexp_to_string de
@ -1898,18 +1895,18 @@ let rec dexp_to_string = function
else "&" in
ampersand ^ s
| 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"
| Dretcall (de, _, _, _) ->
"returned by " ^ (dexp_to_string de)
(** 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 *)
and pp_vpath pe fmt vpath =
let pp fmt = function
| Some de -> pp_dexp pe fmt de
| Some de -> pp_dexp fmt de
| None -> () in
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 ()
@ -1952,7 +1949,7 @@ and attribute_to_string pe = function
| Auntaint -> "UNTAINTED"
| Alocked -> "LOCKED"
| Aunlocked -> "UNLOCKED"
| Adiv0 (pn, nd_id) -> "DIV0"
| Adiv0 (_, _) -> "DIV0"
| Aobjc_null exp ->
let info_s =
match exp with
@ -1975,7 +1972,7 @@ and pp_const pe f = function
| Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att)
| Cexn e -> F.fprintf f "EXN %a" (pp_exp pe) e
| 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
(** 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"
(Csu.name struct_typ.csu)
Mangled.pp name
(pp_seq (fun f (fld, t, ann) ->
(pp_seq (fun f (fld, t, _) ->
F.fprintf f "%a %a"
(pp_typ_full pe) t
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) ->
F.fprintf f "%s {%a} %a"
(Csu.name struct_typ.csu)
(pp_seq (fun f (fld, t, ann) ->
(pp_seq (fun f (fld, t, _) ->
F.fprintf f "%a %a"
(pp_typ_full pe) t
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
(** 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. *)
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, 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
| 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
| Sizeof (t, s) -> F.fprintf f "sizeof(%a%a)" pp_t t Subtype.pp s
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 *)
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
(** dump an offset. *)
@ -2184,7 +2181,7 @@ let pp_instr pe0 f instr =
(pp_typ pe) t
(pp_exp pe) e2
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
| Call (ret_ids, e, arg_ts, loc, cf) ->
(match ret_ids with
@ -2209,7 +2206,7 @@ let pp_instr pe0 f instr =
F.fprintf f "STACKOP.%s; %a" s Location.pp 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" (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
| Goto_node (e, 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 =
match Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) s with
| s1:: s2:: _ -> true
| _ :: _ :: _ -> true
| _ -> false
(** 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
| Tfun _ ->
()
| Tptr (t', pk) ->
| Tptr (t', _) ->
typ_iter_types f t'
| Tstruct struct_typ ->
IList.iter (fun (_, t, _) -> typ_iter_types f t) struct_typ.instance_fields
| Tarray (t, e) ->
typ_iter_types f t;
exp_iter_types f e
| Tenum econsts ->
| Tenum _ ->
()
(** Iterate over all the subtypes in the type (including the type itself) *)
and exp_iter_types f e =
match e with
| Var id -> ()
| Var _ -> ()
| Const (Cexn e1) ->
exp_iter_types f e1
| Const (Ctuple el) ->
@ -2262,48 +2259,48 @@ and exp_iter_types f e =
| Cast (t, e1) ->
typ_iter_types f t;
exp_iter_types f e1
| UnOp (op, e1, typo) ->
| UnOp (_, e1, typo) ->
exp_iter_types f e1;
(match typo with
| Some t -> typ_iter_types f t
| None -> ())
| BinOp (op, e1, e2) ->
| BinOp (_, e1, e2) ->
exp_iter_types f e1;
exp_iter_types f e2
| Lvar id ->
| Lvar _ ->
()
| Lfield (e1, fld, typ) ->
| Lfield (e1, _, typ) ->
exp_iter_types f e1;
typ_iter_types f typ
| Lindex (e1, e2) ->
exp_iter_types f e1;
exp_iter_types f e2
| Sizeof (t, s) ->
| Sizeof (t, _) ->
typ_iter_types f t
(** Iterate over all the types (and subtypes) in the instruction *)
let instr_iter_types f instr = match instr with
| Letderef (id, e, t, loc) ->
| Letderef (_, e, t, _) ->
exp_iter_types f e;
typ_iter_types f t
| Set (e1, t, e2, loc) ->
| Set (e1, t, e2, _) ->
exp_iter_types f e1;
typ_iter_types f t;
exp_iter_types f e2
| Prune (cond, loc, true_branch, ik) ->
| Prune (cond, _, _, _) ->
exp_iter_types f cond
| Call (ret_ids, e, arg_ts, loc, cf) ->
| Call (_, e, arg_ts, _, _) ->
exp_iter_types f e;
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
| 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
| PP_LATEX ->
F.fprintf f "%a{=}%a" (pp_exp pe) e1 (pp_exp pe) e2)
| Aneq ((Const (Cattribute a) as ea), e)
| Aneq (e, (Const (Cattribute a) as ea)) ->
| Aneq ((Const (Cattribute _) as ea), e)
| Aneq (e, (Const (Cattribute _) as ea)) ->
F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e
| Aneq (e1, e2) ->
(match pe.pe_kind with
@ -2435,9 +2432,9 @@ end = struct
let rec process_sexp env = function
| Eexp _ -> ()
| Earray (_, esel, _) ->
IList.iter (fun (e, se) -> process_sexp env se) esel
IList.iter (fun (_, se) -> process_sexp env se) esel
| 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 *)
let rec process_hpred env = function
@ -2504,15 +2501,15 @@ let inst_new_loc loc inst = match inst with
| Iabstraction -> inst
| Iactual_precondition -> inst
| Ialloc -> inst
| Iformal (zf, ncf) -> inst
| Iformal _ -> inst
| Iinitial -> inst
| Ilookup -> inst
| Inone -> 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
| Iupdate (zf, ncf, n, pos) -> Iupdate (zf, ncf, loc.Location.line, pos)
| Ireturn_from_call n -> Ireturn_from_call loc.Location.line
| Iupdate (zf, ncf, _, pos) -> Iupdate (zf, ncf, loc.Location.line, pos)
| Ireturn_from_call _ -> Ireturn_from_call loc.Location.line
(** return a string representing the inst *)
let inst_to_string inst =
@ -2560,14 +2557,14 @@ let inst_zero_flag = function
| Iabstraction -> None
| Iactual_precondition -> None
| Ialloc -> None
| Iformal (zf, ncf) -> zf
| Iformal (zf, _) -> zf
| Iinitial -> None
| Ilookup -> None
| Inone -> None
| Inullify -> None
| Irearrange (zf, ncf, n, _) -> zf
| Irearrange (zf, _, _, _) -> zf
| Itaint -> None
| Iupdate (zf, ncf, n, _) -> zf
| Iupdate (zf, _, _, _) -> zf
| Ireturn_from_call _ -> None
(** Set the null case flag of the inst. *)
@ -2652,7 +2649,7 @@ and pp_hpred_env pe0 envo f hpred =
begin match hpred with
| Hpointsto (e, se, te) ->
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 in
(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 *)
let texp_to_typ default_opt = function
| Sizeof (t, _) -> t
| t ->
| _ ->
unsome_typ "texp_to_typ" default_opt
(** 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
function
| Tstruct struct_typ ->
(try (fun (x, y, z) -> y)
(IList.find (fun (_f, t, ann) ->
(try (fun (_, y, _) -> y)
(IList.find (fun (_f, _, _) ->
Ident.fieldname_equal _f f) struct_typ.instance_fields)
with Not_found -> 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 *)
let array_typ_elem default_opt = function
| Tarray (t_el, _) -> t_el
| t ->
| _ ->
unsome_typ "array_typ_elem" default_opt
(** Return the root of [lexp]. *)
let rec root_of_lexp lexp = match lexp with
| Var _ -> lexp
| Const _ -> lexp
| Cast (t, e) -> root_of_lexp e
| Cast (_, e) -> root_of_lexp e
| UnOp _ | BinOp _ -> lexp
| Lvar _ -> lexp
| Lfield(e, _, _) -> root_of_lexp e
@ -2928,7 +2925,7 @@ let exp_lt e1 e2 =
(** {2 Functions for computing program variables} *)
let rec exp_fpv = function
| Var id -> []
| Var _ -> []
| Const (Cexn e) -> exp_fpv e
| Const (Ctuple el) -> exp_list_fpv el
| Const _ -> []
@ -2946,11 +2943,11 @@ let atom_fpv = function
| Aneq (e1, e2) -> exp_fpv e1 @ exp_fpv e2
let rec strexp_fpv = function
| Eexp (e, inst) -> exp_fpv e
| Estruct (fld_se_list, inst) ->
| Eexp (e, _) -> exp_fpv e
| Estruct (fld_se_list, _) ->
let f (_, se) = strexp_fpv se in
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 f (idx, se) = exp_fpv idx @ strexp_fpv se in
fpv_in_size @ IList.flatten (IList.map f idx_se_list)
@ -3096,7 +3093,7 @@ let rec exp_fav_add fav = function
| Const _ -> ()
| Cast (_, e) | UnOp (_, e, _) -> exp_fav_add fav e
| 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
| Lindex (e1, e2) -> exp_fav_add fav e1; exp_fav_add fav e2
| Sizeof _ -> ()
@ -3121,25 +3118,20 @@ let atom_fav =
(** Atoms do not contain binders *)
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
| Eexp (e, inst) -> exp_fav_add fav e
| Estruct (fld_se_list, inst) ->
| Eexp (e, _) -> exp_fav_add fav e
| Estruct (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;
IList.iter (fun (e, se) -> exp_fav_add fav e; strexp_fav_add fav se) idx_se_list
let hpred_fav_add fav = function
| Hpointsto (base, sexp, te) -> exp_fav_add fav base; strexp_fav_add fav sexp; exp_fav_add fav te
| Hlseg (_, para, e1, e2, elist) ->
hpara_fav_add fav para;
| Hlseg (_, _, e1, e2, elist) ->
exp_fav_add fav e1; exp_fav_add fav e2;
IList.iter (exp_fav_add fav) elist
| Hdllseg (_, para, e1, e2, e3, e4, elist) ->
hpara_dll_fav_add fav para;
| Hdllseg (_, _, e1, e2, e3, e4, elist) ->
exp_fav_add fav e1; exp_fav_add fav e2;
exp_fav_add fav e3; exp_fav_add fav e4;
IList.iter (exp_fav_add fav) elist
@ -3387,7 +3379,7 @@ let rec typ_sub (subst: subst) typ =
Tptr (typ_sub subst t', pk)
| Tarray (t, e) ->
Tarray (typ_sub subst t, exp_sub subst e)
| Tenum econsts ->
| Tenum _ ->
typ
and exp_sub (subst: subst) e =
@ -3418,7 +3410,7 @@ and exp_sub (subst: subst) e =
let e1' = exp_sub subst e1 in
let e2' = exp_sub subst e2 in
BinOp (op, e1', e2')
| Lvar id ->
| Lvar _ ->
e
| Lfield (e1, fld, typ) ->
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) ->
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)
| Nullify (pvar, loc, deallocate) ->
| Nullify _ ->
instr
| Abstract loc ->
| Abstract _ ->
instr
| Remove_temps (temps, loc) ->
Remove_temps (IList.map id_s temps, loc)
| Stackop (stackop, loc) ->
| Stackop _ ->
instr
| Declare_locals (ptl, loc) ->
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] *)
0, ExpMap.add e1 e2 exp_map in
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) ->
let n = unop_compare o1 o2 in
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) ->
let n, exp_map = exp_compare_structural e1 e2 exp_map in
(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) ->
let n, exp_map = exp_compare_structural e1 e2 exp_map in
(if n <> 0 then n
@ -3596,26 +3588,26 @@ let instr_compare_structural instr1 instr2 exp_map =
ids1
ids2 in
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
if n <> 0 then n, exp_map
else
let n, exp_map = exp_compare_structural e1 e2 exp_map in
(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
if n <> 0 then n, exp_map
else
let n = typ_compare t1 t2 in
if n <> 0 then n, 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
(if n <> 0 then n
else let n = bool_compare true_branch1 true_branch2 in
if n <> 0 then n
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 n = Pervasives.compare (IList.length args1) (IList.length args2) in
if n <> 0 then n, exp_map
@ -3634,15 +3626,15 @@ let instr_compare_structural instr1 instr2 exp_map =
else
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
| 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
(if n <> 0 then n else bool_compare deallocate1 deallocate2), exp_map
| Abstract loc1, Abstract loc2 -> 0, exp_map
| Remove_temps (temps1, loc1), Remove_temps (temps2, loc2) ->
| Abstract _, Abstract _ -> 0, exp_map
| Remove_temps (temps1, _), Remove_temps (temps2, _) ->
id_list_compare_structural temps1 temps2 exp_map
| Stackop (stackop1, loc1), Stackop (stackop2, loc2) ->
| Stackop (stackop1, _), Stackop (stackop2, _) ->
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
if n <> 0 then n, exp_map
else
@ -3655,7 +3647,7 @@ let instr_compare_structural instr1 instr2 exp_map =
(0, exp_map)
ptl1
ptl2
| Goto_node (e1, loc1), Goto_node (e2, loc2) ->
| Goto_node (e1, _), Goto_node (e2, _) ->
exp_compare_structural e1 e2 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
hpred_expmap f
let hpara_sub subst para = para
(** {2 Functions for replacing occurrences of expressions.} *)
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 rec f offlist_past e = match e with
| 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
| Lindex(sub_exp, e) -> f (Off_index e :: offlist_past) sub_exp in
f [] exp
@ -3927,7 +3917,7 @@ let hpara_instantiate para e1 e2 elist =
try (IList.map2 g para.svars elist)
with Invalid_argument _ -> assert false in
let ids_evars =
let g id = Ident.create_fresh Ident.kprimed in
let g _ = Ident.create_fresh Ident.kprimed in
IList.map g para.evars in
let subst_for_evars =
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)
with Invalid_argument _ -> assert false in
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
let subst_for_evars =
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
(** Pretty print a dexp. *)
val pp_dexp : printenv -> Format.formatter -> dexp -> unit
val pp_dexp : Format.formatter -> dexp -> unit
(** Pretty print an expression. *)
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 hpara_fav_add : fav -> hpara -> unit
(** Variables in hpara, excluding bound vars in the body *)
val hpara_shallow_av : hpara -> fav
@ -1271,8 +1269,6 @@ val instr_sub : subst -> instr -> instr
val hpred_sub : subst -> hpred -> hpred
val hpara_sub : subst -> hpara -> hpara
(** {2 Functions for replacing occurrences of expressions.} *)
(** 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 rec do_filter acc = function
| [] -> acc
| (Prop (_, p) as jp) :: jpl ->
| (Prop _ as jp) :: jpl ->
(match f jp with
| Some x ->
do_filter (x:: acc) jpl
| None -> do_filter acc jpl)
| (Joined (_, p, jp1, jp2) as jp) :: jpl ->
| (Joined (_, _, jp1, jp2) as jp) :: jpl ->
(match f jp with
| Some x ->
do_filter (x:: acc) jpl
@ -142,13 +142,13 @@ end
module Visitedset =
Set.Make (struct
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)
let visited_str vis =
let s = ref "" in
let lines = ref IntSet.empty in
let do_one (node, ns) =
let do_one (_, ns) =
(* if IList.length ns > 1 then
begin
let ss = ref "" in
@ -180,7 +180,7 @@ end = struct
let spec_fav (spec: Prop.normal spec) : Sil.fav =
let fav = Sil.fav_new () in
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
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 "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
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;
F.fprintf fmt "@\n%a" pp_summary_no_stats_specs summary;
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 ();
F.fprintf fmt "<LISTING>@\n";
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 *)
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 =
{ stats_time = 0.0;
@ -752,7 +754,7 @@ let get_specs proc_name =
let get_phase proc_name =
match get_summary_origin proc_name with
| 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 *)
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 *)
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
timestamps of the dependents *)
@ -778,7 +780,7 @@ let update_dependency_map proc_name =
| Some (summary, origin) ->
let current_dependency_map =
Procname.Map.mapi
(fun dep_proc old_stamp -> get_timestamp summary)
(fun _ _ -> get_timestamp summary)
summary.dependency_map in
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 () = {
const_map = (fun node exp -> None);
const_map = (fun _ _ -> None);
diverging_states_node = Paths.PathSet.empty;
diverging_states_proc = Paths.PathSet.empty;
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 *)
Set.Make(struct
type t = Cfg.Node.t * Sil.instr list
let compare (n1, instrs1) (n2, instrs2) =
let compare (n1, _) (n2, _) =
Cfg.Node.compare n1 n2
end) in
@ -221,7 +221,7 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
try
let s = M.find (get_key node) map 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
match IList.partition filter elements with
| [this], others -> this, others
@ -325,11 +325,11 @@ type log_issue =
unit
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; *)
match fs.node_ok, fs.first_failure with
| 0, Some (loc, key, session, loc_trace, pre_opt, exn) ->
let ex_name, desc, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in
| 0, Some (loc, key, _, loc_trace, pre_opt, exn) ->
let ex_name, _, ml_loc_opt, _, _, _, _ = Exceptions.recognize_exception exn in
let desc' = Localise.verbatim_desc ("exception: " ^ Localise.to_string ex_name) in
let exn' = Exceptions.Analysis_stops (desc', ml_loc_opt) in
log_issue

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

@ -15,7 +15,7 @@ module F = Format
let rec fldlist_assoc fld = function
| [] -> 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 =
match (typ, off) with
@ -127,7 +127,7 @@ let rec apply_offlist
let offlist' = (Sil.Off_index Sil.exp_zero):: offlist in
apply_offlist
pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst lookup_inst
| (Sil.Off_fld (fld, _)):: offlist', Sil.Earray _ ->
| (Sil.Off_fld _):: _, Sil.Earray _ ->
let offlist_new = Sil.Off_index(Sil.exp_zero) :: offlist in
apply_offlist
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
(res_e', strexp, typ, None)
end
| (Sil.Off_index idx):: offlist', _ ->
| (Sil.Off_index _):: _, _ ->
pp_error();
raise (Exceptions.Internal_error (Localise.verbatim_desc "Array out of bounds in Symexec"))
(* This case should not happen. The rearrangement should
@ -318,7 +318,7 @@ let rec execute_nullify_se = function
| Sil.Estruct (fsel, _) ->
let fsel' = IList.map (fun (fld, se) -> (fld, execute_nullify_se se)) fsel in
Sil.Estruct (fsel', Sil.inst_nullify)
| Sil.Earray (size, esel, inst) ->
| Sil.Earray (size, esel, _) ->
let esel' = IList.map (fun (idx, se) -> (idx, execute_nullify_se se)) esel in
Sil.Earray (size, esel', Sil.inst_nullify)
@ -510,7 +510,7 @@ let check_already_dereferenced pname cond prop =
| None ->
None in
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 exn =
(Exceptions.Null_test_after_dereference (desc, __POS__)) in
@ -581,7 +581,7 @@ let resolve_method tenv class_name proc_name =
Some right_proc_name
else
(match superclasses with
| super_classname:: interfaces ->
| super_classname:: _ ->
if not (Typename.Set.mem super_classname !visited)
then resolve super_classname
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
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
| Some class_name -> resolve_method tenv class_name pname
| 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 } ->
let name = Mangled.to_string cl_name in
name = "shared_ptr" || name = "__shared_ptr"
| t -> false
| _ -> false
with exn when exn_not_failure exn -> false in
(* We pattern match over some specific library function, *)
(* 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"
| ("operator->" | "operator*"),[(_, t1)] when ptr_to_shared_ptr t1 ->
Procname.from_string_c_fun "__infer_shared_ptr_arrow"
| "~shared_ptr",[(_, t1)] ->
| "~shared_ptr",[_] ->
Procname.from_string_c_fun "__infer_shared_ptr_destructor"
| _ -> pname in
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)] ->
let parts = Str.split (Str.regexp_string "://") s in
(match parts with
| frst:: parts ->
| frst:: _ ->
if (frst = "http") || (frst = "ftp") || (frst = "https") || (frst = "mailto") || (frst = "jar") then
[this; (Sil.Const (Sil.Cstr frst), atype)]
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 *)
(* returns nil. The exec_call function is either standard call execution or execution of ObjC *)
(* 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 =
let path_description = "Message "^(Procname.to_simplified_string callee_pname)^" with receiver nil returns nil." in
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 *)
[(add_objc_null_attribute_or_nullify_result pre, path)]
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 =
Option.is_some (Prop.get_undef_attribute pre receiver) in
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
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 prop_ren = Prop.prop_iter_to_prop iter_ren in
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
try
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
| Some value ->
[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
let iter_list =
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 ->
if (!Config.array_level = 0) then assert false
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_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 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
IList.rev (IList.fold_left (execute_set_ pdesc tenv n_rhs_exp) [] iter_list)
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
summary.Specs.stats.Specs.call_stats callee_pname loc
(Specs.CallStats.CR_skip) !Config.footprint);
call_unknown_or_scan
false cfg pdesc tenv prop path
ret_ids ret_typ_opt actual_args callee_pname loc in
call_unknown_or_scan false pdesc prop path ret_ids ret_typ_opt actual_args callee_pname loc in
let instr = match _instr with
| Sil.Call (ret, exp, par, loc, call_flags) ->
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 ();
let n_cond, prop = exp_norm_check_arith pname _prop cond in
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 ->
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
@ -1102,7 +1100,7 @@ let rec sym_exec cfg tenv pdesc _instr (_prop: Prop.normal Prop.t) path
let url_handled_args =
call_constructor_url_update_args callee_pname norm_args in
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 =
if !Config.ondemand_enabled then
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 fn, n_actual_params = handle_special_cases_call tenv cfg callee_pname _n_actual_params in
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
| [] -> fn in
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
| Some objc_property_accessor ->
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)
| None ->
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
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
call_unknown_or_scan
false cfg pdesc tenv prop_r path ret_ids None n_actual_params callee_pname loc
call_unknown_or_scan false pdesc prop_r path ret_ids None n_actual_params callee_pname loc
end
| Sil.Nullify (pvar, loc, deallocate) ->
| Sil.Nullify (pvar, _, deallocate) ->
begin
let eprop = Prop.expose _prop in
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]
| _ -> assert false
end
| Sil.Abstract loc ->
| Sil.Abstract _ ->
let node = State.get_node () in
let blocks_nullified = get_nullified_block node in
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
ret_old_path [Abs.remove_redundant_array_elements pname tenv
(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]
| Sil.Declare_locals (ptl, loc) ->
| Sil.Declare_locals (ptl, _) ->
let sigma_locals =
let add_None (x, y) = (x, Sil.Sizeof (y, Sil.Subtype.exact), None) 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']
| Sil.Stackop _ -> (* this should be handled at the propset level *)
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
begin
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 =
IList.filter
(function
| Sil.Hpointsto (lhs, _, typ_exp) when Sil.exp_equal lhs actual ->
| Sil.Hpointsto (lhs, _, _) when Sil.exp_equal lhs actual ->
false
| _ -> true)
(Prop.get_sigma prop) in
@ -1341,10 +1338,10 @@ and check_untainted exp caller_pname callee_pname prop =
else prop
(** 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 =
let remove_file_attribute prop =
let do_exp p (e, t) =
let do_exp p (e, _) =
let do_attribute q = function
| Sil.Aresource res_action as res
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)
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 "^
(Ident.fieldname_to_string field_name)^".");
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
| _ -> 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 "^
(Ident.fieldname_to_string field_name)^".");
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
| _ -> 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
prop path : Builtin.ret_typ =
and sym_exec_objc_accessor property_accesor ret_typ_opt tenv ret_ids pdesc _ loc args prop path
: Builtin.ret_typ =
let f_accessor =
match property_accesor with
| 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,
since this is the procname of the setter/getter method *)
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))
(** 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 =
match actual_pars, formal_types with
| [], [] -> actual_pars
| (e, t_e):: etl', t:: tl' ->
| (e, t_e):: etl', _:: tl' ->
(e, t_e) :: comb etl' tl'
| _,[] ->
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*)
if (!Config.curr_language <> Config.Java) && !Config.objc_method_call_semantics &&
(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
else (* non-objective-c method call. Standard tabulation *)
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
(** perform symbolic execution for a single prop, and check for junk *)
@ -1665,10 +1662,10 @@ module ModelBuiltins = struct
[(prop, path)]
(** 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 =
match args, ret_ids with
| [(lexp1, typ1); (lexp2, typ2); (lexp3, typ3)], _ ->
| [_; _; (lexp3, typ3)], _ ->
let instr' = Sil.Set (lexp3, typ3, Sil.exp_zero, loc) in
sym_exec_generated true cfg tenv pdesc [instr'] [(prop, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
@ -1693,7 +1690,7 @@ module ModelBuiltins = struct
| [ret_id] -> Prop.conjoin_eq e (Sil.Var ret_id) 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 =
match args with
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
@ -1706,7 +1703,7 @@ module ModelBuiltins = struct
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in
match hpred with
| Sil.Hpointsto(e, Sil.Earray(size, _, _), _) ->
| Sil.Hpointsto(_, Sil.Earray(size, _, _), _) ->
[(return_result_for_array_size size prop ret_ids, path)]
| _ -> []
with Not_found ->
@ -1726,7 +1723,7 @@ module ModelBuiltins = struct
end
| _ -> 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 =
match args, ret_ids with
| [(lexp, typ); (size, _)], [] ->
@ -1736,7 +1733,7 @@ module ModelBuiltins = struct
begin
try
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
match hpred with
| [Sil.Hpointsto(e, Sil.Earray(_, esel, inst), t)] ->
@ -1762,11 +1759,11 @@ module ModelBuiltins = struct
end
| _ -> 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 =
L.err "__print_value: ";
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
L.err "%a " (Sil.pp_exp pe_text) n_lexp in
IList.iter do_arg args;
@ -1796,7 +1793,7 @@ module ModelBuiltins = struct
let texp = Sil.Sizeof (typ'', Sil.Subtype.subtypes) in
let hpred = Prop.mk_ptsto n_lexp sexp texp in
Some hpred
| Sil.Tarray (typ', _) ->
| Sil.Tarray _ ->
let size = Sil.Var(Ident.create_fresh Ident.kfootprint) in
let sexp = mk_empty_array size in
let texp = Sil.Sizeof (typ, Sil.Subtype.subtypes) in
@ -1827,7 +1824,7 @@ module ModelBuiltins = struct
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 =
match args with
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
@ -1841,7 +1838,7 @@ module ModelBuiltins = struct
| Sil.Hpointsto(e, _, _) -> Sil.exp_equal e n_lexp
| _ -> false) (Prop.get_sigma prop) in
match hpred with
| Sil.Hpointsto(e, _, texp) ->
| Sil.Hpointsto(_, _, texp) ->
(return_result texp prop ret_ids), path
| _ -> assert false
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
Prop.normalize prop''
let execute___instanceof_cast
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc instof
let execute___instanceof_cast _ pdesc _ tenv _prop path ret_ids args _ _ instof
: Builtin.ret_typ =
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 val1, __prop = exp_norm_check_arith pname _prop _val1 in
let texp2, prop = exp_norm_check_arith pname __prop _texp2 in
let is_cast_to_reference =
match typ1 with
| Sil.Tptr (base_typ, Sil.Pk_reference) -> true
| Sil.Tptr (_, Sil.Pk_reference) -> true
| _ -> false in
(* 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. *)
let should_throw_exception =
!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
__POS__ None texp1 texp2 val1 in
let exe_one_prop prop =
@ -1921,7 +1917,7 @@ module ModelBuiltins = struct
begin
match pos_type_opt with
| 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
else (* !Config.footprint = false *)
begin
@ -1962,61 +1958,60 @@ module ModelBuiltins = struct
[(prop', path)]
(** 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 =
match args, ret_ids with
| [(lexp, typ)], _ ->
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
set_resource_attribute prop path n_lexp loc Sil.Rfile
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** 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 =
match args, ret_ids with
| [(lexp, typ)], _ ->
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
set_resource_attribute prop path n_lexp loc Sil.Rlock
| _ -> 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" *)
let execute___method_set_ignore_attribute
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
let execute___method_set_ignore_attribute _ pdesc _ _ _prop path ret_ids args _ loc
: Builtin.ret_typ =
match args, ret_ids with
| [_ ; (lexp, typ)], _ ->
| [_ ; (lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
set_resource_attribute prop path n_lexp loc Sil.Rignore
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** 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 =
match args, ret_ids with
| [(lexp, typ)], _ ->
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc 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)
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** 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 =
match args, ret_ids with
| [(lexp, typ)], _ ->
| [(lexp, _)], _ ->
let caller_pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith caller_pname prop lexp in
[(check_untainted n_lexp caller_pname callee_pname prop, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** 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 =
match args with
| [(lexp, typ)] ->
| [(lexp, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp 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 fsel' = (Ident.fieldname_hidden, se) :: fsel in
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 () =
match IList.find filter_fld_hidden fsel with
| _, Sil.Eexp(e, _) -> ret_val := Some e
@ -2049,10 +2045,10 @@ module ModelBuiltins = struct
| _ -> 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 *)
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 =
match args with
| [(lexp1, typ1); (lexp2, typ2)] ->
| [(lexp1, _); (lexp2, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc 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
@ -2080,7 +2076,7 @@ module ModelBuiltins = struct
(* Update the objective-c hidden counter by applying the operation op and the operand delta.*)
(* Eg. op=+/- delta is an integer *)
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 =
match args with
| [(lexp, typ)] ->
@ -2114,7 +2110,7 @@ module ModelBuiltins = struct
: Builtin.ret_typ =
let suppress_npe_report, args' = get_suppress_npe_flag args in
match args' with
| [(lexp, typ)] ->
| [(lexp, _)] ->
let prop = return_result lexp _prop ret_ids in
execute___objc_counter_update suppress_npe_report (Sil.PlusA) (Sil.Int.one)
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
(** Set the attibute of the value as objc autoreleased *)
let execute___set_autorelease_attribute
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
let execute___set_autorelease_attribute _ pdesc _ _ _prop path ret_ids args _ _
: Builtin.ret_typ =
match args, ret_ids with
| [(lexp, typ)], _ ->
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let prop = return_result lexp _prop ret_ids in
if !Config.objc_memory_model_on then
@ -2162,8 +2157,7 @@ module ModelBuiltins = struct
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Release all the objects in the pool *)
let execute___release_autorelease_pool
cfg pdesc instr tenv _prop path ret_ids args callee_pname loc
let execute___release_autorelease_pool cfg pdesc instr tenv _prop path ret_ids _ callee_pname loc
: Builtin.ret_typ =
if !Config.objc_memory_model_on then
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
| _ -> false) (Prop.get_sigma _prop) in
match hpred with
| Sil.Hpointsto(_, _, Sil.Sizeof (typ, st)) ->
| Sil.Hpointsto(_, _, Sil.Sizeof (typ, _)) ->
let res1 =
execute___objc_release cfg pdesc instr tenv prop path ret_ids
[(exp, typ)] callee_pname loc in
@ -2188,10 +2182,10 @@ module ModelBuiltins = struct
else execute___no_op _prop path
(** 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 =
match args with
| [(lexp, typ)] ->
| [(lexp, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = exp_norm_check_arith pname _prop lexp in
[(Prop.add_or_replace_exp_attribute prop n_lexp att, path)]
@ -2204,10 +2198,10 @@ module ModelBuiltins = struct
execute___set_attr (Sil.Ataint pname)
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 =
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 val1, __prop = exp_norm_check_arith pname _prop _val1 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
| _ -> false) (Prop.get_sigma prop) in
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
[(return_result val1 prop' ret_ids, path)]
| _ -> [(return_result val1 prop ret_ids, path)]
with Not_found -> [(return_result val1 prop ret_ids, path)])
| _ -> 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 =
raise
(Exceptions.Precondition_not_found
(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 =
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
| (Sil.Hpointsto(lexp, se, _), []) ->
| (Sil.Hpointsto(lexp, _, _), []) ->
let prop = Prop.prop_iter_remove_curr_then_to_prop iter 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
@ -2247,10 +2241,10 @@ module ModelBuiltins = struct
lexp
(Sil.Aresource ra) in
p_res :: acc
| (Sil.Hpointsto _, o :: os) -> assert false (* alignment error *)
| (Sil.Hpointsto _, _ :: _) -> assert false (* alignment error *)
| _ -> 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
begin
match Prover.is_root prop lexp lexp with
@ -2259,7 +2253,7 @@ module ModelBuiltins = struct
assert false
| Some _ ->
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
IList.rev prop_list
end
@ -2272,7 +2266,7 @@ module ModelBuiltins = struct
raise (Exceptions.Array_of_pointsto __POS__)
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 =
match args with
| [(lexp, typ)] ->
@ -2286,13 +2280,13 @@ module ModelBuiltins = struct
let plist =
prop_zero @ (* model: if 0 then skip else _execute_free_nonzero *)
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
IList.map (fun p -> (p, path)) plist
end
| _ -> 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 =
let pname = Cfg.Procdesc.get_proc_name pdesc in
let rec evaluate_char_sizeof e = match e with
@ -2338,10 +2332,10 @@ module ModelBuiltins = struct
[(prop_alloc, path); (prop_null, 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 =
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_arg = Prop.exp_normalize_prop prop (fst arg) in
(match routine_name, (snd start_routine) with
@ -2361,20 +2355,19 @@ module ModelBuiltins = struct
[(prop, path)])
| _ -> 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)]
let execute_scan_function
skip_n_arguments cfg pdesc instr tenv prop path ret_ids args callee_pname loc
let execute_scan_function skip_n_arguments _ pdesc _ _ prop path ret_ids args callee_pname loc
: Builtin.ret_typ =
match args with
| _ when IList.length args >= skip_n_arguments ->
let varargs = ref args in
for _ = 1 to skip_n_arguments do varargs := IList.tl !varargs done;
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__)
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 =
match args with
| [(ret_exn, _)] ->
@ -2389,7 +2382,7 @@ module ModelBuiltins = struct
end
| _ -> 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 =
match args with
| (_arg1, _):: _ ->
@ -2399,13 +2392,13 @@ module ModelBuiltins = struct
[(prop', path)]
| _ -> 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 =
match args with
| [(lexp1, _); (lexp2, _); (lexp3, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp1, prop = exp_norm_check_arith pname _prop lexp1 in
let n_lexp2, prop = exp_norm_check_arith pname _prop lexp2 in
let n_lexp1, _ = exp_norm_check_arith pname _prop lexp1 in
let n_lexp2, _ = exp_norm_check_arith pname _prop lexp2 in
let n_lexp3, prop = exp_norm_check_arith pname _prop lexp3 in
(match n_lexp1, n_lexp2, n_lexp3 with
| 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)])
| _ -> 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 =
let el = IList.map fst args in
let res = Sil.Const (Sil.Ctuple el) in
[(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 =
match args with
| [(lexp1, _); (lexp2, _)] ->
@ -2442,17 +2435,17 @@ module ModelBuiltins = struct
(* forces the expression passed as parameter to be assumed true at the point where this
builtin is called, blocks if this causes an inconsistency *)
let execute___infer_assume
cfg pdesc instr tenv prop path ret_ids args callee_pname loc: Builtin.ret_typ =
let execute___infer_assume _ _ _ _ prop path _ args _ _
: Builtin.ret_typ =
match args with
| [(lexp, typ)] ->
| [(lexp, _)] ->
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
else [(prop_assume, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(* 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 =
let error_str =
match args with
@ -2469,7 +2462,7 @@ module ModelBuiltins = struct
sym_exec_generated true cfg tenv pdesc [set_instr] [(prop, path)]
(* 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 =
let error_str =
match args with
@ -2575,12 +2568,13 @@ module ModelBuiltins = struct
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
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 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
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 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
@ -2603,7 +2597,7 @@ module ModelBuiltins = struct
Sil.expand_type tenv nsdictionary_typ in
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 res' =
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
let fav = Sil.fav_new () in
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' = 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
@ -211,7 +211,7 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_
false
end
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
| _ ->
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 *)
State.set_path new_path path_pos_opt;
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
| _ -> () in
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
| _ -> false in
let atom_update_alloc_attribute = function
| Sil.Aneq (e , Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra))))
| Sil.Aneq (Sil.Const (Sil.Cattribute (Sil.Aresource ({ Sil.ra_res = res } as ra))), e)
| Sil.Aneq (e , Sil.Const (Sil.Cattribute (Sil.Aresource ra)))
| 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 *)
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
@ -409,9 +409,9 @@ and sexp_star_fld se1 se2 : Sil.strexp =
match se1, se2 with
| Sil.Estruct (fsel1, _), Sil.Estruct (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.Eexp (e1, inst1), Sil.Earray (size2, esel2, _) ->
| Sil.Eexp (_, inst1), Sil.Earray (size2, esel2, _) ->
let esel1 = [(Sil.exp_zero, se1)] in
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
| [], _ -> true
| _, [] -> false
| (f1, t1, a1):: ftal1', (f2, t2, a2):: ftal2' ->
| (f1, _, _):: ftal1', (f2, _, _):: ftal2' ->
begin match Ident.fieldname_compare f1 f2 with
| n when n < 0 -> false
| 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; *)
let rec star sg1 sg2 : Sil.hpred list =
match sg1, sg2 with
| [], sigma2 -> []
| [], _ -> []
| sigma1,[] -> sigma1
| hpred1:: sigma1', hpred2:: sigma2' ->
begin
@ -470,13 +470,13 @@ let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpr
L.d_ln ();
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
| _ -> - 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
| Sil.Hpointsto(e1, se1, te1) -> Sil.Hpointsto (e1, se1, te2)
| Sil.Hpointsto(e1, se1, _) -> Sil.Hpointsto (e1, se1, te2)
| _ -> assert false
(** 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 *)
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
caller_pdesc callee_pname loc =
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in
@ -688,29 +688,30 @@ let combine
| None -> post_p2
| Some iter ->
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
match Prop.prop_iter_find iter filter with
| None -> post_p2
| Some iter' ->
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
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
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 ->
let rec do_ftl_ids p = function
| [], [] -> 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
do_ftl_ids p' (ftl', ret_ids')
| _ -> p in
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
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'
| _ -> assert false in
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
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 *)
let missing_pi_sub = Prop.pi_sub sub missing_pi 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 *)
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 =
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc 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 missing_pi' =
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
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 =
match combine
cfg ret_ids posts
ret_ids posts
actual_pre path_pre split
caller_pdesc callee_pname loc with
| 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)
(** 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
| Invalid_res _ -> false
| 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 =
IList.map (function Valid_res cr -> cr | Invalid_res _ -> assert false) valid_res0 in
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 =
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
let deref_errors = IList.filter (function Dereference_error _ -> true | _ -> false) invalid_res in
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
raise (Exceptions.Field_not_null_checked (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;
extend_path path_opt None;
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;
extend_path path_opt (Some 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
(** 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 trace_call res =
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 ("START EXECUTING SPECS FOR " ^ Procname.to_string callee_pname ^ " from state");
Prop.d_prop prop; L.d_ln ();
let exe_one_spec (n, spec) = exe_spec tenv cfg ret_ids (n, nspecs) caller_pdesc callee_pname loc prop path spec actual_params formal_params in
let 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
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 =

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 *)
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 ->
(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 *)
let colormap_from_color color (o: Obj.t) = color
let colormap_from_color color (_: Obj.t) = color
(** standard colormap: black *)
let colormap_black (o: Obj.t) = Black
let colormap_black (_: Obj.t) = Black
(** red colormap *)
let colormap_red (o: Obj.t) = Red
let colormap_red (_: Obj.t) = Red
(** Default text print environment *)
let pe_text =
@ -552,9 +552,9 @@ module FileNormalize = struct
let rec normalize done_l todo_l = match done_l, todo_l with
| _, y :: tl when y = Filename.current_dir_name -> (* path/. --> path *)
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
| 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
| _, y :: tl -> normalize (y :: done_l) tl
| _, [] -> 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.Tstruct struct_typ ->
(try
let (_, t, a) = IList.find (fun (f, t, a) ->
let (_, t, a) = IList.find (fun (f, _, _) ->
Sil.fld_equal f fn)
(struct_typ.Sil.instance_fields @ struct_typ.Sil.static_fields) in
Some (t, a)
@ -45,7 +45,7 @@ let get_field_type_and_annotation fn = function
| _ -> None
let ia_iter f =
let ann_iter (a, b) = f a in
let ann_iter (a, _) = f a in
IList.iter ann_iter
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
(Csu.Class Csu.Java, Mangled.from_string (Procname.java_get_class proc_name)) in
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 proc_belongs_to_lifecycle_typ = IList.exists
(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)
callback_procs
def_methods'
| typ -> callback_procs)
| _ -> callback_procs)
!registered_callback_procs
registered_callback_typs in
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. *)
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 tot_nodes = IList.length proc_nodes 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 join = State.join
let do_node = do_node
let proc_throws pn = DontKnow
let proc_throws _ = DontKnow
end) in
let do_check () =
@ -105,7 +105,7 @@ let callback_check_dead_code { Callbacks.proc_desc; proc_name } =
match transitions exit_node with
| DFDead.Transition (pre_final_s, _, _) ->
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 -> ()
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)
| None ->
match PatternMatch.get_java_method_call_formal_signature instr with
| Some (bt, fn, ats, rt) ->
| Some (bt, fn, _, rt) ->
ST.report_error
proc_name
proc_desc
@ -184,7 +184,7 @@ let callback_check_access { Callbacks.proc_desc } =
Cfg.Procdesc.iter_instrs (report_calls_and_accesses "PROC") proc_desc
(** 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
(Option.may (fun d -> Cfg.Procdesc.iter_instrs (report_calls_and_accesses "CLUSTER") d))
(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
| _ -> [] in
let check r_name r_desc w_name w_desc =
let check r_desc w_desc =
let is_serialization_node node =
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
else
check_match (rcs, wcs)
| rc:: rcs, [] ->
| 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
| _ -> () in
check_match (r_call_descs, w_call_descs) in
let do_instr node instr = match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (_this_exp, this_type):: args, loc, cf) ->
let do_instr _ instr = match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun _), (_this_exp, this_type):: _, _, _) ->
let this_exp = Idenv.expand_expr idenv _this_exp in
if is_write_to_parcel this_exp this_type then begin
if !verbose then L.stdout "Serialization check for %a@." Procname.pp proc_name;
try
match parcel_constructors this_type with
| x :: xs ->
| x :: _ ->
(match get_proc_desc x with
| Some x_proc_desc ->
check x x_proc_desc proc_name proc_desc
| Some x_proc_desc -> check x_proc_desc proc_desc
| None -> raise Not_found)
| _ -> L.stdout "No parcel constructor found for %a@." Procname.pp proc_name
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
end in
let do_instr node instr = match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (_arg1, t1):: arg_ts, loc, cf) when is_nullcheck pn ->
let do_instr _ instr = match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun pn), (_arg1, _):: _, _, _) when is_nullcheck pn ->
let arg1 = Idenv.expand_expr idenv _arg1 in
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
@ -386,30 +385,30 @@ let callback_find_deserialization { Callbacks.proc_desc; get_proc_desc; idenv; p
| None -> "?" in
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
let find_const exp typ =
let find_const exp =
let expanded = Idenv.expand_expr idenv exp in
match expanded with
| 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
| Sil.Set (_, _, Sil.Var (i1), _), Sil.Call (i2::[], _, _, _, _)
when Ident.equal i1 i2 -> true
| _ -> false in
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
match reverse_find_instr is_set_instr node with
(** Look for ivar := tmp *)
| Some s -> (
match reverse_find_instr (is_call_instr s) node with
(** 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
let arg_name (exp, typ) = find_const exp typ in
let arg_name (exp, _) = find_const exp in
Some (IList.map arg_name args)
with _ -> None)
| _ -> None in
@ -459,7 +458,7 @@ let callback_check_field_access { Callbacks.proc_desc } =
| Sil.Cast (_, e) ->
do_exp is_read e
| Sil.Lvar _ -> ()
| Sil.Lfield (e, fn, t) ->
| Sil.Lfield (e, fn, _) ->
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");
do_exp is_read e
@ -469,7 +468,7 @@ let callback_check_field_access { Callbacks.proc_desc } =
| Sil.Sizeof _ -> () in
let do_read_exp = do_exp true in
let do_write_exp = do_exp false in
let do_instr node = function
let do_instr _ = function
| Sil.Letderef (_, e, _, _) ->
do_read_exp e
| Sil.Set (e1, _, e2, _) ->
@ -492,7 +491,7 @@ let callback_check_field_access { Callbacks.proc_desc } =
(** Print c method calls. *)
let callback_print_c_method_calls { Callbacks.proc_desc; proc_name } =
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 ->
let receiver = match Errdesc.exp_rv_dexp node e with
| 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, _ -> false
| CodeQueryAst.ConstString s, (Vfun pn) -> string_contains s (Procname.to_string pn)
| CodeQueryAst.ConstString s, _ -> false
| CodeQueryAst.ConstString _, _ -> false
| CodeQueryAst.Ident id, x ->
env_add env id x
@ -158,7 +158,7 @@ module Match = struct
| Some s -> s in
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
| 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
@ -168,9 +168,10 @@ module Match = struct
end
else 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 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
begin
if show then print_action env action proc_name node loc;
@ -178,13 +179,14 @@ module Match = struct
end
else 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
begin
let found = ref false in
let iter (node', instr') =
let iter (_, instr') =
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
iter_succ_nodes node iter;
let line_contains_null () =
@ -206,7 +208,8 @@ end
let code_query_callback { Callbacks.proc_desc; idenv; proc_name } =
let do_instr node instr =
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
if verbose then L.stdout "code_query_callback on %a@." Procname.pp proc_name;
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
(* 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
| Some (Some c1), Some (Some c2) when Sil.const_equal c1 c2 -> Some (Some c1)
| Some c, None
@ -43,7 +43,7 @@ module ConstantFlow = Dataflow.MakeDF(struct
let join = ConstantMap.merge merge_values
let proc_throws pn = Dataflow.DontKnow
let proc_throws _ = Dataflow.DontKnow
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
Sil.pvar_equal pvar ret_pvar in
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 *)
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 ->
if Procname.equal callee_pn SymExec.ModelBuiltins.__cast
then DontKnow
else DoesNotThrow
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), args, loc, _) ->
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), _, _, _) ->
proc_throws callee_pn
| _ ->
DoesNotThrow in
@ -173,11 +173,11 @@ let callback_test_dataflow { Callbacks.proc_desc } =
let do_node n s =
if verbose then L.stdout "visiting node %a with state %d@." Cfg.Node.pp n s;
[s + 1], [s + 1]
let proc_throws pn = DoesNotThrow
let proc_throws _ = DoesNotThrow
end) in
let transitions = DFCount.run proc_desc 0 in
let do_node node =
match transitions node with
| DFCount.Transition (pre_state, _, _) -> ()
| DFCount.Transition _ -> ()
| DFCount.Dead_state -> () in
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
let _create cfg proc_desc =
let _create proc_desc =
let map = Ident.IdentHash.create 1 in
let do_instr node = function
| Sil.Letderef (id, e, t, loc) ->
let do_instr _ = function
| Sil.Letderef (id, e, _, _) ->
Ident.IdentHash.add map id e
| _ -> () in
Cfg.Procdesc.iter_instrs do_instr proc_desc;
@ -24,12 +24,12 @@ let _create cfg proc_desc =
(* lazy implementation, only create when used *)
let create cfg proc_desc =
let map = lazy (_create cfg proc_desc) in
let map = lazy (_create proc_desc) in
map, cfg
(* create an idenv for another procedure *)
let create_from_idenv (_, cfg) proc_desc =
let map = lazy (_create cfg proc_desc) in
let map = lazy (_create proc_desc) in
map, cfg
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 *)
let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals with
| (n, t):: args -> Some t
| (_, t):: _ -> Some t
| _ -> None
let type_get_direct_supertypes = function
@ -137,7 +137,7 @@ let get_vararg_type_names
(Sil.pvar_equal ivar iv && Ident.equal t1 t2 &&
Procname.equal pn (Procname.from_string_c_fun "__new_array"))
|| initializes_array is
| i:: is -> initializes_array is
| _:: is -> initializes_array is
| _ -> false in
(* Get the type name added to ivar or None *)
@ -146,10 +146,10 @@ let get_vararg_type_names
match instrs with
| Sil.Letderef (nv, Sil.Lfield (_, id, t), _, _):: _
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 ->
Some (get_type_name t)
| i:: is -> nvar_type_name nvar is
| _:: is -> nvar_type_name nvar is
| _ -> None in
let rec added_nvar array_nvar instrs =
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)
| Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Const 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
let rec array_nvar instrs =
match instrs with
| Sil.Letderef (nv, Sil.Lvar iv, _, _):: _
when Sil.pvar_equal iv ivar ->
added_nvar nv instrs
| i:: is -> array_nvar is
| _:: is -> array_nvar is
| _ -> None in
array_nvar (Cfg.Node.get_instrs node) in
@ -181,7 +181,7 @@ let get_vararg_type_names
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 equal_formal_arg (_, typ) arg_type_name = get_type_name typ = arg_type_name in
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 =
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 =
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) *)
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)
| _ -> None
(** Returns the formal signature (class name, method name,
argument type names and return type name) *)
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
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 m_name = Procname.java_get_method pn in
Some (get_type_name tt, m_name, arg_names, rt_name)
@ -262,7 +262,7 @@ let method_is_initializer
| None -> false
(** 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 do_instr = function
| 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
let () = match Errdesc.find_program_variable_assignment node pvar with
| Some (node', _) ->
Cfg.Procdesc.iter_slope_range do_node pdesc node' node
Cfg.Procdesc.iter_slope_range do_node node' node
| None -> () in
!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 do_instruction node instr = match instr with
let do_instruction _ instr = match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), _, _, _) ->
begin
match resolve_attributes callee_pn with
@ -329,7 +329,7 @@ let proc_iter_overridden_methods f tenv proc_name =
let get_fields_nullified procdesc =
(* walk through the instructions and look for instance fields that are assigned to null *)
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 ->
(Ident.FieldSet.add fld nullified_flds, this_ids)
| 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
(** 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
(** Return the callees that satisfy [filter]. *)
val proc_calls :
(Procname.t -> ProcAttributes.t option) ->
Procname.t -> Cfg.Procdesc.t ->
Cfg.Procdesc.t ->
(Procname.t -> ProcAttributes.t -> bool) ->
(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
| Sil.Letderef (id, Sil.Lvar iv, _, _):: _, Sil.Var nid
when Ident.equal id nid -> iv
| i:: is, _ -> array_ivar is nvar
| _:: is, _ -> array_ivar is nvar
| _ -> raise Not_found in
let rec fixed_nvar_type_name instrs nvar =
match nvar with
| Sil.Var nid -> (
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
| i:: is -> fixed_nvar_type_name is nvar
| _:: is -> fixed_nvar_type_name is nvar
| _ -> raise Not_found)
| Sil.Const c -> PatternMatch.java_get_const_type_name c
| _ -> 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
type t = Sil.instr
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 *)
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
@ -87,7 +87,7 @@ struct
| Some loc, None
| None, Some loc ->
if _paths = AllPaths then None else Some loc
| Some loc1, Some loc2 ->
| Some loc1, Some _ ->
Some loc1 (* left priority *)
let join = _join paths
let do_node node lo1 =
@ -95,7 +95,7 @@ struct
let lo' = (* use left priority join to implement transfer function *)
_join SomePath lo1 lo2 in
[lo'], [lo']
let proc_throws pn = Dataflow.DontKnow
let proc_throws _ = Dataflow.DontKnow
end) in
let transitions = DFAllocCheck.run pdesc None in
@ -104,11 +104,11 @@ struct
| DFAllocCheck.Dead_state -> None
(** 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. *)
let arguments_not_temp args =
let filter_arg (e, t) = match e with
let filter_arg (e, _) = match e with
| Sil.Lvar pvar ->
(* same temporary variable does not imply same value *)
not (Errdesc.pvar_is_frontend_tmp pvar)
@ -158,7 +158,7 @@ struct
pp = pp;
}
let update_payload typestate payload = payload
let update_payload _ payload = payload
end (* CheckRepeatedCalls *)
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_integer_literal stmt_info n =
let create_integer_literal n =
let stmt_info = dummy_stmt_info () in
let expr_info = {
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)
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 paren_expr = create_parent_expr stmt_info [cstyle_cast_expr] in
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;
}
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 = {
Clang_ast_t.fldi_is_mutable = 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 var_decl_ref, var_type =
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_ref = make_decl_ref_tp `Var decl_ptr name_info false var_type in
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: *)
(* 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 =
try IList.nth stmt_list (n + 1)
with Not_found -> assert false in
@ -300,7 +300,7 @@ let translate_dispatch_function block_name stmt_info stmt_list ei n =
} in
let open Clang_ast_t in
match block_expr with
| BlockExpr (bsi, bsl, bei, bd) ->
| BlockExpr (_, _, bei, _) ->
let tp = bei.ei_type_ptr in
let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} 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' *)
let build_PseudoObjectExpr tp_m o_cast_decl_ref_exp mname =
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 ei_opre = make_expr_info (pseudo_object_tp ()) 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 =
match pidx with
| 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; *)
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
@ -475,7 +475,7 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
(* idx<a.count *)
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 lt = { Clang_ast_t.boi_kind = `LT } 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
(* 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
match pobj with
| 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 =
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
cast_expr decl_ref tp
| _ -> 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 guard = bin_op pidx objects 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 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
@ -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*)
(* !x <=> x?0:1 *)
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)
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
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 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 = make_binary_stmt decl_ref_exp_cast null_expr stmt_info bin_op_expr_info boi 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 make_objc_ivar_decl : decl_info -> type_ptr -> obj_c_property_impl_decl_info ->
named_decl_info -> decl
val make_objc_ivar_decl : decl_info -> type_ptr -> named_decl_info -> decl
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 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 ->
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*)
(* case we need to add proper retain/release.*)
(* 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 retain_pname = SymExec.ModelBuiltins.__objc_retain 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
Sil.Call([], bi_retain, [(e, t)], loc, Sil.cf_default) in
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*)
(* retain(e2); tmp=e1; e1=e2; release(tmp); *)
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 release = mk_call release_pname (Sil.Var id) typ in
(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*)
(* retain(e2); e1=e2; *)
let retain = mk_call retain_pname e2 typ in
(e1,[retain; assign ], [])
| Sil.Tptr (t, Sil.Pk_objc_weak)
| Sil.Tptr (t, Sil.Pk_objc_unsafe_unretained) ->
| Sil.Tptr (_, Sil.Pk_objc_weak)
| Sil.Tptr (_, Sil.Pk_objc_unsafe_unretained) ->
(e1, [assign],[])
| Sil.Tptr (t, Sil.Pk_objc_autoreleasing) ->
| Sil.Tptr (_, Sil.Pk_objc_autoreleasing) ->
(* for __autoreleasing e1 = e2 the semantics is*)
(* retain(e2); autorelease(e2); e1=e2; *)
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 ->
let e1_xor_e2 = Sil.BinOp(Sil.BXor, Sil.Var id, e2) in
(e1, [Sil.Set (e1, typ, e1_xor_e2, loc)])
| bok -> assert false in
| _ -> assert false in
(e_res, instr1:: instr_op, [id])
(* 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), [], [])
| `Assign ->
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
(e1, [Sil.Set (e1, typ, e2, loc)], [])
| `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
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
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 =
match curr_class with
| ContextCls (name, _, _) -> name
| ContextCategory (name, cls) -> cls
| ContextCategory (_, cls) -> cls
| ContextProtocol name -> name
| 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 =
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 =
try
let static_vars = Procname.Map.find block_name outer_context.blocks_static_vars in
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_vars, true
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)
| _ -> () in
match decl with
| EnumDecl (decl_info, _, _, type_ptr, decl_list, _, _) ->
| EnumDecl (_, _, _, type_ptr, decl_list, _, _) ->
add_enum_constants_to_map (IList.rev decl_list);
let sil_type = Sil.Tint Sil.IInt in
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
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
match Ast_utils.get_decl_opt_with_decl_ref ivar_decl_ref with
| 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')
| ObjCIvarDecl (_, 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'
(* 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 open Clang_ast_t in
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
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
| _ -> (* 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

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
(if should_translate_decl then
match dec with
| FunctionDecl(di, name_info, tp, fdecl_info) ->
| FunctionDecl(_, _, _, _) ->
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 curr_class = ObjcInterface_decl.get_curr_class name oi_decl_info in
ignore
(ObjcInterface_decl.interface_declaration CTypes_decl.type_ptr_to_sil_type tenv dec);
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 curr_class = CContext.ContextProtocol name in
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
| 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 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);
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 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);
@ -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
| _ -> ())
| 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 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);
@ -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
| _ -> ())
| CXXMethodDecl (decl_info, name_info, type_ptr, function_decl_info, _)
| CXXConstructorDecl (decl_info, name_info, type_ptr, function_decl_info, _)
| CXXConversionDecl (decl_info, name_info, type_ptr, function_decl_info, _)
| CXXDestructorDecl (decl_info, name_info, type_ptr, function_decl_info, _) ->
| CXXMethodDecl (decl_info, _, _, _, _)
| CXXConstructorDecl (decl_info, _, _, _, _)
| CXXConversionDecl (decl_info, _, _, _, _)
| CXXDestructorDecl (decl_info, _, _, _, _) ->
(* 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 *)
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]
| Some dec -> Printing.log_stats "Methods of %s skipped\n" (Ast_utils.string_of_decl dec)
| None -> ())
| dec -> ());
| _ -> ());
match dec with
(* Currently C/C++ record decl treated in the same way *)
| 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);
IList.iter (translate_one_declaration tenv cg cfg dec) method_decls
| 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";
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
| ClassTemplateDecl (decl_info, named_decl_info, template_decl_info)
| FunctionTemplateDecl (decl_info, named_decl_info, template_decl_info) ->
| ClassTemplateDecl (_, _, template_decl_info)
| FunctionTemplateDecl (_, _, template_decl_info) ->
let decl_list = template_decl_info.Clang_ast_t.tdi_specializations in
IList.iter (translate_one_declaration tenv cg cfg dec) decl_list
| dec -> ()
| _ -> ()
(* 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
| Clang_ast_t.TranslationUnitDecl(_, 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);
Printing.log_out "\n Start building call/cfg graph for '%s'....\n"
(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"
(DB.source_file_to_string source_file);
(* 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)
(* given that this has not been translated, looking up for variables *)
(* inside leads to inconsistencies *)
| ObjCAtCatchStmt (stmt_info, stmt_list, obj_c_message_expr_kind) ->
| ObjCAtCatchStmt _ ->
[]
| _ -> snd (Clang_ast_proj.get_stmt_tuple stmt)
@ -158,7 +158,7 @@ struct
let get_unqualified_name name_info =
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
fold_qual_name [name]
@ -291,7 +291,7 @@ struct
let update_enum_map enum_constant_pointer sil_exp =
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
with Not_found -> assert false 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
(* it needs extending to handle objC types *)
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
(*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)
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 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"
;
"-fobjc-arc",
Arg.Unit (fun s -> Config.arc_mode := true),
Arg.Unit (fun _ -> Config.arc_mode := true),
None,
"Translate with Objective-C Automatic Reference Counting (ARC)"
;
@ -92,7 +92,7 @@ let print_usage_exit () =
exit(1)
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*)
(* 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. *)
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
"\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
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
captured_vars outer_context_opt extra_instrs
outer_context_opt extra_instrs
| None -> ()
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 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
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 -> ()

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 par_to_ms_par par =
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
(name, type_ptr)
| _ -> 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))
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 =
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
@ -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 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 ->
let assume_call = Ast_expressions.create_assume_not_null_call decl_info name tp in
[(`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 function_info = Some (decl_info, fdi) 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
ms, fdi.Clang_ast_t.fdi_body, extra_instrs
| 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 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 ms = build_method_signature tenv decl_info procname method_decl false parent_pointer
None in
let ms = build_method_signature tenv decl_info procname method_decl parent_pointer None 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 *)
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
| Some decl_ref -> Some decl_ref.Clang_ast_t.dr_decl_pointer
| 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
let extra_instrs = get_assume_not_null_calls mdi.omdi_parameters in
ms, mdi.omdi_body, extra_instrs
| BlockDecl (decl_info, bdi), Some (outer_context, tp, procname, _) ->
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
ms, bdi.bdi_body, extra_instrs
| _ -> 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)
| `Instance ->
(match act_params with
| (instance_obj, Sil.Tptr(t, _)):: _
| (instance_obj, t):: _ -> CTypes.classname_of_type t
| (_, Sil.Tptr(t, _)):: _
| (_, t):: _ -> CTypes.classname_of_type t
| _ -> assert false)
| `SuperInstance ->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 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
| 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 field_name = CField_decl.get_property_corresponding_ivar tenv
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 = CFrontend_utils.General_utils.sort_fields fields in
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;
let mblock = Mangled.from_string block_name in
let block_type = Sil.Tstruct
@ -130,7 +130,7 @@ struct
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 id_block = match trans_res.exps with
| [(Sil.Var id, t)] -> id
| [(Sil.Var id, _)] -> id
| _ -> assert false in
let block_var = Sil.mk_pvar mblock procname in
let declare_block_local =
@ -241,7 +241,7 @@ struct
f trans_state 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 id = Ident.create_fresh Ident.knormal 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 type_ptr = expr_info.Clang_ast_t.ei_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
call_flags ~is_objc_method =
@ -263,9 +263,8 @@ struct
let var_exp = match trans_state.var_exp_typ with
| Some (exp, _) -> exp
| _ ->
let tenv = trans_state.context.CContext.tenv 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)];
Sil.Lvar pvar in
(* 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 }
| _ -> 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 exp = Sil.Const (Sil.Cstr (str)) in
{ 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 *)
(* 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 *)
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 exp = Sil.Const (Sil.Cint (Sil.Int.zero)) in
{ 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
{ empty_res_trans with exps = [(Sil.exp_null, typ)]}
let objCSelectorExpr_trans trans_state stmt_info expr_info selector =
stringLiteral_trans trans_state stmt_info expr_info selector
let objCSelectorExpr_trans trans_state expr_info selector =
stringLiteral_trans trans_state expr_info selector
let objCEncodeExpr_trans trans_state stmt_info expr_info type_ptr =
stringLiteral_trans trans_state stmt_info expr_info (Ast_utils.string_of_type_ptr type_ptr)
let objCEncodeExpr_trans trans_state expr_info 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
| Some s -> s.Clang_ast_t.ni_name
| _ -> "") 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 exp = Sil.Const (Sil.Cint (Sil.Int.of_int n)) in
{ 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 exp = Sil.Const (Sil.Cfloat (float_of_string float_string)) in
{ empty_res_trans with exps = [(exp, typ)]}
(* Note currently we don't have support for different qual *)
(* 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 exp, ids =
try
@ -362,7 +361,7 @@ struct
exps = [(exp, typ)];
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
(* constant will be different depending on type *)
let zero_opt = match typ with
@ -374,11 +373,11 @@ struct
| Some zero -> { empty_res_trans with exps = [(Sil.Const zero, typ)] }
| _ -> empty_res_trans
let nullStmt_trans succ_nodes stmt_info =
let nullStmt_trans succ_nodes =
{ empty_res_trans with root_nodes = succ_nodes }
(* 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 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
@ -578,7 +577,7 @@ struct
decl_ref.Clang_ast_t.dr_decl_pointer in
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@."
(string_of_bool (PriorityNode.is_priority_free trans_state));
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
{ 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 array_stmt, idx_stmt = (match stmt_list with
| [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...*)
let res_trans_a = instruction trans_state array_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
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
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 typ = CTypes_decl.type_ptr_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_type_ptr in
(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 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
@ -692,7 +691,9 @@ struct
(* 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
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 =
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 *)
let trans_state_param =
{ 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
let callee_pname_opt =
match sil_fe with
@ -821,7 +822,7 @@ struct
let sil_loc = CLocation.get_sil_location si context in
(* first for method address, second for 'this' expression *)
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
| Sil.Const (Sil.Cfun pn) -> pn
| _ -> 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
| Some exp_typ -> exp_typ
| None ->
let tenv = trans_state.context.CContext.tenv 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
Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, class_type)];
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
else empty_res_trans
and objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info stmt_list
expr_info method_type trans_state_pri sil_loc act_params =
and objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info
method_type trans_state_pri sil_loc act_params =
let context = trans_state.context 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
@ -961,8 +961,8 @@ struct
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
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
expr_info method_type trans_state_pri sil_loc subexpr_exprs with
match objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info
method_type trans_state_pri sil_loc subexpr_exprs with
| Some res -> res
| None ->
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 }
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";
let procname = Cfg.Procdesc.get_proc_name trans_state.context.CContext.procdesc in
let pvar = CFrontend_utils.General_utils.get_next_block_pvar procname in
let transformed_stmt, tp =
Ast_expressions.translate_dispatch_function (Sil.pvar_to_string pvar) stmt_info stmt_list ei n in
let transformed_stmt, _ =
Ast_expressions.translate_dispatch_function (Sil.pvar_to_string pvar) stmt_info stmt_list n in
instruction trans_state transformed_stmt
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)*)
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 transformed_stmt, vars_to_register =
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 pvar = Sil.mk_pvar (Mangled.from_string v) procname in
let typ = CTypes_decl.type_ptr_to_sil_type trans_state.context.CContext.tenv tp in
(pvar, typ)) vars_to_register in
let pvars = IList.map (fun (v, _, _) ->
Sil.mk_pvar (Mangled.from_string v) procname
) vars_to_register in
let loc = CLocation.get_sil_location stmt_info trans_state.context 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
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
and compoundStmt_trans trans_state stmt_info stmt_list =
and compoundStmt_trans trans_state stmt_list =
instructions trans_state stmt_list
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' = { trans_state_pri with succ_nodes = [] } 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
let set_temp_var = [
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 *)
else
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_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;
@ -1137,7 +1137,7 @@ struct
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
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
{ root_nodes = root_nodes_to_parent;
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";
let open Clang_ast_t in
match cond with
| BinaryOperator(si, [s1; s2], expr_info, boi) ->
| BinaryOperator(_, [s1; s2], _, boi) ->
(match boi.Clang_ast_t.boi_kind with
| `LAnd -> short_circuit (Sil.LAnd) 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 =
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
succ_nodes = res_trans_cond.root_nodes
} in
@ -1291,7 +1291,7 @@ struct
let e_const = res_trans_case_const.exps in
let e_const' =
match e_const with
| [(head, typ)] -> head
| [(head, _)] -> head
| _ -> assert false 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
@ -1307,7 +1307,7 @@ struct
| _ -> assert false in
match cases with (* top-down to handle default cases *)
| [] -> 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 case_entry_point = connected_instruction (IList.rev case_content) last_nodes in
(* 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 }
| _ -> 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 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
@ -1364,7 +1364,7 @@ struct
let continuation_cond = mk_cond_continuation outer_continuation in
let init_incr_nodes =
match loop_kind with
| Loops.For (init, decl_stmt, cond, incr, body) ->
| Loops.For (init, _, _, incr, _) ->
let trans_state' = {
trans_state with
succ_nodes = [join_node];
@ -1391,12 +1391,12 @@ struct
let body_succ_nodes =
match loop_kind with
| Loops.For _ -> (match init_incr_nodes with
| Some (nodes_init, nodes_incr) -> nodes_incr
| Some (_, nodes_incr) -> nodes_incr
| None -> assert false)
| Loops.While _ -> [join_node]
| Loops.DoWhile _ -> res_trans_cond.root_nodes in
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 }
| _ -> continuation in
let res_trans_body =
@ -1421,7 +1421,7 @@ struct
let root_nodes =
match loop_kind with
| 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
{ 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)
| _ -> [[(e, typ)]] (*This case is an error, shouldn't happen.*))
| 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) )
instance_fields in
let lh_types = IList.map ( fun (fieldname, fieldtype, _) -> fieldtype)
let lh_types = IList.map ( fun (_, fieldtype, _) -> fieldtype)
instance_fields in
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)) ->
@ -1544,7 +1544,8 @@ struct
(* 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 *)
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)
else
([], [Sil.Set (lh_exp, lh_t, rh_exp, sil_loc)], []))
@ -1616,7 +1617,7 @@ struct
(* we need to add retain/release *)
let (e, instrs, ids) =
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)
else
([], [Sil.Set (var_exp, ie_typ, sil_e1', sil_loc)], []) in
@ -1676,13 +1677,13 @@ struct
empty_res_trans in
{ 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
| [stmt] -> instruction trans_state stmt
| _ -> assert false
(* 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@."
(string_of_bool (PriorityNode.is_priority_free trans_state));
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]*)
(* 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.*)
and pseudoObjectExpr_trans trans_state stmt_info stmt_list =
and pseudoObjectExpr_trans trans_state stmt_list =
Printing.log_out " priority node free = '%s'\n@."
(string_of_bool (PriorityNode.is_priority_free trans_state));
let rec do_semantic_elements el =
@ -1713,7 +1714,7 @@ struct
| stmt :: _ -> instruction trans_state stmt
| _ -> assert false in
match stmt_list with
| syntactic_form :: semantic_form ->
| _ :: semantic_form ->
do_semantic_elements semantic_form
| _ -> assert false
@ -1737,7 +1738,7 @@ struct
}
(* 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
"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 *)
@ -1747,14 +1748,14 @@ struct
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
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
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
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 =
let context = trans_state.context in
@ -1804,7 +1805,7 @@ struct
succ_nodes = [];
var_exp_typ = Some (ret_exp, ret_typ) } 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
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. *)
(* For ParenExpression we translate its body composed by the stmt_list. *)
(* 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
"WARNING: In ParenExpression there should be only one stmt.\n" in
instruction trans_state stmt
@ -1888,7 +1889,7 @@ struct
(* 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 *)
(* 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
| [_; compound_stmt] -> instruction trans_state compound_stmt
| _ -> assert false)
@ -1897,7 +1898,7 @@ struct
let context = trans_state.context in
let procname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
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
(* Given a captured var, return the instruction to assign it to a temp *)
let assign_captured_var (cvar, typ) =
@ -1905,7 +1906,7 @@ struct
let instr = Sil.Letderef (id, (Sil.Lvar cvar), typ, loc) in
(id, instr) in
match decl with
| Clang_ast_t.BlockDecl (decl_info, block_decl_info) ->
| Clang_ast_t.BlockDecl (_, block_decl_info) ->
let open CContext 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
@ -1941,7 +1942,7 @@ struct
(* 1. Handle __new_array *)
(* 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 sil_loc = CLocation.get_sil_location stmt_info context 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
{ 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 procdesc = context.CContext.procdesc in
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_trans trans_state stmt_info stmt_list label_name
| ArraySubscriptExpr(stmt_info, stmt_list, expr_info) ->
arraySubscriptExpr_trans trans_state stmt_info expr_info stmt_list
| ArraySubscriptExpr(_, stmt_list, expr_info) ->
arraySubscriptExpr_trans trans_state expr_info stmt_list
| BinaryOperator(stmt_info, stmt_list, expr_info, binary_operator_info) ->
binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list
@ -2045,7 +2046,7 @@ struct
| CallExpr(stmt_info, stmt_list, ei) ->
(match is_dispatch_function stmt_list with
| 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 ->
callExpr_trans trans_state stmt_info stmt_list ei)
@ -2065,9 +2066,9 @@ struct
else
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*)
compoundStmt_trans trans_state stmt_info stmt_list
compoundStmt_trans trans_state stmt_list
| ConditionalOperator(stmt_info, stmt_list, expr_info) ->
(* Ternary operator "cond ? exp1 : exp2" *)
@ -2079,11 +2080,11 @@ struct
| SwitchStmt (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
| StmtExpr(stmt_info, stmt_list, expr_info) ->
stmtExpr_trans trans_state stmt_info stmt_list expr_info
| StmtExpr(stmt_info, stmt_list, _) ->
stmtExpr_trans trans_state stmt_info stmt_list
| ForStmt(stmt_info, [init; decl_stmt; cond; incr; body]) ->
forStmt_trans trans_state init decl_stmt cond incr body stmt_info
@ -2100,31 +2101,31 @@ struct
| ObjCForCollectionStmt(stmt_info, [item; items; body]) ->
objCForCollectionStmt_trans trans_state item items body stmt_info
| NullStmt(stmt_info, stmt_list) ->
nullStmt_trans trans_state.succ_nodes stmt_info
| NullStmt _ ->
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
| DeclStmt(stmt_info, stmt_list, decl_list) ->
| DeclStmt(stmt_info, _, decl_list) ->
declStmt_trans trans_state decl_list stmt_info
| DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) as d ->
declRefExpr_trans trans_state stmt_info expr_info decl_ref_expr_info d
| DeclRefExpr(stmt_info, _, _, decl_ref_expr_info) as d ->
declRefExpr_trans trans_state stmt_info decl_ref_expr_info d
| ObjCPropertyRefExpr(stmt_info, stmt_list, expr_info, property_ref_expr_info) ->
objCPropertyRefExpr_trans trans_state stmt_info stmt_list
| ObjCPropertyRefExpr(_, stmt_list, _, _) ->
objCPropertyRefExpr_trans trans_state stmt_list
| 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_trans trans_state stmt_info opaque_value_expr_info
| OpaqueValueExpr(_, _, _, opaque_value_expr_info) ->
opaqueValueExpr_trans trans_state opaque_value_expr_info
| PseudoObjectExpr(stmt_info, stmt_list, expr_info) ->
pseudoObjectExpr_trans trans_state stmt_info stmt_list
| PseudoObjectExpr(_, stmt_list, _) ->
pseudoObjectExpr_trans trans_state stmt_list
| UnaryExprOrTypeTraitExpr(stmt_info, stmt_list, expr_info, ei) ->
unaryExprOrTypeTraitExpr_trans trans_state stmt_info expr_info ei
| UnaryExprOrTypeTraitExpr(_, _, expr_info, ei) ->
unaryExprOrTypeTraitExpr_trans trans_state expr_info ei
| ObjCBridgedCastExpr(stmt_info, stmt_list, expr_info, cast_kind, _) ->
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, _)->
cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_kind false
| IntegerLiteral(stmt_info, _, expr_info, integer_literal_info) ->
integerLiteral_trans trans_state stmt_info expr_info integer_literal_info
| IntegerLiteral(_, _, expr_info, integer_literal_info) ->
integerLiteral_trans trans_state expr_info integer_literal_info
| StringLiteral(stmt_info, stmt_list, expr_info, str) ->
stringLiteral_trans trans_state stmt_info expr_info str
| StringLiteral(_, _, expr_info, str) ->
stringLiteral_trans trans_state expr_info str
| GNUNullExpr(stmt_info, stmt_list, expr_info) ->
gNUNullExpr_trans trans_state stmt_info expr_info
| GNUNullExpr(_, _, expr_info) ->
gNUNullExpr_trans trans_state expr_info
| CXXNullPtrLiteralExpr(stmt_info, stmt_list, expr_info) ->
nullPtrExpr_trans trans_state stmt_info expr_info
| CXXNullPtrLiteralExpr(_, _, expr_info) ->
nullPtrExpr_trans trans_state expr_info
| ObjCSelectorExpr(stmt_info, stmt_list, expr_info, selector) ->
objCSelectorExpr_trans trans_state stmt_info expr_info selector
| ObjCSelectorExpr(_, _, expr_info, selector) ->
objCSelectorExpr_trans trans_state expr_info selector
| ObjCEncodeExpr(stmt_info, stmt_list, expr_info, type_ptr) ->
objCEncodeExpr_trans trans_state stmt_info expr_info type_ptr
| ObjCEncodeExpr(_, _, expr_info, type_ptr) ->
objCEncodeExpr_trans trans_state expr_info type_ptr
| ObjCProtocolExpr(stmt_info, stmt_list, expr_info, decl_ref) ->
objCProtocolExpr_trans trans_state stmt_info expr_info decl_ref
| ObjCProtocolExpr(_, _, 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_trans trans_state stmt_info expr_info stmt_list obj_c_ivar_ref_expr_info
| ObjCIvarRefExpr(stmt_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_trans trans_state stmt_info expr_info stmt_list member_expr_info
| MemberExpr(stmt_info, stmt_list, _, member_expr_info) ->
memberExpr_trans trans_state stmt_info stmt_list member_expr_info
| UnaryOperator(stmt_info, stmt_list, expr_info, unary_operator_info) ->
if is_logical_negation_of_int trans_state.context.CContext.tenv expr_info unary_operator_info then
@ -2175,20 +2176,20 @@ struct
(* 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. *)
| ExprWithCleanups(stmt_info, stmt_list, expr_info, _)
| ParenExpr(stmt_info, stmt_list, expr_info) ->
parenExpr_trans trans_state stmt_info stmt_list
| ExprWithCleanups(_, stmt_list, _, _)
| ParenExpr(_, stmt_list, _) ->
parenExpr_trans trans_state stmt_list
| ObjCBoolLiteralExpr (stmt_info, stmts, expr_info, n)
| CharacterLiteral (stmt_info, stmts, expr_info, n)
| CXXBoolLiteralExpr (stmt_info, stmts, expr_info, n) ->
characterLiteral_trans trans_state stmt_info expr_info n
| ObjCBoolLiteralExpr (_, _, expr_info, n)
| CharacterLiteral (_, _, expr_info, n)
| CXXBoolLiteralExpr (_, _, expr_info, n) ->
characterLiteral_trans trans_state expr_info n
| FloatingLiteral (stmt_info, stmts, expr_info, float_string) ->
floatingLiteral_trans trans_state stmt_info expr_info float_string
| FloatingLiteral (_, _, expr_info, float_string) ->
floatingLiteral_trans trans_state expr_info float_string
| CXXScalarValueInitExpr (stmt_info, stmts, expr_info) ->
cxxScalarValueInitExpr_trans trans_state stmt_info expr_info
| CXXScalarValueInitExpr (_, _, expr_info) ->
cxxScalarValueInitExpr_trans trans_state expr_info
| ObjCBoxedExpr (stmt_info, stmts, info, sel) ->
objCBoxedExpr_trans trans_state info sel stmt_info stmts
@ -2202,14 +2203,14 @@ struct
| ObjCStringLiteral(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_trans trans_state stmt_info stmt_list
| ObjCAtSynchronizedStmt(_, stmt_list) ->
objCAtSynchronizedStmt_trans trans_state stmt_list
| ObjCIndirectCopyRestoreExpr (stmt_info, stmt_list, _) ->
| ObjCIndirectCopyRestoreExpr (_, stmt_list, _) ->
instructions trans_state stmt_list
| BlockExpr(stmt_info, _ , expr_info, decl) ->
@ -2218,20 +2219,20 @@ struct
| ObjCAutoreleasePoolStmt (stmt_info, stmts) ->
objcAutoreleasePool_trans trans_state stmt_info stmts
| ObjCAtTryStmt (stmt_info, stmts) ->
compoundStmt_trans trans_state stmt_info stmts
| ObjCAtTryStmt (_, stmts) ->
compoundStmt_trans trans_state stmts
| ObjCAtThrowStmt (stmt_info, stmts) ->
returnStmt_trans trans_state stmt_info stmts
| ObjCAtFinallyStmt (stmt_info, stmts) ->
compoundStmt_trans trans_state stmt_info stmts
| ObjCAtFinallyStmt (_, stmts) ->
compoundStmt_trans trans_state stmts
| ObjCAtCatchStmt (stmt_info, stmts, obj_c_message_expr_kind) ->
compoundStmt_trans trans_state stmt_info []
| ObjCAtCatchStmt _ ->
compoundStmt_trans trans_state []
| PredefinedExpr (stmt_info, stmts, expr_info, predefined_expr_type) ->
stringLiteral_trans trans_state stmt_info expr_info ""
| PredefinedExpr (_, _, expr_info, _) ->
stringLiteral_trans trans_state expr_info ""
| BinaryConditionalOperator (stmt_info, stmts, expr_info) ->
(match stmts with
@ -2241,25 +2242,25 @@ struct
"BinaryConditionalOperator not translated %s @."
(Ast_utils.string_of_stmt instr);
assert false)
| CXXNewExpr (stmt_info, stmt_list, expr_info, _) ->
| CXXNewExpr (stmt_info, _, expr_info, _) ->
cxxNewExpr_trans trans_state stmt_info expr_info
| CXXDeleteExpr (stmt_info, stmt_list, expr_info, delete_expr_info) ->
cxxDeleteExpr_trans trans_state 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 delete_expr_info
| MaterializeTemporaryExpr (stmt_info, stmt_list, expr_info, _) ->
materializeTemporaryExpr_trans trans_state stmt_info stmt_list expr_info
| CompoundLiteralExpr (stmt_info, stmt_list, expr_info) ->
compoundLiteralExpr_trans trans_state stmt_info stmt_list expr_info
| CompoundLiteralExpr (_, stmt_list, expr_info) ->
compoundLiteralExpr_trans trans_state stmt_list expr_info
| InitListExpr (stmt_info, stmts, expr_info) ->
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 *)
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
| CXXDefaultArgExpr (stmt_info, stmt_list, expr_info, default_arg_info) ->
| CXXDefaultArgExpr (_, _, _, default_arg_info) ->
cxxDefaultArgExpr_trans trans_state default_arg_info
| 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 =
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
| _ ->
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
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
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 return_type =
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)
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
| None -> f a method_name mk_procname lang in
let class_type = Ast_expressions.create_class_type (class_name, `OBJC) in
| None -> f method_name mk_procname lang in
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_stringWithUTF8String 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_retain_release
|> next_predefined (get_predefined_ms_stringWithUTF8String class_name)
|> next_predefined (get_predefined_ms_autoreleasepool_init class_name)
|> next_predefined (get_predefined_ms_is_kind_of_class class_name)
let dispatch_functions = [
("_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 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
let init_ret_id = Ident.create_fresh Ident.knormal 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 [];
{ 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
match e' with
| Sil.Lvar pvar ->
@ -575,7 +575,7 @@ let rec is_owning_method s =
let rec is_method_call s =
match s with
| Clang_ast_t.ObjCMessageExpr (_, _ , _, mei) -> true
| Clang_ast_t.ObjCMessageExpr _ -> true
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false
| s'':: _ -> is_method_call s'')
@ -588,14 +588,14 @@ let get_info_from_decl_ref decl_ref =
let rec get_decl_ref_info s =
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
| Some decl_ref -> decl_ref
| None -> assert false)
| _ ->
match Clang_ast_proj.get_stmt_tuple s with
| stmt_info, [] -> assert false
| stmt_info, s'':: _ ->
| _, [] -> assert false
| _, s'':: _ ->
get_decl_ref_info 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
(match (CTrans_models.is_dispatch_function_name s) with
| None -> None
| Some (dispatch_function, block_arg_pos) ->
| Some (_, block_arg_pos) ->
try
(match IList.nth stmts block_arg_pos with
| 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 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
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
| Some type_ptr ->
(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
Sil.Tptr (typ, pointer_attribute_of_objc_attribute attr_info)
| _ -> 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 =
let open Clang_ast_t in
match c_type with
| NoneType (type_info) -> Sil.Tvoid
| BuiltinType (type_info, builtin_type_kind) ->
| NoneType _ -> Sil.Tvoid
| BuiltinType (_, builtin_type_kind) ->
sil_type_of_builtin_type_kind builtin_type_kind
| PointerType (type_info, type_ptr)
| ObjCObjectPointerType (type_info, type_ptr) ->
| PointerType (_, type_ptr)
| ObjCObjectPointerType (_, type_ptr) ->
let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in
if Sil.typ_equal typ (get_builtin_objc_type `ObjCClass) then
typ
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
| BlockPointerType (type_info, type_ptr) ->
| BlockPointerType (_, type_ptr) ->
let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in
Sil.Tptr (typ, Sil.Pk_pointer)
| IncompleteArrayType (type_info, type_ptr)
| DependentSizedArrayType (type_info, type_ptr)
| VariableArrayType (type_info, type_ptr) ->
| IncompleteArrayType (_, type_ptr)
| DependentSizedArrayType (_, type_ptr)
| VariableArrayType (_, type_ptr) ->
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
| FunctionProtoType (type_info, function_type_info, _)
| FunctionNoProtoType (type_info, function_type_info) ->
| FunctionProtoType _
| FunctionNoProtoType _ ->
Sil.Tfun false
| ParenType (type_info, type_ptr) ->
| ParenType (_, 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
| RecordType (type_info, pointer)
| EnumType (type_info, pointer) ->
| RecordType (_, pointer)
| EnumType (_, pointer) ->
decl_ptr_to_sil_type translate_decl tenv pointer
| ElaboratedType (type_info) ->
(match type_info.Clang_ast_t.ti_desugared_type with
Some type_ptr -> type_ptr_to_sil_type translate_decl tenv type_ptr
| None -> Sil.Tvoid)
| ObjCInterfaceType (type_info, pointer) ->
| ObjCInterfaceType (_, pointer) ->
decl_ptr_to_sil_type translate_decl tenv pointer
| RValueReferenceType (type_info, type_ptr)
| LValueReferenceType (type_info, type_ptr) ->
| RValueReferenceType (_, type_ptr)
| LValueReferenceType (_, type_ptr) ->
let typ = type_ptr_to_sil_type translate_decl tenv type_ptr in
Sil.Tptr (typ, Sil.Pk_reference)
| 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 found = ref None in
let mname = Mangled.from_string name in
let f tn typ =
let f _ typ =
match typ with
| Sil.Tenum 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 open Clang_ast_t in
match Ast_utils.get_type type_ptr with
| Some FunctionProtoType (type_info, function_type_info, _)
| Some FunctionNoProtoType (type_info, function_type_info) ->
| Some FunctionProtoType (_, function_type_info, _)
| Some FunctionNoProtoType (_, function_type_info) ->
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
| Some _ ->
Printing.log_err "Warning: Type pointer %s is not a function type."
@ -108,7 +108,7 @@ let rec expand_structured_type tenv typ =
typ
else expand_structured_type tenv t
| None -> typ)
| Sil.Tptr(t, _) -> typ (*do not expand types under pointers *)
| Sil.Tptr _ -> typ (*do not expand types under pointers *)
| _ -> typ
(* 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, *)
(* they should be added here too!! *)
let add_predefined_basic_types tenv =
let add_predefined_basic_types () =
let open Ast_expressions in
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
@ -71,16 +71,16 @@ let add_predefined_basic_types tenv =
let add_predefined_types tenv =
add_predefined_objc_types tenv;
add_predefined_basic_types tenv
add_predefined_basic_types ()
let create_csu opt_type =
match opt_type with
| `Type s ->
(let buf = Str.split (Str.regexp "[ \t]+") s in
match buf with
| "struct":: l ->Csu.Struct
| "class":: l -> Csu.Class Csu.CPP
| "union":: l -> Csu.Union
| "struct":: _ ->Csu.Struct
| "class":: _ -> Csu.Class Csu.CPP
| "union":: _ -> Csu.Union
| _ -> Csu.Struct)
| _ -> assert false
@ -90,8 +90,8 @@ let get_record_name_csu decl =
let name_info, csu = match decl with
| RecordDecl (_, name_info, opt_type, _, _, _, _) ->
name_info, create_csu opt_type
| CXXRecordDecl (_, name_info, opt_type, _, _, _, _, _)
| ClassTemplateSpecializationDecl (_, name_info, opt_type, _, _, _, _, _) ->
| CXXRecordDecl (_, name_info, _, _, _, _, _, _)
| ClassTemplateSpecializationDecl (_, name_info, _, _, _, _, _, _) ->
(* 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 *)
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_class_methods tenv class_name decl_list =
let get_class_methods class_name decl_list =
let process_method_decl = function
| Clang_ast_t.CXXMethodDecl (decl_info, name_info, tp, function_decl_info, _)
| Clang_ast_t.CXXConstructorDecl (decl_info, name_info, tp, function_decl_info, _)
| Clang_ast_t.CXXConversionDecl (decl_info, name_info, tp, function_decl_info, _)
| Clang_ast_t.CXXDestructorDecl (decl_info, name_info, tp, function_decl_info, _) ->
| Clang_ast_t.CXXMethodDecl (_, name_info, tp, _, _)
| Clang_ast_t.CXXConstructorDecl (_, name_info, tp, _, _)
| Clang_ast_t.CXXConversionDecl (_, name_info, tp, _, _)
| Clang_ast_t.CXXDestructorDecl (_, name_info, tp, _, _) ->
let method_name = name_info.Clang_ast_t.ni_name in
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
@ -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
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 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 sil_type = Sil.Tstruct {
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 open Clang_ast_t in
match var_decl with
| VarDecl (di, var_name, type_ptr, vdi) ->
| VarDecl (_, _, _, vdi) ->
if not vdi.Clang_ast_t.vdi_is_global then
Cfg.Procdesc.append_locals procdesc [(Sil.pvar_get_name pvar, sil_typ)]
| _ -> 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
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
match drei.Clang_ast_t.drti_decl_ref with
| 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 base_class_pointer_opt =
match decl with
| ObjCCategoryDecl (decl_info, name_info, decl_list, decl_context_info, cdi) ->
| ObjCCategoryDecl (_, _, _, _, cdi) ->
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
| _ -> None in
match base_class_pointer_opt with
| Some decl_ref ->
(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)
| _ -> 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 open Clang_ast_t in
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 curr_class = get_curr_class_from_category_decl name cdi in
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 open Clang_ast_t in
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 curr_class = get_curr_class_from_category_impl name cii in
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
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 =
let super = get_super_interface_decl otdi_super 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
Ast_utils.update_sil_types_map decl_key (Sil.Tvar interface_name);
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_protocols 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.sort_fields fields in
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;
let interface_type_info =
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
| Some Sil.Tstruct
({ Sil.static_fields = [];
csu = Csu.Class ck;
struct_name = Some name;
csu = Csu.Class _;
struct_name = Some _;
def_methods;
} as struct_typ) ->
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 open Clang_ast_t in
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
Printing.log_out "ADDING: ObjCImplementationDecl for class '%s'\n" class_name;
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 get_method decl list_methods =
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 method_kind = Procname.objc_method_kind_of_bool is_instance 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 open Clang_ast_t in
match decl with
| ObjCProtocolDecl(decl_info, name_info, decl_list, _, obj_c_protocol_decl_info) -> true
| ObjCProtocolDecl _ -> true
| _ -> false

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

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

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

@ -118,7 +118,7 @@ type from_call =
| From_containsKey (** x.containsKey *)
(** 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 =
let is_fun_nonnull ta = match TypeAnnotation.get_origin ta with
| 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. *)
let check_field_assignment
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, _) =
typecheck_expr node instr_ref curr_pname typestate exp_lhs
(typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.ONone, [loc]) loc in
@ -253,7 +253,7 @@ let check_constructor_initialization
then begin
match PatternMatch.get_this_type (Cfg.Procdesc.get_attributes curr_pdesc) with
| 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
| None -> false
| Some (_, ia) -> f ia in
@ -347,7 +347,7 @@ let spec_make_return_nullable curr_pname =
(** Check the annotations when returning from a method. *)
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 =
let ret_annotated_nullable = Annotations.ia_is_nullable ret_ia in
let ret_annotated_present = Annotations.ia_is_present ret_ia in
@ -414,11 +414,10 @@ let check_call_receiver
typestate
call_params
callee_pname
callee_loc
(instr_ref : TypeErr.InstrRef.t)
loc
typecheck_expr
print_current_state : unit =
: unit =
match call_params with
| ((original_this_e, this_e), typ) :: _ ->
let (_, this_ta, _) =
@ -447,8 +446,7 @@ let check_call_receiver
(** Check the parameters of a call. *)
let check_call_parameters
find_canonical_duplicate curr_pname node typestate callee_attributes
sig_params call_params loc annotated_signature
instr_ref typecheck_expr print_current_state : unit =
sig_params call_params loc instr_ref typecheck_expr : unit =
let callee_pname = callee_attributes.ProcAttributes.proc_name 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
@ -515,7 +513,7 @@ let check_call_parameters
(** Checks if the annotations are consistent with the inherited class or with the
implemented interfaces *)
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 loc = Cfg.Node.get_loc start_node in
@ -537,8 +535,8 @@ let check_overridden_annotations
and check_params overriden_proc_name overriden_signature =
let compare pos current_param overriden_param : int =
let current_name, current_ia, current_type = current_param in
let _, overriden_ia, overriden_type = overriden_param in
let current_name, current_ia, _ = current_param in
let _, overriden_ia, _ = overriden_param in
let () =
if not (Annotations.ia_is_nullable current_ia)
&& 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; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object";
] 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 =
[

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_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
| Some proc_attributes ->
let annotated_signature =
@ -53,7 +53,7 @@ module ComplexExpressions = struct
| None ->
false
let procname_is_true_on_null get_proc_desc pn =
let procname_is_true_on_null pn =
let annotated_true_on_null () =
match Specs.proc_resolve_attributes pn with
| Some proc_attributes ->
@ -102,8 +102,8 @@ module ComplexExpressions = struct
pp_to_string (Sil.pp_const pe_text) c
| Sil.Dderef de ->
dexp_to_string de
| Sil.Dfcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual })
| Sil.Dretcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual })
| Sil.Dfcall (fun_dexp, args, _, { Sil.cf_virtual = isvirtual })
| Sil.Dretcall (fun_dexp, args, _, { Sil.cf_virtual = isvirtual })
when functions_idempotent () ->
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
@ -117,13 +117,13 @@ module ComplexExpressions = struct
| Sil.Dpvar pv
| Sil.Dpvaraddr pv when not (Errdesc.pvar_is_frontend_tmp pv) ->
Sil.pvar_to_string pv
| Sil.Dpvar pv
| Sil.Dpvaraddr pv (* front-end variable -- this should not happen) *) ->
| Sil.Dpvar _
| Sil.Dpvaraddr _ (* front-end variable -- this should not happen) *) ->
case_not_handled ()
| Sil.Dunop (op, de) ->
Sil.str_unop op ^ dexp_to_string de
| Sil.Dsizeof (typ, sub) ->
| Sil.Dsizeof _ ->
case_not_handled ()
| Sil.Dunknown ->
case_not_handled () in
@ -180,7 +180,7 @@ let rec typecheck_expr
find_canonical_duplicate visited checks
node instr_ref curr_pname
typestate e1 tr_default loc
| Sil.Const c ->
| Sil.Const _ ->
let (typ, _, locs) = tr_default in
(typ, TypeAnnotation.const Annotations.Nullable false (TypeOrigin.Const loc), locs)
| Sil.Lfield (exp, fn, typ) ->
@ -238,16 +238,16 @@ let rec typecheck_expr
(** Typecheck an instruction. *)
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 =
let print_current_state () =
L.stdout "Current Typestate in node %a@\n%a@."
Cfg.Node.pp (TypeErr.InstrRef.get_node instr_ref)
(TypeState.pp ext) typestate;
L.stdout " %a@." (Sil.pp_instr pe_text) instr in
(* let print_current_state () = *)
(* L.stdout "Current Typestate in node %a@\n%a@." *)
(* Cfg.Node.pp (TypeErr.InstrRef.get_node instr_ref) *)
(* (TypeState.pp ext) typestate; *)
(* 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.
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'. *)
let handle_field_access_via_temporary typestate exp loc =
let handle_field_access_via_temporary typestate exp =
let name_is_temporary name =
let prefix = "$T" 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.
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 exp =
handle_field_access_via_temporary
typestate
(Idenv.expand_expr idenv _exp)
loc in
let exp = handle_field_access_via_temporary typestate (Idenv.expand_expr idenv _exp) in
let default = exp, typestate in
(* 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
end
| Sil.Lvar pvar ->
| Sil.Lvar _ ->
default
| Sil.Lfield (_exp, fn, typ) when ComplexExpressions.parameter_and_static_field () ->
let exp' = Idenv.expand_expr_temps idenv node _exp in
let is_parameter_field pvar = (* parameter.field *)
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
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 typestate' = update_typestate_fld pvar fn typ in
(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 *)
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
@ -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
if Procname.is_constructor pname then
match PatternMatch.get_this_type proc_attributes with
| Some this_type ->
| Some _ ->
begin
constructor_check_calls_this calls_this pname;
(* 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
n_str = "this" ||
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
match instr with
| Sil.Remove_temps (idl, loc) ->
| Sil.Remove_temps (idl, _) ->
if remove_temps then IList.fold_right TypeState.remove_id idl typestate
else typestate
| 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
(typecheck_expr_simple typestate' e' typ TypeOrigin.Undef loc)
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 *)
typestate
| 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
instr_ref typestate1 e1' e2 typ loc fn t_ia_opt
(typecheck_expr find_canonical_duplicate calls_this checks)
print_current_state
| _ -> () in
let typestate2 =
match e1' with
@ -503,7 +498,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
pvar
(typecheck_expr_simple typestate1 e2 typ TypeOrigin.Undef loc)
typestate1
| Sil.Lfield (_, fn, styp) ->
| Sil.Lfield _ ->
typestate1
| _ ->
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
| Some proc_attributes -> proc_attributes
| None -> assert false in
let callee_loc = callee_attributes.ProcAttributes.loc in
let etl = drop_unchecked_params calls_this callee_attributes _etl in
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 =
(* remove the nullable flag for the given pvar *)
match TypeState.lookup_pvar pvar typestate'' with
| Some (t, ta, locs) ->
| Some (t, ta, _) ->
let should_report =
EradicateChecks.activate_condition_redundant &&
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
match find_parameter parameter_num call_params with
| Some (pvar, typ) ->
| Some (pvar, _) ->
if is_vararg
then
let do_vararg_value e ts = match Idenv.expand_expr idenv e with
| Sil.Lvar pvar1 ->
pvar_apply loc clear_nullable_flag ts pvar1
| _ -> 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'
else
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
| _ -> () in
match call_params with
| ((_, Sil.Lvar pvar), typ):: _ ->
| ((_, Sil.Lvar pvar), _):: _ ->
(* temporary variable for the value of the boolean condition *)
begin
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) ->
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 ->
handle_optional_isPresent node' e
| _ -> () in
@ -733,8 +727,8 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
object_t)
parameters in
match call_params with
| ((_, Sil.Lvar pv_map), typ_map) ::
((_, exp_key), typ_key) ::
| ((_, Sil.Lvar pv_map), _) ::
((_, exp_key), _) ::
((_, exp_value), typ_value) :: _ ->
(* Convert the dexp for k to the dexp for m.get(k) *)
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
call_params
callee_pname
callee_loc
instr_ref
loc
(typecheck_expr find_canonical_duplicate calls_this checks)
print_current_state;
(typecheck_expr find_canonical_duplicate calls_this checks);
if checks.eradicate then
EradicateChecks.check_call_parameters
find_canonical_duplicate
@ -794,18 +786,15 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
signature_params
call_params
loc
annotated_signature
instr_ref
(typecheck_expr find_canonical_duplicate calls_this checks)
print_current_state;
(typecheck_expr find_canonical_duplicate calls_this checks);
let typestate2 =
if checks.check_extension then
let etl' = IList.map (fun ((_, e), t) -> (e, t)) call_params in
let extension = TypeState.get_extension typestate1 in
let extension' =
ext.TypeState.check_instr
get_proc_desc curr_pname curr_pdesc node
extension instr etl' in
get_proc_desc curr_pname curr_pdesc extension instr etl' in
TypeState.set_extension typestate1 extension'
else typestate1 in
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
| Sil.Call _ ->
typestate
| Sil.Prune (cond, loc, true_branch, ik) ->
| Sil.Prune (cond, loc, true_branch, _) ->
let rec check_condition node' c : _ TypeState.t =
(* check if the expression is coming from a call, and return the argument *)
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 ->
begin
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 ->
Some e1
| _ -> 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 *)
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 *)
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 *)
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
EradicateChecks.check_zero
find_canonical_duplicate get_proc_desc curr_pname
find_canonical_duplicate curr_pname
node' e' typ
ta true_branch EradicateChecks.From_condition
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 ->
begin
match from_containsKey e with
| Some e1 when ComplexExpressions.functions_idempotent () ->
| Some _ when ComplexExpressions.functions_idempotent () ->
handle_containsKey e
| _ ->
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
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;
begin
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'', c2' = normalize_cond node' c2 in
node'', Sil.BinOp (bop, c1', c2')
| Sil.Var id ->
| Sil.Var _ ->
let c' = Idenv.expand_expr idenv _cond in
if not (Sil.exp_equal c' _cond) then normalize_cond _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) =
Cfg.Node.equal n1 n2 && i1 = i2
let hash (n, i) = Hashtbl.hash (Cfg.Node.hash n, i)
let get_node (n, i) = n
let replace_node (n, i) n' = (n', i)
let get_node (n, _) = n
let replace_node (_, i) n' = (n', i)
let create_generator n = (n, ref 0)
let gen instr_ref_gen =
let (node, ir) = instr_ref_gen in
@ -88,11 +88,12 @@ module H = Hashtbl.Make(struct
Procname.equal pn1 pn2
| Field_not_initialized (_, _), _
| _, 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
| Field_not_mutable _, _
| _, 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 &&
Ident.fieldname_equal fn1 fn2
| Field_annotation_inconsistent _, _
@ -102,21 +103,21 @@ module H = Hashtbl.Make(struct
Procname.equal pn1 pn2
| Field_over_annotated (_, _), _
| _, 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 &&
Ident.fieldname_equal fn1 fn2 &&
bool_equal ii1 ii2
| Null_field_access _, _
| _, Null_field_access _ -> false
| Call_receiver_annotation_inconsistent (ann1, so1, pn1, od1),
Call_receiver_annotation_inconsistent (ann2, so2, pn2, od2) ->
| Call_receiver_annotation_inconsistent (ann1, so1, pn1, _),
Call_receiver_annotation_inconsistent (ann2, so2, pn2, _) ->
ann1 = ann2 &&
(opt_equal string_equal) so1 so2 &&
Procname.equal pn1 pn2
| Call_receiver_annotation_inconsistent _, _
| _, Call_receiver_annotation_inconsistent _ -> false
| Parameter_annotation_inconsistent (ann1, s1, n1, pn1, cl1, od1),
Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, od2) ->
| Parameter_annotation_inconsistent (ann1, s1, n1, pn1, cl1, _),
Parameter_annotation_inconsistent (ann2, s2, n2, pn2, cl2, _) ->
ann1 = ann2 &&
string_equal s1 s2 &&
int_equal n1 n2 &&
@ -124,8 +125,8 @@ module H = Hashtbl.Make(struct
Location.equal cl1 cl2
| Parameter_annotation_inconsistent _, _
| _, Parameter_annotation_inconsistent _ -> false
| Return_annotation_inconsistent (ann1, pn1, od1),
Return_annotation_inconsistent (ann2, pn2, od2) ->
| Return_annotation_inconsistent (ann1, pn1, _),
Return_annotation_inconsistent (ann2, pn2, _) ->
ann1 = ann2 && Procname.equal pn1 pn2
| Return_annotation_inconsistent _, _
| _, Return_annotation_inconsistent _ -> false
@ -158,19 +159,19 @@ module H = Hashtbl.Make(struct
Hashtbl.hash (1, b, string_opt_hash so, nn)
| Field_not_initialized (fn, 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))
| Field_annotation_inconsistent (ann, fn, od) ->
| Field_annotation_inconsistent (ann, fn, _) ->
Hashtbl.hash (4, ann, string_hash (Ident.fieldname_to_string fn))
| Field_over_annotated (fn, 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))
| 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)
| 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)
| Return_annotation_inconsistent (ann, pn, od) ->
| Return_annotation_inconsistent (ann, pn, _) ->
Hashtbl.hash (9, ann, Procname.hash_pname pn)
| Return_over_annotated pn ->
Hashtbl.hash (10, Procname.hash_pname pn)
@ -302,9 +303,7 @@ type st_report_error =
unit
(** Report an error right now. *)
let report_error_now
(st_report_error : st_report_error)
node err_instance instr_ref_opt loc proc_name : unit =
let report_error_now (st_report_error : st_report_error) node err_instance loc proc_name : unit =
let demo_mode = true in
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
@ -423,7 +422,7 @@ let report_error_now
None,
None,
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
| Annotations.Nullable ->
"ERADICATE_PARAMETER_NOT_NULLABLE",
@ -524,8 +523,7 @@ let report_error st_report_error find_canonical_duplicate node
let should_report_now =
add_err find_canonical_duplicate err_instance instr_ref_opt loc in
if should_report_now then
report_error_now
st_report_error node err_instance instr_ref_opt loc proc_name
report_error_now st_report_error node err_instance loc proc_name
(** 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 =
@ -535,8 +533,7 @@ let report_forall_checks_and_reset st_report_error proc_name =
let node = InstrRef.get_node instr_ref in
State.set_node node;
if is_forall && err_state.always
then report_error_now
st_report_error node err_instance instr_ref_opt err_state.loc proc_name
then report_error_now st_report_error node err_instance err_state.loc proc_name
| None, _ -> () in
H.iter iter err_tbl;
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
let to_string = function
| Const loc -> "Const"
| Field (fn, loc) -> "Field " ^ Ident.fieldname_to_simplified_string fn
| Const _ -> "Const"
| Field (fn, _) -> "Field " ^ Ident.fieldname_to_simplified_string fn
| Formal s -> "Formal " ^ Mangled.to_string s
| Proc po ->
Printf.sprintf

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

@ -23,8 +23,7 @@ type 'a ext =
{
empty : 'a; (** empty extension *)
check_instr : (** check the extension for an instruction *)
get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t
-> 'a -> Sil.instr -> parameters -> 'a;
get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> 'a -> Sil.instr -> parameters -> 'a;
join : 'a -> 'a -> 'a; (** join two extensions *)
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 *)
check_instr : (** check the extension for an instruction *)
get_proc_desc -> Procname.t -> Cfg.Procdesc.t -> Cfg.Node.t
->'a -> Sil.instr -> parameters -> 'a;
get_proc_desc -> Procname.t -> Cfg.Procdesc.t ->'a -> Sil.instr -> parameters -> 'a;
join : 'a -> 'a -> 'a; (** join two extensions *)
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
let rec add_typ class_name typs =
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
and get_supers_rec typ tenv all_supers =
and get_supers_rec typ all_supers =
let direct_supers = get_direct_supers typ in
IList.fold_left
(fun typs class_name -> add_typ class_name typs)
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] *)
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] *)
let get_callbacks_registered_by_proc procdesc tenv =
let collect_callback_typs callback_typs node instr = match instr with
| Sil.Call([], Sil.Const (Sil.Cfun callee), args, loc, _) ->
let collect_callback_typs callback_typs _ instr = match instr with
| Sil.Call([], Sil.Const (Sil.Cfun callee), args, _, _) ->
begin
match get_callback_registered_by callee args tenv with
| 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.
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
* Button.OnClickListener[line 7]*)
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
| Some cfg ->
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)
| None -> registered_callbacks
) lifecycle_cfg_files []
(** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a
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 } ->
let class_name = Typename.TN_csu (Csu.Class Csu.Java, name) in
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
* [lifecycle_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 ->
(* 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
let callback_fields =
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
| None -> ()
) 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)
with Not_found ->
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_typ = Sil.Tarray (inner_typ, arr_size) in
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 *)
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
((exp, formal_typ) :: args, env) in
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
(* 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
| ((name, typ) :: formals, Some receiver) -> (name, receiver) :: formals
| ((name, _) :: formals, Some receiver) -> (name, receiver) :: formals
| (formals, None) -> formals
| ([], Some receiver) ->
| ([], Some _) ->
L.err
"Expected at least one formal to bind receiver to in method %a@." Procname.pp procname;
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
(** 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_dir =
let sources_dir = DB.sources_dir () in
@ -248,13 +248,13 @@ let write_harness_to_file harness_instrs harness_file =
close_outf outf)
(** 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;
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
* 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 *)
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.add_removetemps_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 *)
Cg.store_to_file cg_file cg;
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
* 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
(* pick an arbitrary cg and cfg to piggyback the harness code onto *)
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
(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 harness_cfg tenv in
let harness_file = create_dummy_harness_file harness_name in
let start_line = (Cg.get_nLOC cg) + 1 in
let empty_env =
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 *)
inhabit_fld_trace cb_flds proc_file_map env' in
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
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
order with the specified receiver and add it to the execution environment *)
val inhabit_trace : lifecycle_trace -> callback_trace -> Procname.t ->
DB.source_file Procname.Map.t -> Sil.tenv -> unit
DB.source_file Procname.Map.t -> unit
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. *)
let translate a : Sil.annotation =
let class_name = JBasics.cn_name a.JBasics.kind in
let translate_value_pair (name, value) =
let translate_value_pair (_, value) =
match value with
| JBasics.EVArray [JBasics.EVCstString 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 var_map = get_var_map context in
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
JBir.VarMap.iter aux var_map
let get_var_type context var =
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
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
| Some jump_pc -> get_body_nodes jump_pc in
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
let connect node pc =
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. *)
let add_amethod program icfg node am is_static =
let add_amethod program icfg am is_static =
let cfg = icfg.JContext.cfg in
let tenv = icfg.JContext.tenv 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 ->
add_cmethod never_null_matcher program icfg node cm method_kind
| Javalib.AbstractMethod am ->
add_amethod program icfg node am method_kind
add_amethod program icfg am method_kind
) node
end
@ -225,7 +225,7 @@ let compute_source_icfg
(JClasspath.get_classmap program) in
(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 =
{ JContext.cg = Cg.create ();
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 ->
Sil.tenv ->
JCode.jcode Javalib.interface_or_class ->
DB.source_file ->
Cg.t * Cfg.cfg

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

@ -73,7 +73,7 @@ let print_usage_exit () =
exit(1)
let () =
Arg.parse arg_desc (fun arg -> ()) usage;
Arg.parse arg_desc (fun _ -> ()) usage;
if Config.analyze_models && !JClasspath.models_jar <> "" then
failwith "Not expecting model file when analyzing the models";
if not Config.analyze_models && !JClasspath.models_jar = "" then
@ -91,7 +91,7 @@ let init_global_state source_file =
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 cn = JBasics.make_cn typ_str in
ignore (JTransType.get_class_type program tenv cn) in
@ -125,7 +125,7 @@ let do_source_file
JFrontend.compute_source_icfg
never_null_matcher linereader classes program tenv
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
IList.fold_left
(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
init_global_state fake_source_file;
let call_graph, cfg =
JFrontend.compute_class_icfg
never_null_matcher linereader program tenv node fake_source_file in
store_icfg tenv call_graph cfg fake_source_file program;
JFrontend.compute_class_icfg never_null_matcher linereader program tenv node in
store_icfg tenv call_graph cfg program;
JFrontend.cache_classname cn;
end in
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 *)
let load_tenv program =
let load_tenv () =
let tenv_filename = DB.global_tenv_fname () in
let tenv =
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 *)
let save_tenv classpath tenv =
let save_tenv tenv =
if not Config.analyze_models then JTransType.add_models_types tenv;
let tenv_filename = DB.global_tenv_fname () in
(* 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)
(JBasics.ClassSet.cardinal classes);
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 skip_translation_matcher =
Inferconfig.SkipTranslationMatcher.load_matcher (Inferconfig.inferconfig ()) in
@ -198,7 +197,7 @@ let do_all_files classpath sources classes =
let proc_file_map =
let skip source_file =
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;
if skip source_file then map
else do_source_file
@ -219,7 +218,7 @@ let do_all_files classpath sources classes =
if !JConfig.dependency_mode then
capture_libs never_null_matcher linereader program tenv;
if !JConfig.create_harness then Harness.create_harness proc_file_map tenv;
save_tenv classpath tenv;
save_tenv tenv;
JClasspath.cleanup program;
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 ln =
try JBir.get_source_line_number pc impl
with Invalid_argument e -> None in
with Invalid_argument _ -> None in
match ln with
| None -> 0
| Some n -> n in
@ -78,7 +78,7 @@ let get_undefined_method_call ovt =
| JBasics.TObject ot ->
begin
match ot with
| JBasics.TArray vt -> assert false
| JBasics.TArray _ -> assert false
| JBasics.TClass cn ->
if JBasics.cn_name cn = JConfig.string_cl then
"string_undefined"
@ -100,10 +100,10 @@ let retrieve_fieldname fieldname =
assert false
else
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
| Sil.Tstruct { Sil.instance_fields; static_fields; csu = Csu.Class _ } ->
let fieldname, _, _ =
@ -195,9 +195,9 @@ let get_binop binop =
| JBir.LXor -> Sil.BXor
| JBir.LUshr ->
raise (Frontend_error "Unsigned right shift operator")
| JBir.CMP comp ->
| JBir.CMP _ ->
raise (Frontend_error "Unsigned right shift operator")
| JBir.ArrayLoad vt ->
| JBir.ArrayLoad _ ->
raise (Frontend_error "Array load operator")
let get_test_operator op =
@ -354,7 +354,7 @@ let create_local_procdesc program linereader cfg tenv node m =
| Created defined_status ->
begin
match defined_status with
| Defined procdesc -> assert false
| Defined _ -> assert false
| Called procdesc ->
Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name procdesc) false;
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 tenv = JContext.get_tenv context 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 sil_instr = Sil.Letderef (id, Sil.Lvar pvar, type_of_expr, loc) in
([id], [sil_instr], Sil.Var id) in
match expr with
| JBir.Var (vt, var) ->
| JBir.Var (_, var) ->
let pvar = (JContext.set_pvar context var type_of_expr) in
trans_var pvar type_of_expr
trans_var pvar
| JBir.Const c ->
begin
match c with (* We use the constant <field> internally to mean a variable. *)
| `String s when (JBasics.jstr_pp s) = JConfig.field_cst ->
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 pvar = Sil.mk_pvar varname procname in
trans_var pvar string_type
trans_var pvar
| _ -> ([], [], Sil.Const (get_constant c))
end
| JBir.Unop (unop, ex) ->
@ -454,8 +453,8 @@ let rec expression context pc expr =
JTransType.sizeof_of_object_type program tenv ot subtypes in
let builtin =
(match unop with
| JBir.InstanceOf ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof)
| JBir.Cast ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast)
| JBir.InstanceOf _ -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof)
| JBir.Cast _ -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__cast)
| _ -> assert false) in
let args = [(sil_ex, type_of_ex); (sizeof_expr, Sil.Tvoid)] 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
begin
match binop with
| JBir.ArrayLoad vt ->
| JBir.ArrayLoad _ ->
(* add an instruction that dereferences the array *)
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
@ -485,7 +484,7 @@ let rec expression context pc expr =
end
| JBir.Field (ex, cn, fs) ->
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_expr = Sil.Lfield (sil_expr, field_name, sil_type) 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
Sil.Lvar var_name 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
if JTransStaticField.is_static_final_field context cn fs && use_static_final_fields context
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
else
match node with
| Javalib.JInterface jinterface -> fallback_cn
| Javalib.JInterface _ -> fallback_cn
| Javalib.JClass jclass ->
begin
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
| _ -> true in
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 =
match sil_obj_type with
| 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
(* 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 ->
let set_file_attr =
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]
(* 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 ->
let set_mem_attr =
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
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
(let cn = JBasics.make_cn JConfig.infer_array_cl 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) ->
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 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_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
@ -848,7 +847,7 @@ let rec instruction context pc instr : translation =
Sil.Lvar var_name in
let (idl1, stml1, sil_expr_lhs) = [], [], class_exp 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_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
@ -967,8 +966,8 @@ let rec instruction context pc instr : translation =
begin
match obj_type with
| JBasics.TClass cn -> trans_virtual_call cn I_Virtual
| JBasics.TArray vt ->
let instr = instruction_array_call ms obj_type obj args var_opt vt in
| JBasics.TArray _ ->
let instr = instruction_array_call ms obj_type obj args var_opt in
instruction context pc instr
end
| JBir.InterfaceCall cn ->
@ -1013,7 +1012,7 @@ let rec instruction context pc instr : translation =
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 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
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
@ -1024,7 +1023,7 @@ let rec instruction context pc instr : translation =
| 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 =
expression context pc array_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 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_procname, call_ids, call_instrs =
let _, call_ids, call_instrs =
method_invocation
context loc pc None out_of_bound_cn constr_ms
(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 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_procname, call_ids, call_instrs =
let _, call_ids, call_instrs =
method_invocation context loc pc None cce_cn constr_ms
(Some (Sil.Var ret_id, class_type)) [] I_Special Procname.Static 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