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

[whitespace] indent .ml files as well

Browse Source
master
Jules Villard 10 years ago
parent 6911a1516c
commit bae8a4dced
101 changed files with 5243 additions and 5243 deletions
Show Stats Download Patch File Download Diff File

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

@ -142,12 +142,12 @@ let find_source_dirs () =
let add_cg_files_from_dir dir =
let files = Array.to_list (Sys.readdir dir) in
list_iter (fun fname ->
let path = Filename.concat dir fname in
if Filename.check_suffix path ".cg" then source_dirs := dir :: !source_dirs)
let path = Filename.concat dir fname in
if Filename.check_suffix path ".cg" then source_dirs := dir :: !source_dirs)
files in
list_iter (fun fname ->
let dir = Filename.concat capt_dir fname in
if Sys.is_directory dir then add_cg_files_from_dir dir)
let dir = Filename.concat capt_dir fname in
if Sys.is_directory dir then add_cg_files_from_dir dir)
files_in_results_dir;
list_rev !source_dirs
@ -193,15 +193,15 @@ let create_dir dir =
try
if (Unix.stat dir).Unix.st_kind != Unix.S_DIR then
(L.err "@.ERROR: file %s exists and is not a directory@." dir;
assert false)
assert false)
with Unix.Unix_error _ ->
(try Unix.mkdir dir 0o700 with
Unix.Unix_error _ ->
let created_concurrently = (* check if another process created it meanwhile *)
(Unix.stat dir).Unix.st_kind = Unix.S_DIR in
if not created_concurrently then
(L.err "@.ERROR: cannot create directory %s@." dir;
assert false))
(try Unix.mkdir dir 0o700 with
Unix.Unix_error _ ->
let created_concurrently = (* check if another process created it meanwhile *)
(Unix.stat dir).Unix.st_kind = Unix.S_DIR in
if not created_concurrently then
(L.err "@.ERROR: cannot create directory %s@." dir;
assert false))
let read_whole_file fd =
let stats = Unix.fstat fd in
@ -216,9 +216,9 @@ let read_whole_file fd =
buf
(** Update the file contents with the update function provided.
If the directory does not exist, it is created.
If the file does not exist, it is created, and update is given the empty string.
A lock is used to allow write attempts in parallel. *)
If the directory does not exist, it is created.
If the file does not exist, it is created, and update is given the empty string.
A lock is used to allow write attempts in parallel. *)
let update_file_with_lock dir fname update =
let reset_file fd =
let n = Unix.lseek fd 0 Unix.SEEK_SET in
@ -238,7 +238,7 @@ let update_file_with_lock dir fname update =
if (i = (String.length str))
then (Unix.lockf fd Unix.F_ULOCK 0; Unix.close fd)
else (L.err "@.save_with_lock: fail on path: %s@." path;
assert false)
assert false)
(** Read a file using a lock to allow write attempts in parallel. *)
let read_file_with_lock dir fname =
@ -252,8 +252,8 @@ let read_file_with_lock dir fname =
Unix.close fd;
Some buf
with Unix.Unix_error _ ->
L.stderr "read_file_with_lock: Unix error";
assert false
L.stderr "read_file_with_lock: Unix error";
assert false
with Unix.Unix_error _ -> None
(** {2 Results Directory} *)

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

@ -421,10 +421,10 @@ let typ_get_recursive_flds tenv te =
match te with
| Sil.Sizeof (typ, _) ->
(match typ with
| Sil.Tvar _ -> assert false (* there should be no indirection *)
| Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> []
| Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> list_map (fun (x, y, z) -> x) (list_filter filter fld_typ_ann_list)
| Sil.Tarray _ -> [])
| Sil.Tvar _ -> assert false (* there should be no indirection *)
| Sil.Tint _ | Sil.Tvoid | Sil.Tfun _ | Sil.Tptr _ | Sil.Tfloat _ | Sil.Tenum _ -> []
| Sil.Tstruct (fld_typ_ann_list, _, _, _, _, _, _) -> list_map (fun (x, y, z) -> x) (list_filter filter fld_typ_ann_list)
| Sil.Tarray _ -> [])
| Sil.Var _ -> [] (* type of |-> not known yet *)
| Sil.Const _ -> []
| _ ->
@ -933,7 +933,7 @@ let create_absrules_from_tdecl tenv tname =
match is_simply_recursive tenv tname with
| None -> ()
| Some (fld) ->
(* L.out "@[.... Adding Abstraction Rules ....@\n@."; *)
(* L.out "@[.... Adding Abstraction Rules ....@\n@."; *)
let para = create_hpara_from_tname_flds tenv tname fld [] [] Sil.inst_abstraction in
abs_rules_add_sll para
else ()
@ -949,27 +949,27 @@ let abstract_pure_part p ~(from_abstract_footprint: bool) =
let filter atom =
let fav' = Sil.atom_fav atom in
Sil.fav_for_all fav' (fun id ->
if Ident.is_primed id then Sil.fav_mem fav_sigma id
else if Ident.is_footprint id then Sil.fav_mem fav_nonpure id
else true) in
if Ident.is_primed id then Sil.fav_mem fav_sigma id
else if Ident.is_footprint id then Sil.fav_mem fav_nonpure id
else true) in
list_filter filter pure in
let new_pure =
list_fold_left
(fun pi a ->
match a with
| Sil.Aneq (Sil.Var name, _) -> 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))
| Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Le, _, _))
| Sil.Aeq (Sil.BinOp (Sil.Le, _, _), Sil.Const (Sil.Cint i)) when Sil.Int.isone i ->
a :: pi
| Sil.Aeq (Sil.Var name, e) when not (Ident.is_primed name) ->
(match e with
| Sil.Var _
| Sil.Const _ -> a :: pi
| _ -> pi)
| _ -> pi)
match a with
| Sil.Aneq (Sil.Var name, _) -> 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))
| Sil.Aeq (Sil.Const (Sil.Cint i), Sil.BinOp (Sil.Le, _, _))
| Sil.Aeq (Sil.BinOp (Sil.Le, _, _), Sil.Const (Sil.Cint i)) when Sil.Int.isone i ->
a :: pi
| Sil.Aeq (Sil.Var name, e) when not (Ident.is_primed name) ->
(match e with
| Sil.Var _
| Sil.Const _ -> a :: pi
| _ -> pi)
| _ -> pi)
[] pi_filtered in
list_rev new_pure in
@ -988,8 +988,8 @@ let abstract_gc p =
let p_without_pi = Prop.normalize (Prop.replace_pi [] p) in
let fav_p_without_pi = Prop.prop_fav p_without_pi in
(* let weak_filter atom =
let fav_atom = atom_fav atom in
list_intersect compare fav_p_without_pi fav_atom in *)
let fav_atom = atom_fav atom in
list_intersect compare fav_p_without_pi fav_atom in *)
let strong_filter = function
| Sil.Aeq(e1, e2) | Sil.Aneq(e1, e2) ->
let fav_e1 = Sil.exp_fav e1 in
@ -1046,8 +1046,8 @@ let sigma_reachable root_fav sigma =
if modified then find_fixpoint edges_to_revisit in
find_fixpoint !edges;
(* L.d_str "reachable: ";
Ident.IdentSet.iter (fun id -> Sil.d_exp (Sil.Var id); L.d_str " ") !reach_set;
L.d_ln (); *)
Ident.IdentSet.iter (fun id -> Sil.d_exp (Sil.Var id); L.d_str " ") !reach_set;
L.d_ln (); *)
!reach_set
let get_cycle root prop =
@ -1056,19 +1056,19 @@ let get_cycle root prop =
match e with
| Sil.Eexp(e', _) ->
(try
Some(list_find (fun hpred -> match hpred with
| Sil.Hpointsto(e'', _, _) -> Sil.exp_equal e'' e'
| _ -> false) sigma)
with _ -> None)
Some(list_find (fun hpred -> match hpred with
| Sil.Hpointsto(e'', _, _) -> Sil.exp_equal e'' e'
| _ -> false) sigma)
with _ -> None)
| _ -> None in
let print_cycle cyc =
(L.d_str "Cycle= ";
list_iter (fun ((e, t), f, e') ->
match e, e' with
| Sil.Eexp (e, _), Sil.Eexp (e', _) ->
L.d_str ("("^(Sil.exp_to_string e)^": "^(Sil.typ_to_string t)^", "^(Ident.fieldname_to_string f)^", "^(Sil.exp_to_string e')^")")
| _ -> ()) cyc;
L.d_strln "") in
list_iter (fun ((e, t), f, e') ->
match e, e' with
| Sil.Eexp (e, _), Sil.Eexp (e', _) ->
L.d_str ("("^(Sil.exp_to_string e)^": "^(Sil.typ_to_string t)^", "^(Ident.fieldname_to_string f)^", "^(Sil.exp_to_string e')^")")
| _ -> ()) cyc;
L.d_strln "") in
(* perform a dfs of a graph stopping when e_root is reached. *)
(* Returns a pair (path, bool) where path is a list of edges ((e1,type_e1),f,e2) *)
(* describing the path to e_root and bool is true if e_root is reached. *)
@ -1129,7 +1129,7 @@ let full_reachability_algorithm = true
let should_raise_objc_leak prop hpred =
match hpred with
| Sil.Hpointsto(e, Sil.Estruct((fn, Sil.Eexp( (Sil.Const (Sil.Cint i)), _)):: _, _), Sil.Sizeof (typ, _))
when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) ->
when Ident.fieldname_is_hidden fn && Sil.Int.gt i Sil.Int.zero (* counter > 0 *) ->
Mleak_buckets.should_raise_leak typ
| _ -> None
@ -1155,7 +1155,7 @@ let get_var_retain_cycle _prop =
let is_hpred_block v h =
match h, v with
| Sil.Hpointsto (e, _, Sil.Sizeof(typ, _)), Sil.Eexp (e', _)
when Sil.exp_equal e e' && Sil.is_block_type typ -> true
when Sil.exp_equal e e' && Sil.is_block_type typ -> true
| _, _ -> false in
let find_pvar v =
try
@ -1171,8 +1171,8 @@ let get_var_retain_cycle _prop =
match find_pvar e with
| Some pvar -> [((sexp pvar, t), f, e')]
| _ -> (match find_block e with
| Some blk -> [((sexp blk, t), f, e')]
| _ -> [((sexp (Sil.Sizeof(t, Sil.Subtype.exact)), t), f, e')]) in
| Some blk -> [((sexp blk, t), f, e')]
| _ -> [((sexp (Sil.Sizeof(t, Sil.Subtype.exact)), t), f, e')]) in
(* returns the pvars of the first cycle we find in sigma. *)
(* This is an heuristic that works if there is one cycle. *)
(* In case there are more than one cycle we may return not necessarily*)
@ -1202,7 +1202,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
| Sil.Tstruct(nsf, sf, _, _, _, _, _) ->
let ia = ref [] in
list_iter (fun (fn', t', ia') ->
if Ident.fieldname_equal fn fn' then ia := ia') (nsf@sf);
if Ident.fieldname_equal fn fn' then ia := ia') (nsf@sf);
!ia
| _ -> [] in
let rec has_weak_or_unretained_or_assign params =
@ -1212,7 +1212,7 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
| _:: params' -> has_weak_or_unretained_or_assign params' in
let do_annotation (a, _) =
((a.Sil.class_name = Config.property_attributes) ||
(a.Sil.class_name = Config.ivar_attributes)) && has_weak_or_unretained_or_assign a.Sil.parameters in
(a.Sil.class_name = Config.ivar_attributes)) && has_weak_or_unretained_or_assign a.Sil.parameters in
let rec do_cycle c =
match c with
| [] -> false
@ -1308,26 +1308,26 @@ let check_junk ?original_prop pname tenv prop =
Exceptions.Leak (fp_part, prop, hpred, Errdesc.explain_leak tenv hpred prop alloc_attribute objc_ml_bucket_opt, !Absarray.array_abstraction_performed, resource, try assert false with Assert_failure x -> x) in
let ignore_resource, exn =
(match alloc_attribute, resource with
| Some _, Sil.Rmemory Sil.Mobjc when (hpred_in_cycle hpred) ->
(* When there is a cycle in objc we ignore it only if it has weak or unsafe_unretained fields *)
(* Otherwise we report a retain cycle*)
let cycle = get_var_retain_cycle (remove_opt original_prop) in
if cycle_has_weak_or_unretained_or_assign_field cycle then
true, exn_retain_cycle cycle
else false, exn_retain_cycle cycle
| Some _, Sil.Rmemory Sil.Mobjc ->
objc_ml_bucket_opt = None, exn_leak
| Some _, Sil.Rmemory _ -> !Sil.curr_language = Sil.Java, exn_leak
| Some _, Sil.Rignore -> true, exn_leak
| Some _, Sil.Rfile -> false, exn_leak
| Some _, Sil.Rlock -> false, exn_leak
| _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter hpred ->
(* When its a cycle and the object has a ref counter then *)
(* we have a retain cycle. Objc object may not have the *)
(* Sil.Mobjc qualifier when added in footprint doing abduction *)
let cycle = get_var_retain_cycle (remove_opt original_prop) in
false, exn_retain_cycle cycle
| _ -> !Sil.curr_language = Sil.Java, exn_leak) in
| Some _, Sil.Rmemory Sil.Mobjc when (hpred_in_cycle hpred) ->
(* When there is a cycle in objc we ignore it only if it has weak or unsafe_unretained fields *)
(* Otherwise we report a retain cycle*)
let cycle = get_var_retain_cycle (remove_opt original_prop) in
if cycle_has_weak_or_unretained_or_assign_field cycle then
true, exn_retain_cycle cycle
else false, exn_retain_cycle cycle
| Some _, Sil.Rmemory Sil.Mobjc ->
objc_ml_bucket_opt = None, exn_leak
| Some _, Sil.Rmemory _ -> !Sil.curr_language = Sil.Java, exn_leak
| Some _, Sil.Rignore -> true, exn_leak
| Some _, Sil.Rfile -> false, exn_leak
| Some _, Sil.Rlock -> false, exn_leak
| _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter hpred ->
(* When its a cycle and the object has a ref counter then *)
(* we have a retain cycle. Objc object may not have the *)
(* Sil.Mobjc qualifier when added in footprint doing abduction *)
let cycle = get_var_retain_cycle (remove_opt original_prop) in
false, exn_retain_cycle cycle
| _ -> !Sil.curr_language = Sil.Java, exn_leak) in
let ignore_leak = !Config.allowleak || ignore_resource || is_undefined in
let report_and_continue = !Config.footprint in (* in footprint mode, report leak and continue *)
let already_reported () =
@ -1367,7 +1367,7 @@ let check_junk ?original_prop pname tenv prop =
else Prop.normalize (Prop.replace_sigma sigma_new (Prop.replace_sigma_footprint sigma_fp_new prop))
(** Check whether the prop contains junk.
If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *)
If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *)
let abstract_junk ?original_prop pname tenv prop =
Absarray.array_abstraction_performed := false;
check_junk ~original_prop: original_prop pname tenv prop
@ -1427,7 +1427,7 @@ let remove_local_stack sigma pvars =
list_filter filter_non_stack sigma
(** [prop_set_fooprint p p_foot] removes a local stack from [p_foot],
and sets proposition [p_foot] as footprint of [p]. *)
and sets proposition [p_foot] as footprint of [p]. *)
let set_footprint_for_abs (p : 'a Prop.t) (p_foot : 'a Prop.t) local_stack_pvars : Prop.exposed Prop.t =
let p_foot_pure = Prop.get_pure p_foot in
let p_foot_sigma = Prop.get_sigma p_foot in

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

@ -18,7 +18,7 @@ type sigma = Sil.hpred list
(** Matcher for the sigma part specialized to strexps *)
module StrexpMatch : sig
(** path through a strexp *)
(** path through a strexp *)
type path
(** convert a path into a list of expressions *)
@ -156,7 +156,7 @@ end = struct
let t = (fun (x,y,z) -> y) (list_find (fun (f', t, a) -> Sil.fld_equal f' f) ftal) in
find_offset_sexp sigma_other hpred root ((Field (f, typ)) :: offs) se t
with Not_found ->
L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find")
L.d_strln ("Can't find field " ^ (Ident.fieldname_to_string f) ^ " in StrexpMatch.find")
end;
find_offset_fsel sigma_other hpred root offs fsel' ftal typ
and find_offset_esel sigma_other hpred root offs esel t = match esel with
@ -247,20 +247,20 @@ end = struct
end
(** This function renames expressions in [p]. The renaming is, roughly
speaking, to replace [path.i] by [path.i'] for all (i, i') in [map]. *)
speaking, to replace [path.i] by [path.i'] for all (i, i') in [map]. *)
let prop_replace_path_index
(p: Prop.exposed Prop.t)
(path: StrexpMatch.path)
(map : (Sil.exp * Sil.exp) list) : Prop.exposed Prop.t
=
=
let elist_path = StrexpMatch.path_to_exps path in
let expmap_list =
list_fold_left (fun acc_outer e_path ->
list_fold_left (fun acc_inner (old_index, new_index) ->
let old_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, old_index)) in
let new_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, new_index)) in
(old_e_path_index, new_e_path_index) :: acc_inner
) acc_outer map
list_fold_left (fun acc_inner (old_index, new_index) ->
let old_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, old_index)) in
let new_e_path_index = Prop.exp_normalize_prop p (Sil.Lindex(e_path, new_index)) in
(old_e_path_index, new_e_path_index) :: acc_inner
) acc_outer map
) [] elist_path in
let expmap_fun e' =
try
@ -270,11 +270,11 @@ let prop_replace_path_index
Prop.prop_expmap expmap_fun p
(** This function uses [update] and transforms the two sigma parts of [p],
the sigma of the current SH of [p] and that of the footprint of [p]. *)
the sigma of the current SH of [p] and that of the footprint of [p]. *)
let prop_update_sigma_and_fp_sigma
(p : Prop.normal Prop.t)
(update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool
=
=
let sigma', changed = update false (Prop.get_sigma p) in
let ep1 = Prop.replace_sigma sigma' p in
let ep2, changed2 =
@ -285,13 +285,13 @@ let prop_update_sigma_and_fp_sigma
(Prop.normalize ep2, changed || changed2)
(** This function uses [update] and transforms the sigma of the
current SH of [p] or that of the footprint of [p], depending on
[footprint_part]. *)
current SH of [p] or that of the footprint of [p], depending on
[footprint_part]. *)
let prop_update_sigma_or_fp_sigma
(footprint_part : bool)
(p : Prop.normal Prop.t)
(update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool
=
=
let ep1, changed1 =
if footprint_part then (Prop.expose p, false)
else
@ -311,15 +311,15 @@ let prop_update_sigma_or_fp_sigma
let array_abstraction_performed = ref false
(** This function abstracts strexps. The parameter [can_abstract] spots strexps
where the abstraction might be applicable, and the parameter [do_abstract] does
the abstraction to those spotted strexps. *)
where the abstraction might be applicable, and the parameter [do_abstract] does
the abstraction to those spotted strexps. *)
let generic_strexp_abstract
(abstraction_name : string)
(p_in : Prop.normal Prop.t)
(_can_abstract : sigma -> StrexpMatch.strexp_data -> bool)
(do_abstract : bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool)
: Prop.normal Prop.t
=
: Prop.normal Prop.t
=
let can_abstract s data =
let r = _can_abstract s data in
if r then array_abstraction_performed := true;
@ -382,7 +382,7 @@ let blur_array_index
(p: Prop.normal Prop.t)
(path: StrexpMatch.path)
(index: Sil.exp) : Prop.normal Prop.t
=
=
try
let fresh_index = Sil.Var (Ident.create_fresh (if !Config.footprint then Ident.kfootprint else Ident.kprimed)) in
let p2 =
@ -415,7 +415,7 @@ let blur_array_indices
(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
(list_fold_left f p indices, list_length indices > 0)
@ -426,7 +426,7 @@ let keep_only_indices
(p: Prop.normal Prop.t)
(path: StrexpMatch.path)
(indices: Sil.exp list) : Prop.normal Prop.t * bool
=
=
let prune_sigma footprint_part sigma =
try
let matched = StrexpMatch.find_path sigma path in
@ -559,8 +559,8 @@ let check_after_array_abstraction prop =
else list_iter (fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) esel
| Sil.Estruct (fsel, _) ->
list_iter (fun (f, se) ->
let typ_f = Sil.struct_typ_fld (Some Sil.Tvoid) f typ in
check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in
let typ_f = Sil.struct_typ_fld (Some Sil.Tvoid) f typ in
check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in
let check_hpred = function
| Sil.Hpointsto (root, se, texp) ->
let typ = Sil.texp_to_typ (Some Sil.Tvoid) texp in
@ -593,7 +593,7 @@ let remove_redundant_elements prop =
let favl_foot = Sil.fav_to_list fav_foot in
Sil.fav_duplicates := false;
(* L.d_str "favl_curr "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_curr; L.d_ln();
L.d_str "favl_foot "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_foot; L.d_ln(); *)
L.d_str "favl_foot "; list_iter (fun id -> Sil.d_exp (Sil.Var id)) favl_foot; L.d_ln(); *)
let num_occur l id = list_length (list_filter (fun id' -> Ident.equal id id') l) in
let at_most_once v =
num_occur favl_curr v <= 1 && num_occur favl_foot v <= 1 in

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

@ -21,7 +21,7 @@ module IdMap = Map.Make (Ident) (** maps from identifiers *)
(** Constraint solving module *)
module Constraint : sig
(** Collect constraints on [vars] from [pi], and return a satisfying instantiation *)
(** Collect constraints on [vars] from [pi], and return a satisfying instantiation *)
val solve_from_pure : Sil.atom list -> Ident.t list -> Sil.Int.t IdMap.t
end = struct
(** flag for debug mode of the module *)
@ -162,9 +162,9 @@ end = struct
if !found = None then search_down ();
if !found = None then
(L.err "Constraint Error: empty range %a@." (pp_range id) rng;
rng.top <- Some Sil.Int.zero;
rng.bottom <- Some Sil.Int.zero;
rng.excluded <- [])
rng.top <- Some Sil.Int.zero;
rng.bottom <- Some Sil.Int.zero;
rng.excluded <- [])
(** return the solution if the id is solved (has unique solution) *)
let solved ev id =
@ -239,20 +239,20 @@ end = struct
add_excluded rng id n
| Sil.Var id1, Sil.Var id2 ->
(match solved ev id1, solved ev id2 with
| None, None -> ()
| Some _, Some _ -> ()
| Some n1, None ->
do_neq (Sil.exp_int n1) e2
| None, Some n2 ->
do_neq e1 (Sil.exp_int n2))
| None, None -> ()
| Some _, Some _ -> ()
| Some n1, None ->
do_neq (Sil.exp_int n1) e2
| None, Some n2 ->
do_neq e1 (Sil.exp_int n2))
| Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint n)) ->
(match solved ev id1, solved ev id2 with
| None, None -> ()
| Some _, Some _ -> ()
| Some n1, None ->
do_neq (Sil.exp_int (n1 -- n)) (Sil.Var id2)
| None, Some n2 ->
do_neq (Sil.Var id1) (Sil.exp_int (n2 ++ n)))
| None, None -> ()
| Some _, Some _ -> ()
| Some n1, None ->
do_neq (Sil.exp_int (n1 -- n)) (Sil.Var id2)
| None, Some n2 ->
do_neq (Sil.Var id1) (Sil.exp_int (n2 ++ n)))
| _ -> if debug then assert false in
let do_ident id =
if debug then F.fprintf F.std_formatter "constraints before doing %a:@.%a@." (Ident.pp pe_text) id pp_eval ev;
@ -442,9 +442,9 @@ let gen_sigma code proc_name spec_num env idmap sigma =
list_iter (fun (f, se) -> do_strexp code' (base ^ accessor ^ Ident.fieldname_to_string f) false se) fsel
| Sil.Earray (size, esel, _) ->
list_iter (fun (e, se) ->
let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in
let index = pp_to_string pp () in
do_strexp code' (base ^ "[" ^ index ^ "]") false se) esel in
let pp f () = F.fprintf f "%a" (pp_exp_c pe) e in
let index = pp_to_string pp () in
do_strexp code' (base ^ "[" ^ index ^ "]") false se) esel in
let gen_hpred = function
| Sil.Hpointsto (Sil.Lvar pvar, se, _) ->

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

@ -17,7 +17,7 @@ open Utils
let verbose = Config.trace_error
(** check if the error was reported inside a nested loop
the implementation is approximate: check if the last two visits to a loop were entering loops *)
the implementation is approximate: check if the last two visits to a loop were entering loops *)
let check_nested_loop path pos_opt =
let trace_length = ref 0 in
let loop_visits_log = ref [] in
@ -28,7 +28,7 @@ let check_nested_loop path pos_opt =
| _ -> false in
let do_node_caller node = match Cfg.Node.get_kind node with
| Cfg.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _) ->
(* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *)
(* if !verbose then L.d_strln ((if b then "enter" else "exit") ^ " node " ^ (string_of_int (Cfg.Node.get_id node))); *)
loop_visits_log := b :: !loop_visits_log
| _ -> () in
let do_any_node level node =
@ -44,7 +44,7 @@ let check_nested_loop path pos_opt =
in_nested_loop ()
(** Check that we know where the value was last assigned,
and that there is a local access instruction at that line. **)
and that there is a local access instruction at that line. **)
let check_access access_opt de_opt =
let find_bucket line_number null_case_flag =
let find_formal_ids node = (* find ids obtained by a letref on a formal parameter *)

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

@ -29,24 +29,24 @@ let inline_synthetic_method ret_ids etl proc_desc proc_name loc_call : Sil.instr
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], []
when Sil.pvar_is_global pvar -> (* getter for static fields *)
when Sil.pvar_is_global pvar -> (* getter for static fields *)
let instr' = Sil.Letderef (ret_id, Sil.Lfield (Sil.Lvar pvar, fn, ft), bt, loc_call) in
found instr instr'
| Sil.Set (Sil.Lfield (ex1, fn, ft), bt , ex2, loc), _, [(e1, t1); (e2, t2)] -> (* 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)]
when Sil.pvar_is_global pvar -> (* setter for static fields *)
when Sil.pvar_is_global pvar -> (* setter for static fields *)
let instr' = Sil.Set (Sil.Lfield (Sil.Lvar pvar, fn, ft), bt , e1, loc_call) in
found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
when list_length ret_ids = list_length ret_ids'
&& list_length etl' = list_length etl ->
when list_length ret_ids = list_length ret_ids'
&& list_length etl' = list_length etl ->
let instr' = Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc_call, cf) in
found instr instr'
| Sil.Call (ret_ids', Sil.Const (Sil.Cfun pn), etl', loc', cf), _, _
when list_length ret_ids = list_length ret_ids'
&& list_length etl' + 1 = list_length etl ->
when list_length ret_ids = list_length ret_ids'
&& list_length etl' + 1 = list_length etl ->
let etl1 = match list_rev etl with (* remove last element *)
| _ :: l -> list_rev l
| [] -> assert false in
@ -61,15 +61,15 @@ let proc_inline_synthetic_methods cfg proc_desc : unit =
let instr_inline_synthetic_method = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), etl, loc, _) ->
(match Cfg.Procdesc.find_from_name cfg pn with
| Some pd ->
let is_access = Procname.java_is_access_method pn in
let attributes = Cfg.Procdesc.get_attributes pd in
let is_synthetic = attributes.Sil.is_synthetic_method in
let is_bridge = attributes.Sil.is_bridge_method in
if is_access || is_bridge || is_synthetic
then inline_synthetic_method ret_ids etl pd pn loc
else None
| None -> None)
| Some pd ->
let is_access = Procname.java_is_access_method pn in
let attributes = Cfg.Procdesc.get_attributes pd in
let is_synthetic = attributes.Sil.is_synthetic_method in
let is_bridge = attributes.Sil.is_bridge_method in
if is_access || is_bridge || is_synthetic
then inline_synthetic_method ret_ids etl pd pn loc
else None
| None -> None)
| _ -> None in
let node_inline_synthetic_methods node =
let modified = ref false in
@ -119,10 +119,10 @@ let get_procedure_definition exe_env proc_name =
let tenv = Exe_env.get_tenv exe_env proc_name in
Option.map
(fun proc_desc ->
proc_inline_synthetic_methods cfg proc_desc;
let idenv = Idenv.create cfg proc_desc
and language = (Cfg.Procdesc.get_attributes proc_desc).Sil.language in
(idenv, tenv, proc_name, proc_desc, language))
proc_inline_synthetic_methods cfg proc_desc;
let idenv = Idenv.create cfg proc_desc
and language = (Cfg.Procdesc.get_attributes proc_desc).Sil.language in
(idenv, tenv, proc_name, proc_desc, language))
(Cfg.Procdesc.find_from_name cfg proc_name)
let get_language proc_name = if Procname.is_java proc_name then Sil.Java else Sil.C_CPP
@ -146,19 +146,19 @@ let iterate_procedure_callbacks all_procs exe_env proc_name =
Option.may
(fun (idenv, tenv, proc_name, proc_desc, language) ->
list_iter
(fun (language_opt, proc_callback) ->
let language_matches = match language_opt with
| Some language -> language = procedure_language
| None -> true in
if language_matches then
begin
let init_time = Unix.gettimeofday () in
proc_callback all_procs get_procdesc idenv tenv proc_name proc_desc;
let elapsed = Unix.gettimeofday () -. init_time in
update_time proc_name elapsed
end)
!procedure_callbacks)
list_iter
(fun (language_opt, proc_callback) ->
let language_matches = match language_opt with
| Some language -> language = procedure_language
| None -> true in
if language_matches then
begin
let init_time = Unix.gettimeofday () in
proc_callback all_procs get_procdesc idenv tenv proc_name proc_desc;
let elapsed = Unix.gettimeofday () -. init_time in
update_time proc_name elapsed
end)
!procedure_callbacks)
(get_procedure_definition exe_env proc_name)
(** Invoke all registered cluster callbacks on a cluster of procedures. *)
@ -187,9 +187,9 @@ let iterate_cluster_callbacks all_procs exe_env proc_names =
list_iter
(fun (language_opt, cluster_callback) ->
let proc_names = relevant_procedures language_opt in
if list_length proc_names > 0 then
cluster_callback all_procs get_procdesc environment)
let proc_names = relevant_procedures language_opt in
if list_length proc_names > 0 then
cluster_callback all_procs get_procdesc environment)
!cluster_callbacks
(** Invoke all procedure and cluster callbacks on a given environment. *)
@ -205,9 +205,9 @@ let iterate_callbacks store_summary call_graph exe_env =
let cluster_map =
list_fold_left
(fun map proc_name ->
let proc_cluster = cluster_id proc_name in
let bucket = try StringMap.find proc_cluster map with Not_found -> [] in
StringMap.add proc_cluster (proc_name:: bucket) map)
let proc_cluster = cluster_id proc_name in
let bucket = try StringMap.find proc_cluster map with Not_found -> [] in
StringMap.add proc_cluster (proc_name:: bucket) map)
StringMap.empty
proc_names in
(* Return all values of the map *)

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

@ -249,7 +249,7 @@ module Node = struct
| Join_node, _ -> -1
| _, Join_node -> 1
| Prune_node (is_true_branch1, if_kind1, descr1),
Prune_node (is_true_branch2, if_kind2, descr2) ->
Prune_node (is_true_branch2, if_kind2, descr2) ->
let n = bool_compare is_true_branch1 is_true_branch2 in
if n <> 0 then n else let n = Pervasives.compare if_kind1 if_kind2 in
if n <> 0 then n else string_compare descr1 descr2
@ -373,11 +373,11 @@ module Node = struct
let proc_desc_remove cfg name remove_nodes =
(if remove_nodes then
let pdesc = pdesc_tbl_find cfg name in
let proc_nodes =
list_fold_right (fun node set -> NodeSet.add node set)
pdesc.pd_nodes NodeSet.empty in
remove_node_set cfg proc_nodes);
let pdesc = pdesc_tbl_find cfg name in
let proc_nodes =
list_fold_right (fun node set -> NodeSet.add node set)
pdesc.pd_nodes NodeSet.empty in
remove_node_set cfg proc_nodes);
pdesc_tbl_remove cfg name
let proc_desc_get_start_node proc_desc =
@ -546,27 +546,27 @@ module Node = struct
let proc_desc_iter_slope f proc_desc =
let visited = ref NodeSet.empty in
let rec do_node node = begin
visited := NodeSet.add node !visited;
f node;
match get_succs node with
| [n] -> if not (NodeSet.mem n !visited) then do_node n
| _ -> ()
end in
visited := NodeSet.add node !visited;
f node;
match get_succs node with
| [n] -> if not (NodeSet.mem n !visited) then do_node n
| _ -> ()
end in
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 visited = ref NodeSet.empty in
let rec do_node node = begin
visited := NodeSet.add node !visited;
f node;
match get_succs node with
| [n] ->
if not (NodeSet.mem n !visited)
&& not (equal node dst_node)
then do_node n
| _ -> ()
end in
visited := NodeSet.add node !visited;
f node;
match get_succs node with
| [n] ->
if not (NodeSet.mem n !visited)
&& not (equal node dst_node)
then do_node n
| _ -> ()
end in
do_node src_node
let proc_desc_iter_slope_calls f proc_desc =
@ -611,7 +611,7 @@ let save_source_files cfg =
Node.proc_desc_is_defined pdesc &&
Sys.file_exists source_file_str &&
(not (Sys.file_exists dest_file_str) ||
DB.file_modified_time (DB.filename_from_string source_file_str) > DB.file_modified_time dest_file) in
DB.file_modified_time (DB.filename_from_string source_file_str) > DB.file_modified_time dest_file) in
if needs_copy then
match Utils.copy_file source_file_str dest_file_str with
| Some _ -> ()
@ -727,8 +727,8 @@ let get_defined_procs cfg =
(** Get the objc procedures whose body is generated *)
let get_objc_generated_procs cfg =
list_filter (
fun procdesc ->
(Procdesc.get_attributes procdesc).Sil.is_generated) (get_all_procs cfg)
fun procdesc ->
(Procdesc.get_attributes procdesc).Sil.is_generated) (get_all_procs cfg)
(** get the function names which should be analyzed before the other ones *)
let get_priority_procnames cfg =
@ -849,12 +849,12 @@ let remove_abducted_retvars p =
let abducted_pvars, normal_pvars =
list_fold_left
(fun pvars hpred ->
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, _, _) ->
let abducted_pvars, normal_pvars = pvars in
if Sil.pvar_is_abducted pvar then pvar :: abducted_pvars, normal_pvars
else abducted_pvars, pvar :: normal_pvars
| _ -> pvars)
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, _, _) ->
let abducted_pvars, normal_pvars = pvars in
if Sil.pvar_is_abducted pvar then pvar :: abducted_pvars, normal_pvars
else abducted_pvars, pvar :: normal_pvars
| _ -> pvars)
([], [])
(Prop.get_sigma p) in
let _, p' = Prop.deallocate_stack_vars p abducted_pvars in
@ -894,7 +894,7 @@ let remove_locals_ret (curr_f : Procdesc.t) p =
snd (remove_locals curr_f (remove_ret curr_f p))
(** Remove locals and formal parameters from the prop.
Return the list of stack variables whose address was still present after deallocation. *)
Return the list of stack variables whose address was still present after deallocation. *)
let remove_locals_formals (curr_f : Procdesc.t) p =
let pvars1, p1 = remove_formals curr_f p in
let pvars2, p2 = remove_locals curr_f p1 in
@ -924,11 +924,11 @@ let check_cfg_connectedness cfg =
| Node.Stmt_node _ | Node.Prune_node _
| Node.Skip_node _ -> (list_length succs = 0) || (list_length preds = 0)
| Node.Join_node ->
(* Join node has the exception that it may be without predecessors and pointing to an exit node *)
(* if the if brances end with a return *)
(* Join node has the exception that it may be without predecessors and pointing to an exit node *)
(* if the if brances end with a return *)
(match succs with
| [n'] when is_exit_node n' -> false
| _ -> (list_length preds = 0)) in
| [n'] when is_exit_node n' -> false
| _ -> (list_length preds = 0)) in
let do_pdesc pd =
let pname = Procname.to_string (Procdesc.get_proc_name pd) in
let nodes = Procdesc.get_nodes pd in

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

@ -53,15 +53,15 @@ let _add_node g n defined =
let info = Procname.Hash.find g.node_map n in
if defined then info.defined <- true
with Not_found ->
let info =
{ defined = defined;
parents = Procname.Set.empty;
children = Procname.Set.empty;
ancestors = None;
heirs = None;
recursive_dependents = None;
in_out_calls = None } in
Procname.Hash.add g.node_map n info
let info =
{ defined = defined;
parents = Procname.Set.empty;
children = Procname.Set.empty;
ancestors = None;
heirs = None;
recursive_dependents = None;
in_out_calls = None } in
Procname.Hash.add g.node_map n info
let add_node g n =
_add_node g n true

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

@ -56,10 +56,10 @@ let find_comment_start_and_style lines_arr n =
let is_start line = match cur_line_comment with
| Some (Line (s)) -> if string_is_prefix s line then None else Some (Line (s))
| _ -> try
Some (list_find (function
| Block(s, _, _) -> string_contains s line
| _ -> false) comment_styles)
with Not_found -> None in
Some (list_find (function
| Block(s, _, _) -> string_contains s line
| _ -> false) comment_styles)
with Not_found -> None in
let i = ref (n - 1) in
(* hacky fake line comment to avoid an option type *)
let found = ref (-1, Line(">>>>>>>>>>>")) in

64
infer/src/backend/config.ml
Unescape View File

@ -113,31 +113,31 @@ let project_root : string option ref = ref None
(** FLAGS AND GLOBAL VARIABLES *)
(** Flag for abstracting fields of structs
0 = no
1 = forget some fields during matching (and so lseg abstraction) *)
0 = no
1 = forget some fields during matching (and so lseg abstraction) *)
let abs_struct = ref 1
(** Flag for abstracting numerical values
0 = no abstraction.
1 = evaluate all expressions abstractly.
2 = 1 + abstract constant integer values during join.
0 = no abstraction.
1 = evaluate all expressions abstractly.
2 = 1 + abstract constant integer values during join.
*)
let abs_val = ref 2
(** if true, completely ignore the possibility that errors can be caused by unknown procedures
* during the symbolic execution phase *)
* during the symbolic execution phase *)
let angelic_execution = ref true
(** Flag for forgetting memory leak
false = no
true = forget leaked memory cells during abstraction
false = no
true = forget leaked memory cells during abstraction
*)
let allowleak = ref false
(** Flag for ignoring arrays and pointer arithmetic.
0 = treats both features soundly.
1 = assumes that the size of every array is infinite.
2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct.
0 = treats both features soundly.
1 = assumes that the size of every array is infinite.
2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct.
*)
let array_level = ref 0
@ -186,14 +186,14 @@ let intraprocedural = ref false
let join_plus = ref true
(** Flag to tune the final information-loss check used by the join
0 = use the most aggressive join for preconditions
1 = use the least aggressive join for preconditions
0 = use the most aggressive join for preconditions
1 = use the least aggressive join for preconditions
*)
let join_cond = ref 1
(** Flag for turning on the transformation that
null is assigned to a program variable when it becomes dead.
**)
null is assigned to a program variable when it becomes dead.
**)
let liveness = ref true
(** if true, give static procs a long name filename::procname *)
@ -212,9 +212,9 @@ let max_num_proc = ref 0
let max_recursion = ref 5
(** Flag to tune the level of applying the meet operator for
preconditions during the footprint analysis.
0 = do not use the meet.
1 = use the meet to generate new preconditions.
preconditions during the footprint analysis.
0 = do not use the meet.
1 = use the meet to generate new preconditions.
*)
let meet_level = ref 1
@ -258,9 +258,9 @@ let results_dir = ref default_results_dir
let slice_fun = ref ""
(** Flag to tune the level of abstracting the postconditions of specs discovered
by the footprint analysis.
0 = nothing special.
1 = filter out redundant posts implied by other posts. *)
by the footprint analysis.
0 = nothing special.
1 = filter out redundant posts implied by other posts. *)
let spec_abs_level = ref 1
(** Flag for test mode *)
@ -294,15 +294,15 @@ let taint_analysis = ref false
let trace_anal = ref false
(** Flag for turning on the optimization based on locality
0 = no
1 = based on reachability
0 = no
1 = based on reachability
*)
let undo_join = ref true
(** visit mode for the worklist:
0 depth - fist visit
1 bias towards exit node
2 least visited first *)
0 depth - fist visit
1 bias towards exit node
2 least visited first *)
let worklist_mode = ref 0
(** flag: if true write dot files in db dir*)
@ -328,16 +328,16 @@ let show_ml_buckets = ref false
let dotty_cfg_libs = ref true
(** if true, it deals with messages (method calls) in objective-c using the objective-c
typical semantics. That is: if the receiver is nil then the method is nop and it returns 0.
When the flag is false we deal with messages as standard method / function calls *)
typical semantics. That is: if the receiver is nil then the method is nop and it returns 0.
When the flag is false we deal with messages as standard method / function calls *)
let objc_method_call_semantics = ref true
(** if true, generate preconditions for runtime exceptions in Java and report errors for the public
methods having preconditions to throw runtime exceptions *)
methods having preconditions to throw runtime exceptions *)
let report_runtime_exceptions = ref false
(** if true, sanity-check inferred preconditions against Nullable annotations and report
inconsistencies *)
inconsistencies *)
let report_nullable_inconsistency = ref true
(** true if the current objective-c source file is compiled with automatic reference counting (ARC) *)
@ -356,11 +356,11 @@ module Experiment = struct
let activate_subtyping_in_cpp = ref false
(** if true, a precondition with e.g. index 3 in an array does not require the caller to have index 3 too
this mimics what happens with direct access to the array without a procedure call, where the index is simply materialized if not there *)
this mimics what happens with direct access to the array without a procedure call, where the index is simply materialized if not there *)
let allow_missing_index_in_proc_call = ref true
(** if true, a procedure call succeeds even when there is a bound error
this mimics what happens with a direct array access where an error is produced and the analysis continues *)
this mimics what happens with a direct array access where an error is produced and the analysis continues *)
let bound_error_allowed_in_procedure_call = ref true
end

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

@ -85,13 +85,13 @@ let do_side side f e1 e2 =
(** {2 Sets for expression pairs} *)
module EPset = Set.Make
(struct
type t = Sil.exp * Sil.exp
let compare (e1, e1') (e2, e2') =
match (Sil.exp_compare e1 e2) with
| i when i <> 0 -> i
| _ -> Sil.exp_compare e1' e2'
end)
(struct
type t = Sil.exp * Sil.exp
let compare (e1, e1') (e2, e2') =
match (Sil.exp_compare e1 e2) with
| i when i <> 0 -> i
| _ -> Sil.exp_compare e1' e2'
end)
let epset_add e e' set =
match (Sil.exp_compare e e') with
@ -479,16 +479,16 @@ end = struct
let (_, _, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e1 e1' && Sil.exp_equal e2 e2') !t in
e
with Not_found ->
let e = Sil.exp_get_undefined (JoinState.get_footprint ()) in
t := (e1, e2, e)::!t;
e
let e = Sil.exp_get_undefined (JoinState.get_footprint ()) in
t := (e1, e2, e)::!t;
e
let lookup side e =
try
let (e1, e2, e) = list_find (fun (e1', e2', _) -> Sil.exp_equal e (select side e1' e2')) !t in
Some (e, select (opposite side) e1 e2)
with Not_found ->
None
None
let get_induced_atom acc strict_lower upper e =
let ineq_lower = Prop.mk_inequality (Sil.BinOp(Sil.Lt, strict_lower, e)) in
@ -516,8 +516,8 @@ end = struct
let eqs_acc' = eq:: eqs_acc in
f_eqs_entry entry eqs_acc' t_seen t_rest'
with Not_found ->
let t_seen' = entry':: t_seen in
f_eqs_entry entry eqs_acc t_seen' t_rest' in
let t_seen' = entry':: t_seen in
f_eqs_entry entry eqs_acc t_seen' t_rest' in
let rec f_eqs eqs_acc t_acc = function
| [] -> (eqs_acc, t_acc)
| entry:: t_rest ->
@ -610,12 +610,12 @@ end = struct
let res = ref [] in
let f v = match v, side with
| (Sil.BinOp (Sil.PlusA, e1', Sil.Const (Sil.Cint i)), e2, e'), Lhs
when Sil.exp_equal e e1' ->
when Sil.exp_equal e e1' ->
let c' = Sil.exp_int (Sil.Int.neg i) in
let v' = (e1', Sil.BinOp(Sil.PlusA, e2, c'), Sil.BinOp (Sil.PlusA, e', c')) in
res := v'::!res
| (e1, Sil.BinOp (Sil.PlusA, e2', Sil.Const (Sil.Cint i)), e'), Rhs
when Sil.exp_equal e e2' ->
when Sil.exp_equal e e2' ->
let c' = Sil.exp_int (Sil.Int.neg i) in
let v' = (Sil.BinOp(Sil.PlusA, e1, c'), e2', Sil.BinOp (Sil.PlusA, e', c')) in
res := v'::!res
@ -705,11 +705,11 @@ end = struct
let others = get_others_direct_or_induced side e in
let others' = get_others_direct_or_induced side e' in
(match others, others' with
| None, _ | _, None -> None
| Some (e_res, e_op), Some(e_res', e_op') ->
let e_res'' = Sil.BinOp(op, e_res, e_res') in
let e_op'' = Sil.BinOp(op, e_op, e_op') in
Some (e_res'', e_op''))
| None, _ | _, None -> None
| Some (e_res, e_op), Some(e_res', e_op') ->
let e_res'' = Sil.BinOp(op, e_res, e_res') in
let e_op'' = Sil.BinOp(op, e_op, e_op') in
Some (e_res'', e_op''))
| _ -> None
let get_other_atoms side atom_in =
@ -739,22 +739,22 @@ end = struct
begin
match atom_in with
| Sil.Aneq((Sil.Var id as e), e') | Sil.Aneq(e', (Sil.Var id as e))
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
build_other_atoms (fun e0 -> Prop.mk_neq e0 e') side e
| Sil.Aeq((Sil.Var id as e), e') | Sil.Aeq(e', (Sil.Var id as e))
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
build_other_atoms (fun e0 -> Prop.mk_eq e0 e') side e
| Sil.Aeq(Sil.BinOp(Sil.Le, e, e'), Sil.Const (Sil.Cint i))
| Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Le, e, e'))
when Sil.Int.isone i && (exp_contains_only_normal_ids e') ->
when Sil.Int.isone i && (exp_contains_only_normal_ids e') ->
let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Le, e0, e')) in
build_other_atoms construct side e
| Sil.Aeq(Sil.BinOp(Sil.Lt, e', e), Sil.Const (Sil.Cint i))
| Sil.Aeq(Sil.Const (Sil.Cint i), Sil.BinOp(Sil.Lt, e', e))
when Sil.Int.isone i && (exp_contains_only_normal_ids e') ->
when Sil.Int.isone i && (exp_contains_only_normal_ids e') ->
let construct e0 = Prop.mk_inequality (Sil.BinOp(Sil.Lt, e', e0)) in
build_other_atoms construct side e
@ -764,31 +764,31 @@ end = struct
type data_opt = ExtFresh | ExtDefault of Sil.exp
(* Extend the renaming relation. At least one of e1 and e2
* should be a primed or footprint variable *)
* should be a primed or footprint variable *)
let extend e1 e2 default_op =
try
let eq_to_e (f1, f2, _) = Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2 in
let _, _, res = list_find eq_to_e !tbl in
res
with Not_found ->
let fav1 = Sil.exp_fav e1 in
let fav2 = Sil.exp_fav e2 in
let no_ren1 = not (Sil.fav_exists fav1 can_rename) in
let no_ren2 = not (Sil.fav_exists fav2 can_rename) in
let some_primed () = Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in
let e =
if (no_ren1 && no_ren2) then
if (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise Fail)
else
match default_op with
| ExtDefault e -> e
| ExtFresh ->
let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in
Sil.Var (Ident.create_fresh kind) in
let entry = e1, e2, e in
push entry;
Todo.push entry;
e
let fav1 = Sil.exp_fav e1 in
let fav2 = Sil.exp_fav e2 in
let no_ren1 = not (Sil.fav_exists fav1 can_rename) in
let no_ren2 = not (Sil.fav_exists fav2 can_rename) in
let some_primed () = Sil.fav_exists fav1 Ident.is_primed || Sil.fav_exists fav2 Ident.is_primed in
let e =
if (no_ren1 && no_ren2) then
if (Sil.exp_equal e1 e2) then e1 else (L.d_strln "failure reason 13"; raise Fail)
else
match default_op with
| ExtDefault e -> e
| ExtFresh ->
let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in
Sil.Var (Ident.create_fresh kind) in
let entry = e1, e2, e in
push entry;
Todo.push entry;
e
let pp pe f renaming =
let pp_triple f (e1, e2, e3) =
@ -928,15 +928,15 @@ let rec exp_partial_join (e1: Sil.exp) (e2: Sil.exp) : Sil.exp =
| Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const _), Sil.Var id2
| Sil.Var id1, Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const _)
when ident_same_kind_primed_footprint id1 id2 ->
when ident_same_kind_primed_footprint id1 id2 ->
Rename.extend e1 e2 Rename.ExtFresh
| Sil.BinOp(Sil.PlusA, Sil.Var id1, Sil.Const (Sil.Cint c1)), Sil.Const (Sil.Cint c2)
when can_rename id1 ->
when can_rename id1 ->
let c2' = c2 -- c1 in
let e_res = Rename.extend (Sil.Var id1) (Sil.exp_int c2') Rename.ExtFresh in
Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c1)
| Sil.Const (Sil.Cint c1), Sil.BinOp(Sil.PlusA, Sil.Var id2, Sil.Const (Sil.Cint c2))
when can_rename id2 ->
when can_rename id2 ->
let c1' = c1 -- c2 in
let e_res = Rename.extend (Sil.exp_int c1') (Sil.Var id2) Rename.ExtFresh in
Sil.BinOp(Sil.PlusA, e_res, Sil.exp_int c2)
@ -1062,10 +1062,10 @@ let run_without_absval f e1 e2 =
e
end
with exn ->
begin
Config.abs_val := old_abs_val;
raise exn
end
begin
Config.abs_val := old_abs_val;
raise exn
end
let exp_partial_join_without_absval e1 e2 =
run_without_absval exp_partial_join e1 e2
@ -1187,7 +1187,7 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st
let inst = Sil.inst_partial_meet inst1 inst2 in
f_fld_se_list inst [] fld_se_list1 fld_se_list2
| Sil.Earray (size1, idx_se_list1, inst1), Sil.Earray (size2, idx_se_list2, inst2)
when Sil.exp_equal size1 size2 ->
when Sil.exp_equal size1 size2 ->
let inst = Sil.inst_partial_meet inst1 inst2 in
f_idx_se_list inst size1 [] idx_se_list1 idx_se_list2
| _ -> (L.d_strln "failure reason 52"; raise Fail)
@ -1250,7 +1250,7 @@ let hpred_partial_join mode (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpr
let shared' = exp_list_partial_join shared1 shared2 in
Prop.mk_lseg (kind_join k1 k2) hpara' e next' shared'
| Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1),
Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ->
Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ->
let fwd1 = Sil.exp_equal e1 iF1 in
let fwd2 = Sil.exp_equal e2 iF2 in
let hpara' = hpara_dll_partial_join para1 para2 in
@ -1278,7 +1278,7 @@ let hpred_partial_meet (todo: Sil.exp * Sil.exp * Sil.exp) (hpred1: Sil.hpred) (
let shared' = exp_list_partial_meet shared1 shared2 in
Prop.mk_lseg (kind_meet k1 k2) hpara' e next' shared'
| Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1),
Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ->
Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ->
let fwd1 = Sil.exp_equal e1 iF1 in
let fwd2 = Sil.exp_equal e2 iF2 in
let hpara' = hpara_dll_partial_meet para1 para2 in
@ -1321,11 +1321,11 @@ let same_pred (hpred1: Sil.hpred) (hpred2: Sil.hpred) : bool =
| _ -> false
(* check that applying renaming to the lhs / rhs of [sigma_new]
* gives [sigma] and that the renaming is injective *)
* gives [sigma] and that the renaming is injective *)
let sigma_renaming_check (lhs: side) (sigma: sigma) (sigma_new: sigma) =
(* apply the lhs / rhs of the renaming to sigma,
* and check that the renaming of primed vars is injective *)
* and check that the renaming of primed vars is injective *)
let fav_sigma = Prop.sigma_fav sigma_new in
let sub = Rename.to_subst_proj lhs fav_sigma in
let sigma' = Prop.sigma_sub sub sigma_new in
@ -1352,7 +1352,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared')
| Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared)
when Sil.exp_equal iF e ->
when Sil.exp_equal iF e ->
let oF' = do_side side exp_partial_join oF opposite in
let shared' = Rename.lookup_list side shared in
let oB', iB' = lookup_and_expand side oB iB in
@ -1365,7 +1365,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared')
| Sil.Hdllseg (k, hpara, iF, oB, oF, iB, shared)
when Sil.exp_equal iB e ->
when Sil.exp_equal iB e ->
let oB' = do_side side exp_partial_join oB opposite in
let shared' = Rename.lookup_list side shared in
let oF', iF' = lookup_and_expand side oF iF in
@ -1397,8 +1397,8 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
| _ -> assert false in
(* Drop the part of 'other' sigma corresponding to 'target' sigma if possible.
'side' describes that target is Lhs or Rhs.
'todo' describes the start point. *)
'side' describes that target is Lhs or Rhs.
'todo' describes the start point. *)
let cut_sigma side todo (target: sigma) (other: sigma) =
let list_is_empty l = if l != [] then (L.d_strln "failure reason 61"; raise Fail) in
@ -1482,7 +1482,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
sigma_partial_join' mode sigma_acc' sigma1' sigma2
| Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some (hpred2)
when Sil.exp_equal e1 iF1 ->
when Sil.exp_equal e1 iF1 ->
let iB_res = exp_partial_join iB1 e2 in
let sigma2' = cut_dllseg Lhs todo_curr iF1 dllseg (hpred2:: sigma2) in
let sigma_acc' = update_dllseg Lhs dllseg e iB_res :: sigma_acc in
@ -1498,7 +1498,7 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
sigma_partial_join' mode sigma_acc' sigma1 sigma2'
| Some (hpred1), Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg)
when Sil.exp_equal e2 iF2 ->
when Sil.exp_equal e2 iF2 ->
let iB_res = exp_partial_join e1 iB2 in
let sigma1' = cut_dllseg Rhs todo_curr iF2 dllseg (hpred1:: sigma1) in
let sigma_acc' = update_dllseg Rhs dllseg e iB_res :: sigma_acc in
@ -1516,9 +1516,9 @@ let rec sigma_partial_join' mode (sigma_acc: sigma)
assert false (* Should be handled by a guarded case *)
with Todo.Empty ->
match sigma1_in, sigma2_in with
| _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
| _ -> sigma_acc, sigma1_in, sigma2_in
match sigma1_in, sigma2_in with
| _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
| _ -> sigma_acc, sigma1_in, sigma2_in
let sigma_partial_join mode (sigma1: sigma) (sigma2: sigma) : (sigma * sigma * sigma) =
CheckJoin.init mode sigma1 sigma2;
@ -1568,9 +1568,9 @@ let rec sigma_partial_meet' (sigma_acc: sigma) (sigma1_in: sigma) (sigma2_in: si
(L.d_strln "failure reason 65"; raise Fail)
with Todo.Empty ->
match sigma1_in, sigma2_in with
| [], [] -> sigma_acc
| _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
match sigma1_in, sigma2_in with
| [], [] -> sigma_acc
| _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise Fail
let sigma_partial_meet (sigma1: sigma) (sigma2: sigma) : sigma =
sigma_partial_meet' [] sigma1 sigma2
@ -1582,7 +1582,7 @@ let widening_bottom = Sil.Int.of_int64 Int64.min_int ++ Sil.Int.of_int 1000 (* n
let pi_partial_join mode
(ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t)
(pi1: Sil.atom list) (pi2: Sil.atom list) : Sil.atom list
=
=
let exp_is_const = function
(* | Sil.Var id -> is_normal id *)
| Sil.Const _ -> true
@ -1668,19 +1668,19 @@ let pi_partial_join mode
match join_atom size p_op pi_op a with
| None ->
(match widening_atom a with
| None -> atom_list
| Some a' ->
(match join_atom size p_op pi_op a' with
| None -> atom_list
| Some a' -> a' :: atom_list))
| None -> atom_list
| Some a' ->
(match join_atom size p_op pi_op a' with
| None -> atom_list
| Some a' -> a' :: atom_list))
| Some a' -> a' :: atom_list in
let filter_atom = function
| Sil.Aneq(e, e') | Sil.Aeq(e, e')
when (exp_is_const e && exp_is_const e') ->
when (exp_is_const e && exp_is_const e') ->
true
| Sil.Aneq(Sil.Var id, e') | Sil.Aneq(e', Sil.Var id)
| Sil.Aeq(Sil.Var id, e') | Sil.Aeq(e', Sil.Var id)
when (exp_is_const e') ->
when (exp_is_const e') ->
true
| Sil.Aneq _ -> false
| e -> Prop.atom_is_inequality e in
@ -1769,12 +1769,12 @@ let prop_partial_meet p1 p2 =
Rename.final (); FreshVarExp.final (); Todo.final ();
Some res
with exn ->
begin
Rename.final (); FreshVarExp.final (); Todo.final ();
match exn with
| Fail -> None
| _ -> raise exn
end
begin
Rename.final (); FreshVarExp.final (); Todo.final ();
match exn with
| Fail -> None
| _ -> raise exn
end
let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t =
SymOp.pay(); (* pay one symop *)
@ -1872,11 +1872,11 @@ let prop_partial_join pname tenv mode p1 p2 =
Rename.final (); FreshVarExp.final (); Todo.final ();
res
with exn ->
begin
Rename.final (); FreshVarExp.final (); Todo.final ();
(if !Config.footprint then JoinState.set_footprint false);
(match exn with Fail -> None | _ -> raise exn)
end
begin
Rename.final (); FreshVarExp.final (); Todo.final ();
(if !Config.footprint then JoinState.set_footprint false);
(match exn with Fail -> None | _ -> raise exn)
end
end
| Some _ -> res_by_implication_only
@ -1894,19 +1894,19 @@ let list_reduce name dd f list =
let rec element_list_reduce acc (x, p1) = function
| [] -> ((x, p1), list_rev acc)
| (y, p2):: ys -> begin
L.d_strln ("COMBINE[" ^ name ^ "] ....");
L.d_str "ENTRY1: "; L.d_ln (); dd x; L.d_ln ();
L.d_str "ENTRY2: "; L.d_ln (); dd y; L.d_ln ();
L.d_ln ();
match f x y with
| None ->
L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ...");
element_list_reduce ((y, p2):: acc) (x, p1) ys
| Some x' ->
L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ....");
L.d_strln "RESULT:"; dd x'; L.d_ln ();
element_list_reduce acc (x', p1) ys
end in
L.d_strln ("COMBINE[" ^ name ^ "] ....");
L.d_str "ENTRY1: "; L.d_ln (); dd x; L.d_ln ();
L.d_str "ENTRY2: "; L.d_ln (); dd y; L.d_ln ();
L.d_ln ();
match f x y with
| None ->
L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ...");
element_list_reduce ((y, p2):: acc) (x, p1) ys
| Some x' ->
L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ....");
L.d_strln "RESULT:"; dd x'; L.d_ln ();
element_list_reduce acc (x', p1) ys
end in
let rec reduce acc = function
| [] -> list_rev acc
| x:: xs ->
@ -1966,7 +1966,7 @@ let join_time = ref 0.0
let pathset_join
pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t)
: Paths.PathSet.t * Paths.PathSet.t =
: Paths.PathSet.t * Paths.PathSet.t =
let mode = JoinState.Post in
let initial_time = Unix.gettimeofday () in
let pset_to_plist pset =
@ -1977,18 +1977,18 @@ let pathset_join
let rec join_proppath_plist ppalist2_acc ((p2, pa2) as ppa2) = function
| [] -> (ppa2, list_rev ppalist2_acc)
| ((p2', pa2') as ppa2') :: ppalist2_rest -> begin
L.d_strln ".... JOIN ....";
L.d_strln "JOIN SYM HEAP1: "; Prop.d_prop p2; L.d_ln ();
L.d_strln "JOIN SYM HEAP2: "; Prop.d_prop p2'; L.d_ln (); L.d_ln ();
match prop_partial_join pname tenv mode p2 p2' with
| None ->
L.d_strln_color Red ".... JOIN FAILED ...."; L.d_ln ();
join_proppath_plist (ppa2':: ppalist2_acc) ppa2 ppalist2_rest
| Some p2'' ->
L.d_strln_color Green ".... JOIN SUCCEEDED ....";
L.d_strln "RESULT SYM HEAP:"; Prop.d_prop p2''; L.d_ln (); L.d_ln ();
join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest
end in
L.d_strln ".... JOIN ....";
L.d_strln "JOIN SYM HEAP1: "; Prop.d_prop p2; L.d_ln ();
L.d_strln "JOIN SYM HEAP2: "; Prop.d_prop p2'; L.d_ln (); L.d_ln ();
match prop_partial_join pname tenv mode p2 p2' with
| None ->
L.d_strln_color Red ".... JOIN FAILED ...."; L.d_ln ();
join_proppath_plist (ppa2':: ppalist2_acc) ppa2 ppalist2_rest
| Some p2'' ->
L.d_strln_color Green ".... JOIN SUCCEEDED ....";
L.d_strln "RESULT SYM HEAP:"; Prop.d_prop p2''; L.d_ln (); L.d_ln ();
join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest
end in
let rec join ppalist1_cur ppalist2_acc = function
| [] -> (ppalist1_cur, ppalist2_acc)
| ppa2:: ppalist2_rest ->
@ -2004,14 +2004,14 @@ let pathset_join
res
(**
The meet operator does two things:
1) makes the result logically stronger (just like additive conjunction)
2) makes the result spatially larger (just like multiplicative conjunction).
Assuming that the meet operator forms a partial commutative monoid (soft assumption: it means
that the results are more predictable), try to combine every element of plist with any other element.
Return a list of the same lenght, with each element maximally combined. The algorithm is quadratic.
The operation is dependent on the order in which elements are combined; there is a straightforward
order - independent algorithm but it is exponential.
The meet operator does two things:
1) makes the result logically stronger (just like additive conjunction)
2) makes the result spatially larger (just like multiplicative conjunction).
Assuming that the meet operator forms a partial commutative monoid (soft assumption: it means
that the results are more predictable), try to combine every element of plist with any other element.
Return a list of the same lenght, with each element maximally combined. The algorithm is quadratic.
The operation is dependent on the order in which elements are combined; there is a straightforward
order - independent algorithm but it is exponential.
*)
let proplist_meet_generate plist =
let props_done = ref Propset.empty in
@ -2031,9 +2031,9 @@ let proplist_meet_generate plist =
let rec proplist_meet = function
| [] -> ()
| (porig, pcombined) :: pplist ->
(* use porig instead of pcombined because it might be combinable with more othe props *)
(* e.g. porig might contain a global var to add to the ture branch of a conditional *)
(* but pcombined might have been combined with the false branch already *)
(* use porig instead of pcombined because it might be combinable with more othe props *)
(* e.g. porig might contain a global var to add to the ture branch of a conditional *)
(* but pcombined might have been combined with the false branch already *)
let pplist' = list_map (combine porig) pplist in
props_done := Propset.add pcombined !props_done;
proplist_meet pplist' in

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

@ -264,32 +264,32 @@ 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), _) when not (Sil.exp_equal e Sil.exp_zero) ->
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) ->
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) ->
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
[Dotdangling(coo, e2, e2_color_str)]
else [] in
if not (Sil.exp_equal e3 Sil.exp_zero) then Dotdangling(coo, e3, e3_color_str):: ll
else ll
| Sil.Hpointsto (_, _, _)
| _ -> [] (* arrays and struct do not give danglings*)
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) when not (Sil.exp_equal e Sil.exp_zero) ->
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) ->
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) ->
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
[Dotdangling(coo, e2, e2_color_str)]
else [] in
if not (Sil.exp_equal e3 Sil.exp_zero) then Dotdangling(coo, e3, e3_color_str):: ll
else ll
| Sil.Hpointsto (_, _, _)
| _ -> [] (* arrays and struct do not give danglings*)
) in
let is_allocated d =
match d with
| Dotdangling(_, e, _) ->
list_exists (fun a -> match a with
| Dotpointsto(_, e', _)
| Dotarray(_, _, e', _, _, _)
| Dotlseg(_, e', _, _, _, _)
| Dotdllseg(_, e', _, _, _, _, _, _) -> Sil.exp_equal e e'
| _ -> false
| Dotpointsto(_, e', _)
| Dotarray(_, _, e', _, _, _)
| Dotlseg(_, e', _, _, _, _)
| Dotdllseg(_, e', _, _, _, _, _, _) -> Sil.exp_equal e e'
| _ -> false
) allocated_nodes
| _ -> false (*this should never happen since d must be a dangling node *) in
let rec filter_duplicate l seen_exp =
@ -353,7 +353,7 @@ let set_exps_neq_zero pi =
let box_dangling e =
let entry_e = list_filter (fun b -> match b with
| Dotdangling(_, e', _) -> Sil.exp_equal e e' | _ -> false ) !dangling_dotboxes in
| Dotdangling(_, e', _) -> Sil.exp_equal e e' | _ -> false ) !dangling_dotboxes in
match entry_e with
|[] -> None
| Dotdangling(coo, _, _):: _ -> Some coo.id
@ -417,20 +417,20 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda =
end else
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
(match nodes_e with
| [] ->
(match box_dangling e with
| None -> []
| Some n' -> [(LinkStructToExp, Ident.fieldname_to_string fn, n',"")]
)
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkStructToStruct, Ident.fieldname_to_string fn, n, e_no_special_char)]
end else
[(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
| [] ->
(match box_dangling e with
| None -> []
| Some n' -> [(LinkStructToExp, Ident.fieldname_to_string fn, n',"")]
)
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkStructToStruct, Ident.fieldname_to_string fn, n, e_no_special_char)]
end else
[(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.Earray _ ->[] (* inner arrays are printed by print_array function *)
@ -453,20 +453,20 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda =
end else
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
(match nodes_e with
| [] ->
(match box_dangling e with
| None -> []
| Some n' -> [(LinkArrayToExp, Sil.exp_to_string idx, n',"")]
)
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkArrayToStruct, Sil.exp_to_string idx, n, e_no_special_char)]
end else
[(LinkArrayToExp, Sil.exp_to_string idx, n,"")]
| _ -> (* by construction there must be at most 2 nodes for an expression*)
L.out "@\n Too many nodes! Error! @\n@.@."; assert false
| [] ->
(match box_dangling e with
| None -> []
| Some n' -> [(LinkArrayToExp, Sil.exp_to_string idx, n',"")]
)
| [node] | [Dotpointsto _ ; node] | [node; Dotpointsto _] ->
let n = get_coordinate_id node in
if list_mem Sil.exp_equal e !struct_exp_nodes then begin
let e_no_special_char = strip_special_chars (Sil.exp_to_string e) in
[(LinkArrayToStruct, Sil.exp_to_string idx, n, e_no_special_char)]
end else
[(LinkArrayToExp, Sil.exp_to_string idx, 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.Earray _ ->[] (* inner arrays are printed by print_array function *)
@ -486,12 +486,12 @@ let rec compute_target_from_eexp dotnodes e p f lambda =
let nodes_e_no_struct = list_filter is_not_struct nodes_e in
let trg = list_map get_coordinate_id nodes_e_no_struct in
(match trg with
| [] ->
(match box_dangling e with
| None -> []
| Some n -> [(LinkExpToExp, n, "")]
)
| _ -> list_map (fun n -> (LinkExpToExp, n, "")) trg
| [] ->
(match box_dangling e with
| None -> []
| Some n -> [(LinkExpToExp, n, "")]
)
| _ -> list_map (fun n -> (LinkExpToExp, n, "")) trg
)
(* build the set of edges between nodes *)
@ -516,60 +516,60 @@ let rec dotty_mk_set_links dotnodes sigma p f =
| (Sil.Hpointsto (e, Sil.Estruct (lfld, _), t), lambda):: sigma' ->
let src = look_up dotnodes e lambda in
(match src with
| [] -> assert false
| nl ->
(* L.out "@\n@\n List of nl= "; list_iter (L.out " %i ") nl; L.out "@.@.@."; *)
let target_list = compute_target_struct_fields dotnodes lfld p f lambda in
let ff n = list_map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
let address_struct_id =
try get_coordinate_id (list_hd (list_filter (is_source_node_of_exp e) nodes_e))
with exn when exn_not_timeout exn -> (* L.out "@\n@\n PROBLEMS!!!!!!!!!!@.@.@."; *) assert false in
(* we need to exclude the address node from the sorce of fields. no fields should start from there*)
let nl'= list_filter (fun id -> address_struct_id != id) nl in
let links_from_fields = list_flatten (list_map ff nl') in
let trg_label = strip_special_chars (Sil.exp_to_string e) in
let lnk_from_address_struct = mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) "" (mk_coordinate (address_struct_id + 1) lambda) trg_label in
lnk_from_address_struct:: links_from_fields @ dotty_mk_set_links dotnodes sigma' p f
| [] -> assert false
| nl ->
(* L.out "@\n@\n List of nl= "; list_iter (L.out " %i ") nl; L.out "@.@.@."; *)
let target_list = compute_target_struct_fields dotnodes lfld p f lambda in
let ff n = list_map (fun (k, lab_src, m, lab_trg) -> mk_link k (mk_coordinate n lambda) lab_src (mk_coordinate m lambda) lab_trg) target_list in
let nodes_e = select_nodes_exp_lambda dotnodes e lambda in
let address_struct_id =
try get_coordinate_id (list_hd (list_filter (is_source_node_of_exp e) nodes_e))
with exn when exn_not_timeout exn -> (* L.out "@\n@\n PROBLEMS!!!!!!!!!!@.@.@."; *) assert false in
(* we need to exclude the address node from the sorce of fields. no fields should start from there*)
let nl'= list_filter (fun id -> address_struct_id != id) nl in
let links_from_fields = list_flatten (list_map ff nl') in
let trg_label = strip_special_chars (Sil.exp_to_string e) in
let lnk_from_address_struct = mk_link (LinkExpToStruct) (mk_coordinate address_struct_id lambda) "" (mk_coordinate (address_struct_id + 1) lambda) trg_label in
lnk_from_address_struct:: links_from_fields @ dotty_mk_set_links dotnodes sigma' p f
)
| (Sil.Hpointsto (e, Sil.Eexp (e', inst'), t), lambda):: sigma' ->
let src = look_up dotnodes e lambda in
(match src with
| [] -> assert false
| nl ->
let target_list = compute_target_from_eexp dotnodes e' p f lambda in
let ff n = list_map (fun (k, m, lab_target) -> mk_link k (mk_coordinate n lambda) "" (mk_coordinate m lambda) (strip_special_chars lab_target)) target_list in
let ll = list_flatten (list_map ff nl) in
ll @ dotty_mk_set_links dotnodes sigma' p f
| [] -> assert false
| nl ->
let target_list = compute_target_from_eexp dotnodes e' p f lambda in
let ff n = list_map (fun (k, m, lab_target) -> mk_link k (mk_coordinate n lambda) "" (mk_coordinate m lambda) (strip_special_chars lab_target)) target_list in
let ll = list_flatten (list_map ff nl) in
ll @ dotty_mk_set_links dotnodes sigma' p f
)
| (Sil.Hlseg (_, pred, e1, e2, elist), lambda):: sigma' ->
let src = look_up dotnodes e1 lambda in
(match src with
| [] -> assert false
| n:: _ ->
let (_, m, lab) = list_hd (compute_target_from_eexp dotnodes e2 p f lambda) in
let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in
lnk:: dotty_mk_set_links dotnodes sigma' p f
| [] -> assert false
| n:: _ ->
let (_, m, lab) = list_hd (compute_target_from_eexp dotnodes e2 p f lambda) in
let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in
lnk:: dotty_mk_set_links dotnodes sigma' p f
)
| (Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist), lambda):: sigma' ->
let src = look_up dotnodes e1 lambda in
(match src with
| [] -> assert false
| n:: _ -> (* n is e1's box and n+1 is e4's box *)
let targetF = look_up dotnodes e3 lambda in
let target_Flink = (match targetF with
| [] -> []
| m:: _ -> [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""]
) in
let targetB = look_up dotnodes e2 lambda in
let target_Blink = (match targetB with
| [] -> []
| m:: _ -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""]
) in
target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f
| [] -> assert false
| n:: _ -> (* n is e1's box and n+1 is e4's box *)
let targetF = look_up dotnodes e3 lambda in
let target_Flink = (match targetF with
| [] -> []
| m:: _ -> [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""]
) in
let targetB = look_up dotnodes e2 lambda in
let target_Blink = (match targetB with
| [] -> []
| m:: _ -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""]
) in
target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f
)
let print_kind f kind =
@ -628,8 +628,8 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) =
let remove_links_from ln = list_filter (fun n' -> not (list_mem Pervasives.(=) n' ln)) !tmp_links in
let remove_node n ns =
list_filter (fun n' -> match n' with
| Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n)
| _ -> true
| Dotpointsto _ -> (get_coordinate_id n')!= (get_coordinate_id n)
| _ -> true
) ns in
let rec boxes_pointed_by n lns =
match lns with
@ -758,11 +758,11 @@ and build_visual_graph f pe p =
compute_fields_struct sigma;
compute_struct_exp_nodes sigma;
(* L.out "@\n@\n Computed fields structs: ";
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs;
L.out "@\n@.";
L.out "@\n@\n Computed exp structs nodes: ";
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes;
L.out "@\n@."; *)
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !fields_structs;
L.out "@\n@.";
L.out "@\n@\n Computed exp structs nodes: ";
list_iter (fun e -> L.out " %a " (Sil.pp_exp pe) e) !struct_exp_nodes;
L.out "@\n@."; *)
let sigma_lambda = list_map (fun hp -> (hp,!lambda_counter)) sigma in
let nodes = (dotty_mk_node pe) sigma_lambda in
make_dangling_boxes pe nodes sigma_lambda;
@ -833,10 +833,10 @@ let pp_dotty_one_spec f pre posts =
pp_dotty f (Spec_precondition) pre;
invisible_arrows:= false;
list_iter (fun (po, path) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po;
for j = 1 to 4 do
F.fprintf f " inv_%i%i%i%i -> state_pi_%i [style=invis]\n" !spec_counter j j j !target_invisible_arrow_pre;
done
) posts;
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
) posts;
F.fprintf f "\n } \n"
(* this is used to print a list of proposition when considered in a path of nodes *)
@ -851,7 +851,7 @@ let pp_dotty_prop_list_in_path f plist prev_n curr_n =
if prev_n <> - 1 then F.fprintf f "\n state%iN ->state%iN\n" prev_n curr_n;
F.fprintf f "\n } \n"
with exn when exn_not_timeout exn ->
()
()
(* create a dotty file with a single proposition *)
let dotty_prop_to_dotty_file fname prop =
@ -865,7 +865,7 @@ let dotty_prop_to_dotty_file fname prop =
Format.fprintf fmt_dot "@\n}";
close_out out_dot
with exn when exn_not_timeout exn ->
()
()
(* this is used only to print a list of prop parsed with the external parser. Basically deprecated.*)
let pp_proplist_parsed2dotty_file filename plist =
@ -882,7 +882,7 @@ let pp_proplist_parsed2dotty_file filename plist =
F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist;
close_out outc
with exn when exn_not_timeout exn ->
()
()
(********** START of Print interprocedural cfgs in dotty format *)
(********** Print control flow graph (in dot form) for fundec to *)
@ -893,19 +893,19 @@ let pp_cfgnodename fmt (n : Cfg.Node.t) =
let pp_etlist fmt etl =
list_iter (fun (id, ty) ->
Format.fprintf fmt " %s:%a" id (Sil.pp_typ_full pe_text) ty) etl
Format.fprintf fmt " %s:%a" id (Sil.pp_typ_full pe_text) ty) etl
let pp_local_list fmt etl =
list_iter (fun (id, ty) ->
Format.fprintf fmt " %a:%a" Mangled.pp id (Sil.pp_typ_full pe_text) ty) etl
Format.fprintf fmt " %a:%a" Mangled.pp id (Sil.pp_typ_full pe_text) ty) etl
let pp_cfgnodelabel fmt (n : Cfg.Node.t) =
let pp_label fmt n =
match Cfg.Node.get_kind n with
| Cfg.Node.Start_node (pdesc) ->
let gen = if (Cfg.Procdesc.get_attributes pdesc).Sil.is_generated then " (generated)" else "" in
(* let def = if Cfg.Procdesc.is_defined pdesc then "defined" else "declared" in *)
(* Format.fprintf fmt "Start %a (%s)" pp_id (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) def *)
let gen = if (Cfg.Procdesc.get_attributes pdesc).Sil.is_generated then " (generated)" else "" in
(* let def = if Cfg.Procdesc.is_defined pdesc then "defined" else "declared" in *)
(* Format.fprintf fmt "Start %a (%s)" pp_id (Procname.to_string (Cfg.Procdesc.get_proc_name pdesc)) def *)
Format.fprintf fmt "Start %s%s\\nFormals: %a\\nLocals: %a"
(Procname.to_string (Cfg.Procdesc.get_proc_name pdesc))
gen
@ -1025,7 +1025,7 @@ let pp_speclist_to_file (filename : DB.filename) spec_list =
let pp_speclist_dotty_file (filename : DB.filename) spec_list =
try pp_speclist_to_file filename spec_list
with exn when exn_not_timeout exn ->
()
()
(**********************************************************************)
(* Code prodicing a xml version of a graph *)
@ -1077,7 +1077,7 @@ let atom_to_xml_string a =
(* return the dangling node corresponding to an expression it exists or None *)
let exp_dangling_node e =
let entry_e = list_filter (fun b -> match b with
| VH_dangling(_, e') -> Sil.exp_equal e e' | _ -> false ) !set_dangling_nodes in
| VH_dangling(_, e') -> Sil.exp_equal e e' | _ -> false ) !set_dangling_nodes in
match entry_e with
|[] -> None
| VH_dangling(n, e') :: _ -> Some (VH_dangling(n, e'))
@ -1126,7 +1126,7 @@ let rec select_node_at_address nodes e =
(* look-up the ids in the list of nodes corresponding to expression e*)
(* let look_up_nodes_ids nodes e =
list_map get_node_id (select_nodes_exp nodes e) *)
list_map get_node_id (select_nodes_exp nodes e) *)
(* create a list of dangling nodes *)
let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) =
@ -1136,22 +1136,22 @@ 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.Hlseg (_, _, _, e2, _) when not (Sil.exp_equal e2 Sil.exp_zero) -> [e2]
| Sil.Hdllseg (_, _, e1, e2, e3, _, _) ->
if (Sil.exp_equal e2 Sil.exp_zero) then
if (Sil.exp_equal e3 Sil.exp_zero) then []
else [e3]
else [e2; e3]
| Sil.Hpointsto (_, _, _)
| _ -> [] (* arrays and struct do not give danglings. CHECK THIS!*)
| Sil.Hpointsto (_, Sil.Eexp (e, inst), _) 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, _, _) ->
if (Sil.exp_equal e2 Sil.exp_zero) then
if (Sil.exp_equal e3 Sil.exp_zero) then []
else [e3]
else [e2; e3]
| Sil.Hpointsto (_, _, _)
| _ -> [] (* arrays and struct do not give danglings. CHECK THIS!*)
) in
let is_not_allocated e =
let allocated = list_exists (fun a -> match a with
| VH_pointsto(_, e', _, _)
| VH_lseg(_, e', _ , _)
| VH_dllseg(_, e', _, _, _, _) -> Sil.exp_equal e e'
| _ -> false ) allocated_nodes in
| VH_pointsto(_, e', _, _)
| VH_lseg(_, e', _ , _)
| VH_dllseg(_, e', _, _, _, _) -> Sil.exp_equal e e'
| _ -> false ) allocated_nodes in
not allocated in
let rec filter_duplicate l seen_exp =
match l with
@ -1173,27 +1173,27 @@ let rec compute_target_nodes_from_sexp nodes se prop field_lab =
| Sil.Eexp (e, inst) ->
let e_node = select_node_at_address nodes e in
(match e_node with
| None ->
(match exp_dangling_node e with
| None -> []
| Some dang_node -> [(dang_node, field_lab)]
)
| Some n -> [(n, field_lab)]
| None ->
(match exp_dangling_node e with
| None -> []
| Some dang_node -> [(dang_node, field_lab)]
)
| Some n -> [(n, field_lab)]
)
| Sil.Estruct (lfld, inst) ->
(match lfld with
| [] -> []
| (fn, se2):: l' ->
compute_target_nodes_from_sexp nodes se2 prop (Ident.fieldname_to_string fn) @
compute_target_nodes_from_sexp nodes (Sil.Estruct (l', inst)) prop ""
| [] -> []
| (fn, se2):: l' ->
compute_target_nodes_from_sexp nodes se2 prop (Ident.fieldname_to_string fn) @
compute_target_nodes_from_sexp nodes (Sil.Estruct (l', inst)) prop ""
)
| Sil.Earray(size, lie, inst) ->
(match lie with
| [] -> []
| (idx, se2):: l' ->
let lab ="["^exp_to_xml_string idx^"]" in
compute_target_nodes_from_sexp nodes se2 prop lab @
compute_target_nodes_from_sexp nodes (Sil.Earray(size, l', inst)) prop ""
| [] -> []
| (idx, se2):: l' ->
let lab ="["^exp_to_xml_string idx^"]" in
compute_target_nodes_from_sexp nodes se2 prop lab @
compute_target_nodes_from_sexp nodes (Sil.Earray(size, l', inst)) prop ""
)
@ -1206,32 +1206,32 @@ let rec make_visual_heap_edges nodes sigma prop =
| Sil.Hpointsto (e, se, t):: sigma' ->
let e_node = select_node_at_address nodes e in
(match e_node with
| None -> assert false
| Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop
| None -> assert false
| Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop
)
| Sil.Hlseg (_, pred, e1, e2, elist):: sigma' ->
let e1_node = select_node_at_address nodes e1 in
(match e1_node with
| None -> assert false
| Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop
| None -> assert false
| Some n ->
let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let ll = list_map (combine_source_target_label n) target_nodes in
ll @ make_visual_heap_edges nodes sigma' prop
)
| Sil.Hdllseg (_, pred, e1, e2, e3, e4, elist):: sigma' ->
let e1_node = select_node_at_address nodes e1 in
(match e1_node with
| None -> assert false
| Some n ->
let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in
let target_nodesB = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let llF = list_map (combine_source_target_label n) target_nodesF in
let llB = list_map (combine_source_target_label n) target_nodesB in
llF @ llB @ make_visual_heap_edges nodes sigma' prop
| None -> assert false
| Some n ->
let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in
let target_nodesB = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in
let llF = list_map (combine_source_target_label n) target_nodesF in
let llB = list_map (combine_source_target_label n) target_nodesB in
llF @ llB @ make_visual_heap_edges nodes sigma' prop
)
(* from a prop generate and return visual proposition *)
@ -1348,8 +1348,8 @@ let print_specs_xml signature specs loc fmt =
let list_of_specs_xml =
list_map
(fun s ->
j:=!j + 1;
do_one_spec (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts !j)
j:=!j + 1;
do_one_spec (Specs.Jprop.to_prop s.Specs.pre) s.Specs.posts !j)
specs in
let xml_specifications = Io_infer.Xml.create_tree "specifications" [] list_of_specs_xml in
let xml_signature = Io_infer.Xml.create_tree "signature" [("name", signature)] [] in

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

@ -21,8 +21,8 @@ let pvar_to_string pvar =
let hpred_is_open_resource prop = function
| Sil.Hpointsto(e, _, _) ->
(match Prop.get_resource_undef_attribute prop e with
| Some (Sil.Aresource { Sil.ra_kind = Sil.Racquire; Sil.ra_res = res }) -> Some res
| _ -> None)
| Some (Sil.Aresource { Sil.ra_kind = Sil.Racquire; Sil.ra_res = res }) -> Some res
| _ -> None)
| _ ->
None
@ -69,9 +69,9 @@ let find_other_prune_node node =
match Cfg.Node.get_preds node with
| [n_pre] ->
(match Cfg.Node.get_succs n_pre with
| [n1; n2] ->
if Cfg.Node.equal n1 node then Some n2 else Some n1
| _ -> None)
| [n1; n2] ->
if Cfg.Node.equal n1 node then Some n2 else Some n1
| _ -> None)
| _ -> None
(** Return true if [id] is assigned to a program variable which is then nullified *)
@ -84,15 +84,15 @@ let id_is_assigned_then_dead node id =
let prune_check = function (* if prune node, check that it's also nullified in the other branch *)
| Some node' ->
(match Cfg.Node.get_instrs node' with
| instr':: _ -> find_nullify_after_instr node' instr' pvar
| _ -> false)
| instr':: _ -> find_nullify_after_instr node' instr' pvar
| _ -> false)
| _ -> false in
find_nullify_after_instr node instr pvar
&& (not is_prune || prune_check (find_other_prune_node node))
| _ -> false
(** Find the function call instruction used to initialize normal variable [id],
and return the function name and arguments *)
and return the function name and arguments *)
let find_normal_variable_funcall
(node: Cfg.Node.t)
(id: Ident.t): (Sil.exp * (Sil.exp list) * Sil.location * Sil.call_flags) option =
@ -105,7 +105,7 @@ let find_normal_variable_funcall
| _ -> false in
ignore (list_exists find_declaration node_instrs);
if !verbose && !res == None then (L.d_str ("find_normal_variable_funcall could not find " ^
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
!res
(** Find a program variable assignment in the current node or predecessors. *)
@ -129,8 +129,8 @@ let find_program_variable_assignment node pvar : (Cfg.Node.t * Ident.t) option =
find pred_node
| [pn1; pn2] ->
(match find pn1 with
| None -> find pn2
| x -> x)
| None -> find pn2
| x -> x)
| _ -> None (* either 0 or >2 predecessors *)
end in
find node
@ -156,14 +156,14 @@ let find_ident_assignment node id : (Cfg.Node.t * Sil.exp) option =
find pred_node
| [pn1; pn2] ->
(match find pn1 with
| None -> find pn2
| x -> x)
| None -> find pn2
| x -> x)
| _ -> None (* either 0 or >2 predecessors *)
end in
find node
(** Find a boolean assignment to a temporary variable holding a boolean condition.
The boolean parameter indicates whether the true or false branch is required. *)
The boolean parameter indicates whether the true or false branch is required. *)
let rec find_boolean_assignment node pvar true_branch : Cfg.Node.t option =
let find_instr n =
let filter = function
@ -213,7 +213,7 @@ let pvar_is_frontend_tmp pvar =
else pvar_is_cil_tmp pvar || pvar_is_edg_tmp pvar
(** Find the Letderef instruction used to declare normal variable [id],
and return the expression dereferenced to initialize [id] *)
and return the expression dereferenced to initialize [id] *)
let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp option =
let res = ref None in
let node_instrs = Cfg.Node.get_instrs node in
@ -227,7 +227,7 @@ let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp
res := _exp_rv_dexp seen node e;
true
| Sil.Call ([id0], (Sil.Const (Sil.Cfun pname) as fun_exp), args, loc, call_flags)
when Ident.equal id id0 ->
when Ident.equal id id0 ->
if !verbose then (L.d_str "find_normal_variable_letderef function call "; Sil.d_exp fun_exp; L.d_ln ());
let fun_dexp = Sil.Dconst (Sil.Cfun pname) in
@ -244,7 +244,7 @@ let rec _find_normal_variable_letderef (seen : Sil.ExpSet.t) node id : Sil.dexp
| _ -> false in
ignore (list_exists find_declaration node_instrs);
if !verbose && !res == None then (L.d_str ("find_normal_variable_letderef could not find " ^
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
Ident.to_string id ^ " in node " ^ string_of_int (Cfg.Node.get_id node)); L.d_ln ());
!res
(** describe lvalue [e] as a dexp *)
@ -260,13 +260,13 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
| Sil.BinOp(Sil.PlusPI, e1, e2) ->
if !verbose then (L.d_str "exp_lv_dexp: (e1 +PI e2) "; Sil.d_exp e; L.d_ln ());
(match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| Some de1, Some de2 -> Some (Sil.Dbinop(Sil.PlusPI, de1, de2))
| _ -> None)
| Some de1, Some de2 -> Some (Sil.Dbinop(Sil.PlusPI, de1, de2))
| _ -> None)
| Sil.Var id when Ident.is_normal id ->
if !verbose then (L.d_str "exp_lv_dexp: normal var "; Sil.d_exp e; L.d_ln ());
(match _find_normal_variable_letderef seen node id with
| None -> None
| Some de -> Some (Sil.Dderef de))
| None -> None
| Some de -> Some (Sil.Dderef de))
| Sil.Lvar pvar ->
if !verbose then (L.d_str "exp_lv_dexp: program var "; Sil.d_exp e; L.d_ln ());
if pvar_is_frontend_tmp pvar then
@ -302,8 +302,8 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln ()
end;
(match _find_normal_variable_letderef seen node id with
| None -> None
| Some de -> Some (Sil.Darrow (de, f)))
| None -> None
| Some de -> Some (Sil.Darrow (de, f)))
| Sil.Lfield (e1, f, typ) ->
if !verbose then
begin
@ -313,8 +313,8 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln ()
end;
(match _exp_lv_dexp seen node e1 with
| None -> None
| Some de -> Some (Sil.Ddot (de, f)))
| None -> None
| Some de -> Some (Sil.Ddot (de, f)))
| Sil.Lindex (e1, e2) ->
if !verbose then
begin
@ -325,11 +325,11 @@ and _exp_lv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln ()
end;
(match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| None, _ -> None
| Some de1, None ->
(* even if the index is unknown, the array info is useful for bound errors *)
Some (Sil.Darray (de1, Sil.Dunknown))
| Some de1, Some de2 -> Some (Sil.Darray (de1, de2)))
| None, _ -> None
| Some de1, None ->
(* even if the index is unknown, the array info is useful for bound errors *)
Some (Sil.Darray (de1, Sil.Dunknown))
| Some de1, Some de2 -> Some (Sil.Darray (de1, de2)))
| _ ->
if !verbose then (L.d_str "exp_lv_dexp: no match for "; Sil.d_exp e; L.d_ln ());
None
@ -361,8 +361,8 @@ and _exp_rv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln ()
end;
(match _exp_rv_dexp seen node e1 with
| None -> None
| Some de -> Some (Sil.Ddot(de, f)))
| None -> None
| Some de -> Some (Sil.Ddot(de, f)))
| Sil.Lindex (e1, e2) ->
if !verbose then
begin
@ -373,18 +373,18 @@ and _exp_rv_dexp (_seen : Sil.ExpSet.t) node e : Sil.dexp option =
L.d_ln ()
end;
(match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| None, _ | _, None -> None
| Some de1, Some de2 -> Some (Sil.Darray(de1, de2)))
| None, _ | _, None -> None
| Some de1, Some de2 -> Some (Sil.Darray(de1, de2)))
| Sil.BinOp (op, e1, e2) ->
if !verbose then (L.d_str "exp_rv_dexp: BinOp "; Sil.d_exp e; L.d_ln ());
(match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with
| None, _ | _, None -> None
| Some de1, Some de2 -> Some (Sil.Dbinop (op, de1, de2)))
| None, _ | _, None -> None
| Some de1, Some de2 -> Some (Sil.Dbinop (op, de1, de2)))
| Sil.UnOp (op, e1, _) ->
if !verbose then (L.d_str "exp_rv_dexp: UnOp "; Sil.d_exp e; L.d_ln ());
(match _exp_rv_dexp seen node e1 with
| None -> None
| Some de1 -> Some (Sil.Dunop (op, de1)))
| None -> None
| Some de1 -> Some (Sil.Dunop (op, de1)))
| Sil.Cast (_, e1) ->
if !verbose then (L.d_str "exp_rv_dexp: Cast "; Sil.d_exp e; L.d_ln ());
_exp_rv_dexp seen node e1
@ -453,9 +453,9 @@ let find_pvar_typ_without_ptr tenv prop pvar =
!res
(** Produce a description of a leak by looking at the current state.
If the current instruction is a variable nullify, blame the variable.
If it is an abstraction, blame any variable nullify at the current node.
If there is an alloc attribute, print the function call and line number. *)
If the current instruction is a variable nullify, blame the variable.
If it is an abstraction, blame any variable nullify at the current node.
If there is an alloc attribute, print the function call and line number. *)
let explain_leak tenv hpred prop alloc_att_opt bucket =
let instro = State.get_instr () in
let loc = State.get_loc () in
@ -486,9 +486,9 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
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)) ->
(try
let t2 = Sil.expand_type tenv _t2 in
Sil.typ_equal t1 t2
with exn when exn_not_timeout exn -> false)
let t2 = Sil.expand_type tenv _t2 in
Sil.typ_equal t1 t2
with exn when exn_not_timeout exn -> false)
| Some (Sil.Sizeof (Sil.Tint _, _)), Some (Sil.Sizeof (Sil.Tint _, _)) when is_file -> (* must be a file opened with "open" *)
true
| _ -> false in
@ -499,8 +499,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
| Some (Sil.Nullify (pvar, loc, _)) 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
| Some de -> Some (Sil.dexp_to_string de))
| None -> None
| Some de -> Some (Sil.dexp_to_string de))
| Some (Sil.Abstract _) ->
if !verbose then (L.d_str "explain_leak: current instruction is Abstract"; L.d_ln ());
let get_nullify = function
@ -514,8 +514,8 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
| Some (Sil.Set (lexp, _, _, _)) when vpath = None ->
if !verbose then (L.d_str "explain_leak: current instruction Set for "; Sil.d_exp lexp; L.d_ln ());
(match exp_lv_dexp node lexp with
| Some dexp -> Some (Sil.dexp_to_string dexp)
| None -> None)
| Some dexp -> Some (Sil.dexp_to_string dexp)
| None -> None)
| Some instr ->
if !verbose then (L.d_str "explain_leak: case not matched in instr "; Sil.d_instr instr; L.d_ln());
value_str_from_pvars_vpath [] vpath in
@ -530,7 +530,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
exn_cat, Localise.desc_leak value_str resource_opt res_action_opt loc bucket
(** find the dexp, if any, where the given value is stored
also return the type of the value if found *)
also return the type of the value if found *)
let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
if !verbose then (L.d_str "in vpath_find exp:"; Sil.d_exp _exp; L.d_ln ());
let rec find sigma_acc sigma_todo exp =
@ -538,38 +538,38 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
| Sil.Eexp (e, _) when Sil.exp_equal exp e ->
let sigma' = (list_rev_append sigma_acc' sigma_todo') in
(match lexp with
| Sil.Lvar pv ->
let typo = match texp with
| Sil.Sizeof (Sil.Tstruct (ftl, ftal, _, _, _, _, _), _) ->
(try
| Sil.Lvar pv ->
let typo = match texp with
| Sil.Sizeof (Sil.Tstruct (ftl, ftal, _, _, _, _, _), _) ->
(try
let _, t, _ = list_find (fun (_f, _t, _) -> Ident.fieldname_equal _f f) ftl in
Some t
with Not_found -> None)
| _ -> None in
res := Some (Sil.Ddot (Sil.Dpvar pv, f)), typo
| Sil.Var id ->
(match find [] sigma' (Sil.Var id) with
| None, _ -> ()
| Some de, typo -> res := Some (Sil.Darrow (de, f)), typo)
| lexp ->
if !verbose then (L.d_str "vpath_find do_fse: no match on Eexp "; Sil.d_exp lexp; L.d_ln ()))
| _ -> None in
res := Some (Sil.Ddot (Sil.Dpvar pv, f)), typo
| Sil.Var id ->
(match find [] sigma' (Sil.Var id) with
| None, _ -> ()
| Some de, typo -> res := Some (Sil.Darrow (de, f)), typo)
| lexp ->
if !verbose then (L.d_str "vpath_find do_fse: no match on Eexp "; Sil.d_exp lexp; L.d_ln ()))
| _ -> () in
let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with
| Sil.Eexp (e, _) when Sil.exp_equal exp e ->
let sigma' = (list_rev_append sigma_acc' sigma_todo') in
(match lexp with
| Sil.Lvar pv when not (pvar_is_frontend_tmp pv) ->
let typo = match texp with
| Sil.Sizeof (typ, _) -> Some typ
| _ -> None in
Some (Sil.Dpvar pv), typo
| Sil.Var id ->
(match find [] sigma' (Sil.Var id) with
| None, typo -> None, typo
| Some de, typo -> Some (Sil.Dderef de), typo)
| lexp ->
if !verbose then (L.d_str "vpath_find do_sexp: no match on Eexp "; Sil.d_exp lexp; L.d_ln ());
None, None)
| Sil.Lvar pv when not (pvar_is_frontend_tmp pv) ->
let typo = match texp with
| Sil.Sizeof (typ, _) -> Some typ
| _ -> None in
Some (Sil.Dpvar pv), typo
| Sil.Var id ->
(match find [] sigma' (Sil.Var id) with
| None, typo -> None, typo
| Some de, typo -> Some (Sil.Dderef de), typo)
| lexp ->
if !verbose then (L.d_str "vpath_find do_sexp: no match on Eexp "; Sil.d_exp lexp; L.d_ln ());
None, None)
| Sil.Estruct (fsel, _) ->
let res = ref (None, None) in
list_iter (do_fse res sigma_acc' sigma_todo' lexp texp) fsel;
@ -588,14 +588,14 @@ let vpath_find prop _exp : Sil.dexp option * Sil.typ option =
| 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 ()); *)
(* 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
| [] -> None, None
| hpred:: sigma_todo' ->
(match do_hpred sigma_acc sigma_todo' hpred with
| Some de, typo -> Some de, typo
| None, _ -> find (hpred:: sigma_acc) sigma_todo' exp) in
| Some de, typo -> Some de, typo
| None, _ -> find (hpred:: sigma_acc) sigma_todo' exp) in
let res = find [] (Prop.get_sigma prop) _exp in
if !verbose then begin
match res with
@ -644,45 +644,45 @@ let explain_dexp_access prop dexp is_nullable =
Some (Sil.Eexp (Sil.Const c, Sil.inst_none))
| Sil.Darray (de1, de2) ->
(match lookup de1, lookup de2 with
| None, _ | _, None -> None
| Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) ->
lookup_esel esel e
| Some se1, Some se2 ->
if !verbose then (L.d_str "lookup: case not matched on Darray "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln());
None)
| None, _ | _, None -> None
| Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) ->
lookup_esel esel e
| Some se1, Some se2 ->
if !verbose then (L.d_str "lookup: case not matched on Darray "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln());
None)
| Sil.Darrow (de1, f) ->
(match lookup (Sil.Dderef de1) with
| None -> None
| Some Sil.Estruct (fsel, _) ->
lookup_fld fsel f
| Some _ ->
if !verbose then (L.d_str "lookup: case not matched on Darrow "; L.d_ln ());
None)
| None -> None
| Some Sil.Estruct (fsel, _) ->
lookup_fld fsel f
| Some _ ->
if !verbose then (L.d_str "lookup: case not matched on Darrow "; L.d_ln ());
None)
| Sil.Ddot (de1, f) ->
(match lookup de1 with
| None -> None
| Some Sil.Estruct (fsel, _) ->
lookup_fld fsel f
| Some _ ->
if !verbose then (L.d_str "lookup: case not matched on Ddot "; L.d_ln ());
None)
| None -> None
| Some Sil.Estruct (fsel, _) ->
lookup_fld fsel f
| Some _ ->
if !verbose then (L.d_str "lookup: case not matched on Ddot "; L.d_ln ());
None)
| Sil.Dpvar pvar ->
if !verbose then (L.d_str "lookup: found Dpvar "; L.d_ln ());
(find_ptsto (Sil.Lvar pvar))
| Sil.Dderef de ->
(match lookup de with
| None -> None
| Some (Sil.Eexp (e, _)) -> find_ptsto e
| Some _ -> None)
| None -> None
| Some (Sil.Eexp (e, _)) -> find_ptsto e
| Some _ -> None)
| (Sil.Dbinop(Sil.PlusPI, Sil.Dpvar pvar, Sil.Dconst c) 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 *)
Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Sil.line))
| _ -> None)
| Sil.Cfun pn -> (* Treat function as an update *)
Some (Sil.Eexp (Sil.Const c, Sil.Ireturn_from_call loc.Sil.line))
| _ -> None)
| de ->
if !verbose then (L.d_strln ("lookup: unknown case not matched " ^ Sil.dexp_to_string de));
None in
@ -749,17 +749,17 @@ let create_dereference_desc
| Some (Sil.Dpvar pvar)
| Some (Sil.Dpvaraddr pvar) ->
(match Prop.get_objc_null_attribute prop (Sil.Lvar pvar) with
| Some (Sil.Aobjc_null info) -> Localise.parameter_field_not_null_checked_desc desc info
| _ -> desc)
| Some (Sil.Aobjc_null info) -> Localise.parameter_field_not_null_checked_desc desc info
| _ -> desc)
| _ -> desc
else desc in
if use_buckets then Buckets.classify_access desc access_opt' de_opt is_nullable
else desc
(** explain memory access performed by the current instruction
if outermost_array is true, the outermost array access is removed
if outermost_dereference is true, stop at the outermost dereference
(skipping e.g. outermost field access) *)
if outermost_array is true, the outermost array access is removed
if outermost_dereference is true, stop at the outermost dereference
(skipping e.g. outermost field access) *)
let _explain_access
?use_buckets: (use_buckets = false)
?outermost_array: (outermost_array = false)
@ -824,7 +824,7 @@ let _explain_access
de_opt deref_str prop loc
(** Produce a description of which expression is dereferenced in the current instruction, if any.
The subexpression to focus on is obtained by removing field and index accesses. *)
The subexpression to focus on is obtained by removing field and index accesses. *)
let explain_dereference
?use_buckets: (use_buckets = false)
?is_nullable: (is_nullable = false)
@ -835,7 +835,7 @@ let explain_dereference
deref_str prop loc
(** Produce a description of the array access performed in the current instruction, if any.
The subexpression to focus on is obtained by removing the outermost array access. *)
The subexpression to focus on is obtained by removing the outermost array access. *)
let explain_array_access deref_str prop loc =
_explain_access ~outermost_array: true deref_str prop loc
@ -859,21 +859,21 @@ let dexp_apply_pvar_off dexp pvar_off =
| Fstruct [] -> dexp (* case should not happen *)
(** Produce a description of the nth parameter of the function call, if the current instruction
is a function call with that parameter *)
is a function call with that parameter *)
let explain_nth_function_parameter use_buckets deref_str prop n pvar_off =
let node = State.get_node () in
let loc = State.get_loc () in
match State.get_instr () with
| Some Sil.Call (_, _, args, _, _) ->
(try
let arg = fst (list_nth args (n - 1)) in
let dexp_opt = exp_rv_dexp node arg in
let dexp_opt' = match dexp_opt with
| Some de ->
Some (dexp_apply_pvar_off de pvar_off)
| None -> None in
create_dereference_desc ~use_buckets dexp_opt' deref_str prop loc
with exn when exn_not_timeout exn -> Localise.no_desc)
let arg = fst (list_nth args (n - 1)) in
let dexp_opt = exp_rv_dexp node arg in
let dexp_opt' = match dexp_opt with
| Some de ->
Some (dexp_apply_pvar_off de pvar_off)
| None -> None in
create_dereference_desc ~use_buckets dexp_opt' deref_str prop loc
with exn when exn_not_timeout exn -> Localise.no_desc)
| _ -> Localise.no_desc
(** Find a program variable whose value is [exp] or pointing to a struct containing [exp] *)
@ -902,7 +902,7 @@ let find_pvar_with_exp prop exp =
!res
(** return a description explaining value [exp] in [prop] in terms of a source expression
using the formal parameters of the call *)
using the formal parameters of the call *)
let explain_dereference_as_caller_expression
?use_buckets: (use_buckets = false)
deref_str actual_pre spec_pre exp node loc formal_params =

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

@ -55,8 +55,8 @@ module ErrLogHash = Hashtbl.Make (struct
end)
(** Type of the error log, to be reset once per function.
Map err_kind, fotprint / re - execution flag, error name,
error description, severity, to set of err_data. *)
Map err_kind, fotprint / re - execution flag, error name,
error description, severity, to set of err_data. *)
type t = ErrDataSet.t ErrLogHash.t
(** Empty error log *)
@ -70,19 +70,19 @@ type iter_fun =
(** Apply f to nodes and error names *)
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, mloco, ltr, pre_opt, eclass) ->
f
node_id_key loc ekind in_footprint err_name
desc severity ltr pre_opt eclass)
set)
ErrDataSet.iter
(fun (node_id_key, section, loc, mloco, ltr, pre_opt, eclass) ->
f
node_id_key loc ekind in_footprint err_name
desc severity ltr pre_opt eclass)
set)
err_log
(** Return the number of elements in the error log which satisfy [filter] *)
let size filter (err_log: t) =
let count = ref 0 in
ErrLogHash.iter (fun (ekind, in_footprint, _, _, _) eds ->
if filter ekind in_footprint then count := !count + (ErrDataSet.cardinal eds)) err_log;
if filter ekind in_footprint then count := !count + (ErrDataSet.cardinal eds)) err_log;
!count
(** Print an error log *)
@ -125,7 +125,7 @@ let severity_to_str severity = match severity with
| Exceptions.Low -> "LOW"
(** Add an error description to the error log unless there is
one already at the same node + session; return true if added *)
one already at the same node + session; return true if added *)
let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataSet.t) : bool =
try
let current_eds = ErrLogHash.find tbl (ekind, in_footprint, err_name, desc, severity) in
@ -138,16 +138,16 @@ let add_issue tbl (ekind, in_footprint, err_name, desc, severity) (eds: ErrDataS
true
end
with Not_found ->
begin
ErrLogHash.add tbl (ekind, in_footprint, err_name, desc, severity) eds;
true
end
begin
ErrLogHash.add tbl (ekind, in_footprint, err_name, desc, severity) eds;
true
end
(** Update an old error log with a new one *)
let update errlog_old errlog_new =
ErrLogHash.iter
(fun (ekind, infp, s, desc, severity) l ->
ignore (add_issue errlog_old (ekind, infp, s, desc, severity) l)) errlog_new
ignore (add_issue errlog_old (ekind, infp, s, desc, severity) l)) errlog_new
let log_issue _ekind err_log loc node_id_key session ltr pre_opt exn =
@ -237,26 +237,26 @@ module Err_table = struct
let err_list = LocMap.find nslm !map in
map := LocMap.add nslm ((err_name, desc) :: err_list) !map
with Not_found ->
map := LocMap.add nslm [(err_name, desc)] !map in
map := LocMap.add nslm [(err_name, desc)] !map in
let f err_name eds =
ErrDataSet.iter (fun loc -> add_err loc err_name) eds in
ErrLogHash.iter f err_table;
let pp ekind (nodeidkey, session, loc, mloco, ltr, pre_opt, eclass) fmt err_names =
list_iter (fun (err_name, desc) ->
Exceptions.pp_err nodeidkey loc ekind err_name desc mloco fmt ()) err_names in
Exceptions.pp_err nodeidkey loc ekind err_name desc mloco fmt ()) err_names in
F.fprintf fmt "@.Detailed errors during footprint phase:@.";
LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp;
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_fp;
F.fprintf fmt "@.Detailed errors during re-execution phase:@.";
LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re;
F.fprintf fmt "%a" (pp Exceptions.Kerror nslm) err_names) !map_err_re;
F.fprintf fmt "@.Detailed warnings during footprint phase:@.";
LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp;
F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_fp;
F.fprintf fmt "@.Detailed warnings during re-execution phase:@.";
LocMap.iter (fun nslm err_names ->
F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re
F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re
end
type err_table = Err_table.t

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

@ -27,10 +27,10 @@ type file_data =
(** get the path to the tenv file, which either one tenv file per source file or a global tenv file *)
let tenv_filename file_base =
let per_source_tenv_filename = DB.filename_add_suffix file_base ".tenv" in
if Sys.file_exists (DB.filename_to_string per_source_tenv_filename) then
per_source_tenv_filename
else
DB.global_tenv_fname ()
if Sys.file_exists (DB.filename_to_string per_source_tenv_filename) then
per_source_tenv_filename
else
DB.global_tenv_fname ()
(** create a new file_data *)
let new_file_data source nLOC cg_fname =
@ -90,14 +90,14 @@ let add_callee (exe_env: t) (source_file : DB.source_file) (pname: Procname.t) =
let file_data_opt =
try Some (Hashtbl.find exe_env.file_map source_file)
with Not_found ->
let source_dir = DB.source_dir_from_source_file source_file in
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
(match Cg.load_from_file cg_fname with
| None -> None
| Some cg ->
let nLOC = Cg.get_nLOC cg in
let file_data = new_file_data source_file nLOC cg_fname in
Some file_data) in
let source_dir = DB.source_dir_from_source_file source_file in
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
(match Cg.load_from_file cg_fname with
| None -> None
| Some cg ->
let nLOC = Cg.get_nLOC cg in
let file_data = new_file_data source_file nLOC cg_fname in
Some file_data) in
match file_data_opt with
| None -> ()
| Some file_data ->
@ -120,14 +120,14 @@ let add_cg_exclude_fun (exe_env: t) (source_dir : DB.source_dir) exclude_fun =
let file_data = new_file_data source nLOC cg_fname in
let defined_procs = Cg.get_defined_nodes cg in
list_iter (fun pname ->
let should_update =
if Procname.Hash.mem exe_env.proc_map pname then
let old_source = (Procname.Hash.find exe_env.proc_map pname).source in
exe_env.procs_defined_in_several_files <- Procname.Set.add pname exe_env.procs_defined_in_several_files;
(* L.err "Warning: procedure %a is defined in both %s and %s@." Procname.pp pname (DB.source_file_to_string source) (DB.source_file_to_string old_source); *)
source < old_source (* when a procedure is defined in several files, map to the first alphabetically *)
else true in
if should_update then Procname.Hash.replace exe_env.proc_map pname file_data) defined_procs;
let should_update =
if Procname.Hash.mem exe_env.proc_map pname then
let old_source = (Procname.Hash.find exe_env.proc_map pname).source in
exe_env.procs_defined_in_several_files <- Procname.Set.add pname exe_env.procs_defined_in_several_files;
(* L.err "Warning: procedure %a is defined in both %s and %s@." Procname.pp pname (DB.source_file_to_string source) (DB.source_file_to_string old_source); *)
source < old_source (* when a procedure is defined in several files, map to the first alphabetically *)
else true in
if should_update then Procname.Hash.replace exe_env.proc_map pname file_data) defined_procs;
Hashtbl.add exe_env.file_map source file_data;
Some cg
@ -160,8 +160,8 @@ let get_file_data exe_env pname =
try
Procname.Hash.find exe_env.proc_map pname
with Not_found ->
L.err "can't find tenv_cfg_object for %a@." Procname.pp pname;
raise Not_found
L.err "can't find tenv_cfg_object for %a@." Procname.pp pname;
raise Not_found
(** return the source file associated to the procedure *)
let get_source exe_env pname =

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

@ -137,8 +137,8 @@ module Process_fork : Process_signature = struct
let (summ : Specs.summary) = Marshal.from_channel p_str.c2p_in in
(p_str, summ)
with Not_found ->
L.err "@.ERROR: process %d was killed while trying to communicate with the parent@." sender_pid;
receive_from_child () (* wait for communication from the next process *)
L.err "@.ERROR: process %d was killed while trying to communicate with the parent@." sender_pid;
receive_from_child () (* wait for communication from the next process *)
let receive_from_parent p_str : val_t =
Marshal.from_channel p_str.p2c_in
@ -290,20 +290,20 @@ let compute_weighed_pnameset gr =
!pnameset
(* Return true if there are no children of [pname] whose specs
have changed since [pname] was last analyzed. *)
have changed since [pname] was last analyzed. *)
let proc_is_up_to_date gr pname =
match Specs.get_summary pname with
| None -> false
| Some summary ->
let filter dependent_proc = Specs.get_timestamp summary =
Procname.Map.find dependent_proc summary.Specs.dependency_map in
Procname.Map.find dependent_proc summary.Specs.dependency_map in
let res =
Specs.is_inactive pname &&
Procname.Set.for_all filter (Cg.get_defined_children gr pname) in
res
(** Return the list of procedures which should perform a phase
transition from [FOOTPRINT] to [RE_EXECUTION] *)
transition from [FOOTPRINT] to [RE_EXECUTION] *)
let should_perform_transition gr proc_name : Procname.t list =
let recursive_dependents = Cg.get_recursive_dependents gr proc_name in
let recursive_dependents_plus_self = Procname.Set.add proc_name recursive_dependents in
@ -332,10 +332,10 @@ let transition_footprint_re_exe proc_name joined_pres =
let specs =
list_map
(fun jp ->
Specs.spec_normalize
{ Specs.pre = jp;
Specs.posts = [];
Specs.visited = Specs.Visitedset.empty })
Specs.spec_normalize
{ Specs.pre = jp;
Specs.posts = [];
Specs.visited = Specs.Visitedset.empty })
joined_pres in
Specs.PrePosts specs
} in
@ -355,11 +355,11 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
let current_specs =
ref
(list_fold_left
(fun map spec ->
SpecMap.add
spec.Specs.pre
(Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map)
SpecMap.empty old_specs) in
(fun map spec ->
SpecMap.add
spec.Specs.pre
(Paths.PathSet.from_renamed_list spec.Specs.posts, spec.Specs.visited) map)
SpecMap.empty old_specs) in
let re_exe_filter old_spec = (* filter out pres which failed re-exe *)
if phase == Specs.RE_EXECUTION && not (list_exists (fun new_spec -> Specs.Jprop.equal new_spec.Specs.pre old_spec.Specs.pre) new_specs)
then begin
@ -381,9 +381,9 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
current_specs := SpecMap.add spec.Specs.pre (new_post, new_visited) (SpecMap.remove spec.Specs.pre !current_specs) end
with Not_found ->
changed := true;
L.out "Specs changed: added new pre@\n%a@." (Specs.Jprop.pp_short pe_text) spec.Specs.pre;
current_specs :=
changed := true;
L.out "Specs changed: added new pre@\n%a@." (Specs.Jprop.pp_short pe_text) spec.Specs.pre;
current_specs :=
SpecMap.add
spec.Specs.pre
((Paths.PathSet.from_renamed_list spec.Specs.posts), spec.Specs.visited)
@ -391,10 +391,10 @@ let update_specs proc_name (new_specs : Specs.NormSpec.t list) : Specs.NormSpec.
let res = ref [] in
let convert pre (post_set, visited) =
res :=
Specs.spec_normalize
{ Specs.pre = pre;
Specs.posts = Paths.PathSet.elements post_set;
Specs.visited = visited }:: !res in
Specs.spec_normalize
{ Specs.pre = pre;
Specs.posts = Paths.PathSet.elements post_set;
Specs.visited = visited }:: !res in
list_iter re_exe_filter old_specs; (* filter out pre's which failed re-exe *)
list_iter add_spec new_specs; (* add new specs *)
SpecMap.iter convert !current_specs;
@ -420,10 +420,10 @@ let procs_become_done gr pname : Procname.t list =
let nonrecursive_dependents = Cg.get_nonrecursive_dependents gr pname in
let summary = Specs.get_summary_unsafe pname in
let is_done = Specs.get_timestamp summary <> 0 &&
Specs.is_inactive pname &&
(!Config.only_footprint || Specs.get_phase pname == Specs.RE_EXECUTION) &&
Procname.Set.for_all (proc_is_done gr) nonrecursive_dependents &&
Procname.Set.for_all (proc_is_up_to_date gr) recursive_dependents in
Specs.is_inactive pname &&
(!Config.only_footprint || Specs.get_phase pname == Specs.RE_EXECUTION) &&
Procname.Set.for_all (proc_is_done gr) nonrecursive_dependents &&
Procname.Set.for_all (proc_is_up_to_date gr) recursive_dependents in
if !trace then L.err "proc is%s done@." (if is_done then "" else " not");
if is_done
then
@ -441,30 +441,30 @@ let post_process_procs exe_env procs_done =
end in
let cg = Exe_env.get_cg exe_env in
list_iter (fun pn ->
let elem = (pn, Cg.get_calls cg pn) in
if WeightedPnameSet.mem elem !wpnames_todo then
begin
incr num_procs_done;
wpnames_todo := WeightedPnameSet.remove (pn, Cg.get_calls cg pn) !wpnames_todo;
let whole_seconds = false in
check_no_specs pn;
Printer.proc_write_log whole_seconds (Exe_env.get_cfg exe_env pn) pn
end
let elem = (pn, Cg.get_calls cg pn) in
if WeightedPnameSet.mem elem !wpnames_todo then
begin
incr num_procs_done;
wpnames_todo := WeightedPnameSet.remove (pn, Cg.get_calls cg pn) !wpnames_todo;
let whole_seconds = false in
check_no_specs pn;
Printer.proc_write_log whole_seconds (Exe_env.get_cfg exe_env pn) pn
end
) procs_done
(** Activate a check which ensures that multi-core mode gives the same result as one-core.
If true, detect when a dependent proc is active (analyzed concurrently)
and in that case wait for a process to terminate next *)
If true, detect when a dependent proc is active (analyzed concurrently)
and in that case wait for a process to terminate next *)
let one_core_compatibility_mode = ref true
(** Find the max string in the [set] which satisfies [filter], and count the number of attempts.
Precedence is given to strings in [priority_set] *)
Precedence is given to strings in [priority_set] *)
let filter_max exe_env cg filter set priority_set =
let rec find_max n filter set =
let elem = WeightedPnameSet.max_elt set in
let check_one_core_compatibility () =
if !one_core_compatibility_mode &&
Procname.Set.exists (fun child -> Specs.is_active child) (Cg.get_dependents cg (fst elem))
Procname.Set.exists (fun child -> Specs.is_active child) (Cg.get_dependents cg (fst elem))
then raise Not_found in
check_one_core_compatibility ();
if filter elem then
@ -499,8 +499,8 @@ end = struct
match Config.os_type with
| Config.Unix | Config.Cygwin ->
ignore (Unix.setitimer Unix.ITIMER_REAL
{ Unix.it_interval = 3.0; (* try again after 3 seconds if the signal is lost *)
Unix.it_value = float_of_int nsecs })
{ Unix.it_interval = 3.0; (* try again after 3 seconds if the signal is lost *)
Unix.it_value = float_of_int nsecs })
| Config.Win32 ->
SymOp.set_wallclock_alarm nsecs
@ -522,14 +522,14 @@ end = struct
raise (Timeout_exe (TOtime))
let () = begin
match Config.os_type with
| Config.Unix | Config.Cygwin ->
Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action);
Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action)
| Config.Win32 ->
SymOp.set_wallclock_timeout_handler timeout_action;
ignore (Gc.create_alarm SymOp.check_wallclock_alarm) (* use the Gc alarm for periodic timeout checks *)
end
match Config.os_type with
| Config.Unix | Config.Cygwin ->
Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action);
Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action)
| Config.Win32 ->
SymOp.set_wallclock_timeout_handler timeout_action;
ignore (Gc.create_alarm SymOp.check_wallclock_alarm) (* use the Gc alarm for periodic timeout checks *)
end
let exe_timeout iterations f x =
try
@ -555,8 +555,8 @@ end
module Process = Process_fork
(** Main algorithm responsible for driving the analysis of an Exe_env (set of procedures).
The algorithm computes dependencies between procedures, spawns processes if required,
propagates results, and handles fixpoints in the call graph. *)
The algorithm computes dependencies between procedures, spawns processes if required,
propagates results, and handles fixpoints in the call graph. *)
let parallel_execution exe_env num_processes analyze_proc filter_out process_result : unit =
parallel_mode := num_processes > 1 || !Config.max_num_proc > 0;
let call_graph = Exe_env.get_cg exe_env in
@ -579,7 +579,7 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res
Procname.Set.for_all
(fun child -> Specs.is_inactive child) (Cg.get_defined_children call_graph pname) &&
(Specs.get_timestamp (Specs.get_summary_unsafe pname) = 0
|| not (proc_is_up_to_date call_graph pname)) in
|| not (proc_is_up_to_date call_graph pname)) in
let process_one_proc pname (calls: Cg.in_out_calls) =
DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file;
if !trace then
@ -634,9 +634,9 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res
| Some (p_str, summ) ->
let (pname, weight) = Process.get_last_input p_str in
(try
DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file;
process_result exe_env (pname, weight) summ
with exn -> assert false);
DB.current_source := (Specs.get_summary_unsafe pname).Specs.loc.Sil.file;
process_result exe_env (pname, weight) summ
with exn -> assert false);
Timing_log.event_finish (Procname.to_string pname);
Process.kill_process p_str;
incr avail_num
@ -654,21 +654,21 @@ let parallel_execution exe_env num_processes analyze_proc filter_out process_res
let pname, calls = filter_max exe_env call_graph wpname_can_be_analyzed !wpnames_todo wpnames_address_of in (** find max analyzable proc *)
process_one_proc pname calls
with Not_found -> (* no analyzable procs *)
if !avail_num < num_processes (* some other process is doing work *)
then wait_for_next_result ()
else
(L.err "Error: can't analyze any procs. Printing current spec table@\n@[<v>%a@]@." (Specs.pp_spec_table pe_text false) ();
raise (Failure "Stopping"))
if !avail_num < num_processes (* some other process is doing work *)
then wait_for_next_result ()
else
(L.err "Error: can't analyze any procs. Printing current spec table@\n@[<v>%a@]@." (Specs.pp_spec_table pe_text false) ();
raise (Failure "Stopping"))
end
else
wait_for_next_result ()
done
(** [parallel_iter_nodes cfg call_graph analyze_proc process_result filter_out]
executes [analyze_proc] in parallel as much as possible as allowed
by the call graph, and applies [process_result] to the result as
soon as it is returned by a child process. If [filter_out] returns
true, no execution. *)
executes [analyze_proc] in parallel as much as possible as allowed
by the call graph, and applies [process_result] to the result as
soon as it is returned by a child process. If [filter_out] returns
true, no execution. *)
let parallel_iter_nodes (exe_env: Exe_env.t) (_analyze_proc: Exe_env.t -> Procname.t -> 'a) (_process_result: Exe_env.t -> (Procname.t * Cg.in_out_calls) -> 'a -> unit) (filter_out: Cg.t -> Procname.t -> bool) : unit =
let analyze_proc exe_env pname = (* wrap _analyze_proc and handle exceptions *)
try _analyze_proc exe_env pname with

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

@ -73,10 +73,10 @@ let ident_list_equal ids1 ids2 = (ident_list_compare ids1 ids2 = 0)
(** {2 Set for identifiers} *)
module IdentSet = Set.Make
(struct
type t = _ident
let compare = compare
end)
(struct
type t = _ident
let compare = compare
end)
module IdentHash =
Hashtbl.Make(struct
@ -86,14 +86,14 @@ module IdentHash =
end)
module FieldSet = Set.Make(struct
type t = fieldname
let compare = fieldname_compare
end)
type t = fieldname
let compare = fieldname_compare
end)
module FieldMap = Map.Make(struct
type t = fieldname
let compare = fieldname_compare
end)
type t = fieldname
let compare = fieldname_compare
end)
let idlist_to_idset ids =
list_fold_left (fun set id -> IdentSet.add id set) IdentSet.empty ids
@ -136,8 +136,8 @@ 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
| _ -> s)
| Some s3, s4 -> s4 ^ "." ^ s2
| _ -> s)
| _ -> s
(** Convert a fieldname to a flat string without path. *)
@ -221,7 +221,7 @@ let create_with_stamp kind name stamp =
let new_stamp = max curr_stamp stamp in
NameHash.replace name_map name new_stamp
with Not_found ->
NameHash.add name_map name stamp in
NameHash.add name_map name stamp in
update_name_hash ();
{ kind = kind; name = name; stamp = stamp }
@ -290,8 +290,8 @@ let create_fresh_ident kind name =
NameHash.replace name_map name (stamp + 1);
stamp + 1
with Not_found ->
NameHash.add name_map name 0;
0 in
NameHash.add name_map name 0;
0 in
{ kind = kind; name = name; stamp = stamp }
(** Create a fresh identifier with default name for the given kind. *)

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

@ -93,9 +93,9 @@ let objc_ml_buckets_arg = ref "cf"
let allow_specs_cleanup = ref false
(** Compute the exclude function from excluded_files and source_path.
The exclude function builds an exclude list of file path prefixes, and checks if one
of them is a prefix of the given source file.
Prefixes are obtained by prepending source_path, if any, to relative paths in excluded_fies *)
The exclude function builds an exclude list of file path prefixes, and checks if one
of them is a prefix of the given source file.
Prefixes are obtained by prepending source_path, if any, to relative paths in excluded_fies *)
let compute_exclude_fun () : DB.source_file -> bool =
let prepend_source_path s =
if Filename.is_relative s then Filename.concat !source_path s
@ -133,53 +133,53 @@ let arg_desc =
let desc =
base_arg_desc @
[
"-err_file", Arg.Set_string err_file_cmdline, Some "file", "use file for the err channel";
"-exclude", Arg.String exclude, Some "file", "exclude from analysis the files and directories specified in file";
"-incremental_ignore_dependencies", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_ONLY), None, "only analyze files captured since the last analysis";
"-incremental", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_AND_DEPENDENCIES), None, "analyze files captured since the last analysis plus any dependencies";
"-iterations", Arg.Set_int iterations_cmdline, Some "n", "set the max number of operations for each function, expressed as a multiple of symbolic operations (default n=1)";
"-nonstop", Arg.Set Config.nonstop, None, "activate the nonstop mode: the analysis continues after finding errors. With this option the analysis can become less precise.";
"-out_file", Arg.Set_string out_file_cmdline, Some "file", "use file for the out channel";
"-print_builtins", Arg.Unit SymExec.print_builtins, None, "print the builtin functions and exit";
"-source_path", Arg.String source_path, Some "path", "specify the absolute path to the root of the source files. Used to interpret relative paths when using option -exclude.";
(* TODO: merge with the -project_root option *)
"-java", Arg.Unit (fun () -> Sil.curr_language := Sil.Java), None, "Set language to Java";
"-version", Arg.Unit print_version, None, "print version information and exit";
"-version_json", Arg.Unit print_version_json, None, "print version json formatted";
"-objcm", Arg.Set Config.objc_memory_model_on, None, "Use ObjC memory model";
"-objc_ml_buckets", Arg.Set_string objc_ml_buckets_arg, Some "objc_ml_buckets",
"memory leak buckets to be checked, separated by commas. The possible buckets are cf (Core Foundation), arc, narc (No arc)";
"-err_file", Arg.Set_string err_file_cmdline, Some "file", "use file for the err channel";
"-exclude", Arg.String exclude, Some "file", "exclude from analysis the files and directories specified in file";
"-incremental_ignore_dependencies", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_ONLY), None, "only analyze files captured since the last analysis";
"-incremental", Arg.Unit (fun () -> incremental_mode := ANALYZE_CHANGED_AND_DEPENDENCIES), None, "analyze files captured since the last analysis plus any dependencies";
"-iterations", Arg.Set_int iterations_cmdline, Some "n", "set the max number of operations for each function, expressed as a multiple of symbolic operations (default n=1)";
"-nonstop", Arg.Set Config.nonstop, None, "activate the nonstop mode: the analysis continues after finding errors. With this option the analysis can become less precise.";
"-out_file", Arg.Set_string out_file_cmdline, Some "file", "use file for the out channel";
"-print_builtins", Arg.Unit SymExec.print_builtins, None, "print the builtin functions and exit";
"-source_path", Arg.String source_path, Some "path", "specify the absolute path to the root of the source files. Used to interpret relative paths when using option -exclude.";
(* TODO: merge with the -project_root option *)
"-java", Arg.Unit (fun () -> Sil.curr_language := Sil.Java), None, "Set language to Java";
"-version", Arg.Unit print_version, None, "print version information and exit";
"-version_json", Arg.Unit print_version_json, None, "print version json formatted";
"-objcm", Arg.Set Config.objc_memory_model_on, None, "Use ObjC memory model";
"-objc_ml_buckets", Arg.Set_string objc_ml_buckets_arg, Some "objc_ml_buckets",
"memory leak buckets to be checked, separated by commas. The possible buckets are cf (Core Foundation), arc, narc (No arc)";
] in
Arg2.create_options_desc false "Analysis Options" desc in
let reserved_arg =
let desc =
reserved_arg_desc @
[
"-analysis_stops", Arg.Set Config.analysis_stops, None, "issue a warning when the analysis stops";
"-angelic_execution", Arg.Set Config.angelic_execution, None, "activate angelic execution: the analysis ignores errors caused by unknown procedure calls.";
"-checkers", Arg.Set checkers, None, " run only the checkers instead of the full analysis";
"-cluster", Arg.String (fun s -> cluster_cmdline := Some s), Some "fname", "specify a .cluster file to be analyzed";
"-codequery", Arg.String (fun s -> CodeQuery.query := Some s), Some "query", " execute the code query";
"-eradicate", Arg.Set Config.eradicate, None, " activate the eradicate checker for java annotations";
"-file", Arg.String (fun s -> only_files_cmdline := s :: !only_files_cmdline), Some "fname", "specify one file to be analyzed (without path); the option can be repeated";
"-intraprocedural", Arg.Set Config.intraprocedural, None, "perform an intraprocedural analysis only";
"-makefile", Arg.Set_string makefile_cmdline, Some "file", "create a makefile to perform the analysis";
"-max_cluster", Arg.Set_int Config.max_cluster_size, Some "n", "set the max number of procedures in each cluster (default n=2000)";
"-only_nospecs", Arg.Set Config.only_nospecs, None, " only analyze procedures which were analyzed before but have no specs";
"-only_skips", Arg.Set Config.only_skips, None, " only analyze procedures dependent on previous skips which now have a .specs file";
"-seconds_per_iteration", Arg.Set_int seconds_per_iteration, Some "n", "set the number of seconds per iteration (default n=30)";
"-simulate", Arg.Set simulate, None, " run a simulation of the analysis only";
"-subtype_multirange", Arg.Set Config.subtype_multirange, None, "use the multirange subtyping domain";
"-optimistic_cast", Arg.Set Config.optimistic_cast, None, "allow cast of undefined values";
"-select_proc", Arg.String (fun s -> select_proc := Some s), Some "string", "only consider procedures whose name contains the given string";
"-symops_per_iteration", Arg.Set_int symops_per_iteration, Some "n", "set the number of symbolic operations per iteration (default n="^(string_of_int !symops_per_iteration)^")";
"-type_size", Arg.Set Config.type_size, None, "consider the size of types during analysis";
"-tracing", Arg.Unit (fun () -> Config.report_runtime_exceptions := true), None,
"Report error traces for runtime exceptions (Only for Java)";
"-allow_specs_cleanup", Arg.Unit (fun () -> allow_specs_cleanup := true), None,
"Allow to remove existing specs before running analysis when it's not incremental";
"-print_buckets", Arg.Unit (fun() -> Config.show_buckets := true; Config.show_ml_buckets := true), None,
"Add buckets to issue descriptions, useful when developing infer"
"-analysis_stops", Arg.Set Config.analysis_stops, None, "issue a warning when the analysis stops";
"-angelic_execution", Arg.Set Config.angelic_execution, None, "activate angelic execution: the analysis ignores errors caused by unknown procedure calls.";
"-checkers", Arg.Set checkers, None, " run only the checkers instead of the full analysis";
"-cluster", Arg.String (fun s -> cluster_cmdline := Some s), Some "fname", "specify a .cluster file to be analyzed";
"-codequery", Arg.String (fun s -> CodeQuery.query := Some s), Some "query", " execute the code query";
"-eradicate", Arg.Set Config.eradicate, None, " activate the eradicate checker for java annotations";
"-file", Arg.String (fun s -> only_files_cmdline := s :: !only_files_cmdline), Some "fname", "specify one file to be analyzed (without path); the option can be repeated";
"-intraprocedural", Arg.Set Config.intraprocedural, None, "perform an intraprocedural analysis only";
"-makefile", Arg.Set_string makefile_cmdline, Some "file", "create a makefile to perform the analysis";
"-max_cluster", Arg.Set_int Config.max_cluster_size, Some "n", "set the max number of procedures in each cluster (default n=2000)";
"-only_nospecs", Arg.Set Config.only_nospecs, None, " only analyze procedures which were analyzed before but have no specs";
"-only_skips", Arg.Set Config.only_skips, None, " only analyze procedures dependent on previous skips which now have a .specs file";
"-seconds_per_iteration", Arg.Set_int seconds_per_iteration, Some "n", "set the number of seconds per iteration (default n=30)";
"-simulate", Arg.Set simulate, None, " run a simulation of the analysis only";
"-subtype_multirange", Arg.Set Config.subtype_multirange, None, "use the multirange subtyping domain";
"-optimistic_cast", Arg.Set Config.optimistic_cast, None, "allow cast of undefined values";
"-select_proc", Arg.String (fun s -> select_proc := Some s), Some "string", "only consider procedures whose name contains the given string";
"-symops_per_iteration", Arg.Set_int symops_per_iteration, Some "n", "set the number of symbolic operations per iteration (default n="^(string_of_int !symops_per_iteration)^")";
"-type_size", Arg.Set Config.type_size, None, "consider the size of types during analysis";
"-tracing", Arg.Unit (fun () -> Config.report_runtime_exceptions := true), None,
"Report error traces for runtime exceptions (Only for Java)";
"-allow_specs_cleanup", Arg.Unit (fun () -> allow_specs_cleanup := true), None,
"Allow to remove existing specs before running analysis when it's not incremental";
"-print_buckets", Arg.Unit (fun() -> Config.show_buckets := true; Config.show_ml_buckets := true), None,
"Add buckets to issue descriptions, useful when developing infer"
] in
Arg2.create_options_desc false "Reserved Options: Experimental features, use with caution!" desc in
base_arg @ reserved_arg
@ -210,7 +210,7 @@ module Simulator = struct (** Simulate the analysis only *)
(Cg.get_nodes_and_calls cg)
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for
the procedures enabled after the analysis of [proc_name] *)
the procedures enabled after the analysis of [proc_name] *)
let perform_transition exe_env proc_name =
let proc_names = Fork.should_perform_transition (Exe_env.get_cg exe_env) proc_name in
let f proc_name =
@ -242,23 +242,23 @@ let analyze exe_env =
Random.self_init ();
let line_reader = Printer.LineReader.create () in
if !checkers then (* run the checkers only *)
begin
let call_graph = Exe_env.get_cg exe_env in
Callbacks.iterate_callbacks Checkers.ST.store_summary call_graph exe_env
end
begin
let call_graph = Exe_env.get_cg exe_env in
Callbacks.iterate_callbacks Checkers.ST.store_summary call_graph exe_env
end
else if !simulate then (* simulate the analysis *)
begin
Simulator.reset_summaries (Exe_env.get_cg exe_env);
Fork.parallel_iter_nodes exe_env (Simulator.analyze_proc exe_env) Simulator.process_result Simulator.filter_out
end
begin
Simulator.reset_summaries (Exe_env.get_cg exe_env);
Fork.parallel_iter_nodes exe_env (Simulator.analyze_proc exe_env) Simulator.process_result Simulator.filter_out
end
else (* full analysis *)
begin
Interproc.do_analysis exe_env;
Printer.c_files_write_html line_reader exe_env;
Interproc.print_stats exe_env;
let elapsed = Unix.gettimeofday () -. init_time in
L.out "Interprocedural footprint analysis terminated in %f sec@." elapsed
end
begin
Interproc.do_analysis exe_env;
Printer.c_files_write_html line_reader exe_env;
Interproc.print_stats exe_env;
let elapsed = Unix.gettimeofday () -. init_time in
L.out "Interprocedural footprint analysis terminated in %f sec@." elapsed
end
(** add [x] to list [l] at position [nth] *)
let list_add_nth x l nth =
@ -270,7 +270,7 @@ let list_add_nth x l nth =
add [] l nth
(** sort a list weakly w.r.t. a compare function which doest not have to be a total order
the number returned by [compare x y] indicates 'how strongly' x should come before y *)
the number returned by [compare x y] indicates 'how strongly' x should come before y *)
let weak_sort compare list =
let weak_add l x =
let length = list_length l in
@ -280,14 +280,14 @@ let weak_sort compare list =
let best_value = ref (fitness.(0)) in
let i = ref 0 in
list_iter (fun y ->
incr i;
let new_value = fitness.(!i - 1) - (compare x y) + (compare y x) in
fitness.(!i) <- new_value;
if new_value < !best_value then
begin
best_value := new_value;
best_position := !i
end)
incr i;
let new_value = fitness.(!i - 1) - (compare x y) + (compare y x) in
fitness.(!i) <- new_value;
if new_value < !best_value then
begin
best_value := new_value;
best_position := !i
end)
l;
list_add_nth x l !best_position in
list_fold_left weak_add [] list
@ -316,8 +316,8 @@ let weak_sort_nodes cg =
weak_sort cmp nodes
(** cluster element: the file name, the number of procedures defined in it, and the list of active procedures
A procedure is active if it is defined only in this file, or if it is defined in several files and this
is the representative file for it (see Exe_env.add_cg) *)
A procedure is active if it is defined only in this file, or if it is defined in several files and this
is the representative file for it (see Exe_env.add_cg) *)
type cluster_elem =
{ ce_file : DB.source_file;
ce_naprocs : int; (** number of active procedures defined in the file *)
@ -364,7 +364,7 @@ let create_minimal_clusters file_cg exe_env (only_analyze : Procname.Set.t optio
match Cg.load_from_file cg_fname with
| None -> { ce_file = source_file; ce_naprocs = 0; ce_active_procs = []; ce_source_map = Procname.Map.empty }
| Some cg ->
(* decide whether a proc is active using pname_to_fname, i.e. whether this is the file associated to it *)
(* decide whether a proc is active using pname_to_fname, i.e. whether this is the file associated to it *)
let proc_is_selected pname = match !select_proc with
| None -> true
| Some pattern_str -> string_is_prefix pattern_str (Procname.to_unique_id pname) in
@ -411,9 +411,9 @@ let create_minimal_clusters file_cg exe_env (only_analyze : Procname.Set.t optio
let cluster, list'' = list_partition (fun node -> Procname.Set.mem node cluster_set) list in
seen := Procname.Set.union !seen cluster_set;
let files_to_analyze = list_filter (fun node ->
match only_analyze with
| None -> true
| Some files_to_analyze -> Procname.Set.mem node files_to_analyze) cluster in
match only_analyze with
| None -> true
| Some files_to_analyze -> Procname.Set.mem node files_to_analyze) cluster in
if files_to_analyze <> [] then
begin
let cluster = list_map create_cluster_elem files_to_analyze in
@ -553,7 +553,7 @@ module ClusterMakefile = struct
list_iter (fun ce -> file_to_cluster := DB.SourceFileMap.add ce.ce_file !cluster_nr !file_to_cluster) cluster;
list_iter do_file cluster;
pp_cluster_dependency !cluster_nr tot_clusters_nr cluster print_files fmt (IntSet.elements !dependent_clusters);
(* L.err "cluster %d has %d dependencies@." !cluster_nr (IntSet.cardinal !dependent_clusters) *) in
(* L.err "cluster %d has %d dependencies@." !cluster_nr (IntSet.cardinal !dependent_clusters) *) in
pp_prolog fmt tot_clusters_nr;
list_iter do_cluster clusters;
pp_epilog fmt ();
@ -590,12 +590,12 @@ let compute_clusters exe_env (files_changed : Procname.Set.t) : cluster list =
if !incremental_mode != ANALYZE_ALL then
begin
Procname.Set.iter (fun c_file ->
let ancestors =
try Cg.get_ancestors file_cg c_file with
| Not_found ->
L.err "Warning: modified file %s is ignored, all its functions might be already defined in another file@." (Procname.to_string c_file);
Procname.Set.empty in
files_changed_and_dependents := Procname.Set.union ancestors !files_changed_and_dependents) files_changed;
let ancestors =
try Cg.get_ancestors file_cg c_file with
| Not_found ->
L.err "Warning: modified file %s is ignored, all its functions might be already defined in another file@." (Procname.to_string c_file);
Procname.Set.empty in
files_changed_and_dependents := Procname.Set.union ancestors !files_changed_and_dependents) files_changed;
L.err "Number of files changed since the last analysis: %d.@." (Procname.Set.cardinal files_changed)
end
else L.err ".@.";
@ -625,7 +625,7 @@ let compute_clusters exe_env (files_changed : Procname.Set.t) : cluster list =
clusters'
(** Check whether the cg file is changed. It is unchanged if for each defined procedure, the .specs
file exists and is more recent than the cg file. *)
file exists and is more recent than the cg file. *)
let cg_check_changed exe_env source_dir cg =
let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in
let defined_nodes = Cg.get_defined_nodes cg in
@ -637,7 +637,7 @@ let cg_check_changed exe_env source_dir cg =
let spec_fname = Specs.res_dir_specs_filename pname in
if is_active then
changed := (!changed || not (Sys.file_exists (DB.filename_to_string spec_fname)) ||
DB.file_modified_time cg_fname > DB.file_modified_time spec_fname) in
DB.file_modified_time cg_fname > DB.file_modified_time spec_fname) in
list_iter check_needs_update defined_nodes;
!changed
@ -658,13 +658,13 @@ let load_cg_files _exe_env check_changed (source_dirs : DB.source_dir list) excl
let check_cg_changed (source_dir, cg) =
let is_changed = cg_check_changed exe_env source_dir cg in
if is_changed then files_changed :=
Procname.Set.add (source_file_to_pname (Cg.get_source cg)) !files_changed in
Procname.Set.add (source_file_to_pname (Cg.get_source cg)) !files_changed in
list_iter check_cg_changed !cg_list in
list_iter (fun source_dir ->
match load_cg_file _exe_env source_dir exclude_fun with
| None -> ()
| Some cg ->
if check_changed then cg_list := (source_dir, cg) :: !cg_list) sorted_dirs;
match load_cg_file _exe_env source_dir exclude_fun with
| None -> ()
| Some cg ->
if check_changed then cg_list := (source_dir, cg) :: !cg_list) sorted_dirs;
let exe_env = Exe_env.freeze _exe_env in
if check_changed then check_cgs_changed exe_env;
!files_changed, exe_env
@ -706,14 +706,14 @@ let process_cluster_cmdline_exit () =
| None -> ()
| Some fname ->
(match load_cluster_from_file (DB.filename_from_string fname) with
| None ->
L.err "Cannot find cluster file %s@." fname;
exit 0
| Some (nr, tot_nr, cluster) ->
Fork.tot_files_done := (nr - 1) * list_length cluster;
Fork.tot_files := tot_nr * list_length cluster;
analyze_cluster (ref (nr -1)) tot_nr cluster;
exit 0)
| None ->
L.err "Cannot find cluster file %s@." fname;
exit 0
| Some (nr, tot_nr, cluster) ->
Fork.tot_files_done := (nr - 1) * list_length cluster;
Fork.tot_files := tot_nr * list_length cluster;
analyze_cluster (ref (nr -1)) tot_nr cluster;
exit 0)
let open_output_file f fname =
try
@ -722,8 +722,8 @@ let open_output_file f fname =
f fmt;
Some (fmt, cout)
with Sys_error _ ->
Format.fprintf Format.std_formatter "Error: cannot open output file %s@." fname;
exit(-1)
Format.fprintf Format.std_formatter "Error: cannot open output file %s@." fname;
exit(-1)
let close_output_file = function
| None -> ()

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

@ -66,13 +66,13 @@ let load_filters analyzer =
let is_matching patterns =
fun source_file ->
let path = DB.source_file_to_rel_path source_file in
Utils.list_exists
(fun pattern ->
try
(Str.search_forward pattern path 0) = 0
with Not_found -> false)
patterns
let path = DB.source_file_to_rel_path source_file in
Utils.list_exists
(fun pattern ->
try
(Str.search_forward pattern path 0) = 0
with Not_found -> false)
patterns
module FileContainsStringMatcher = struct
type matcher = DB.source_file -> bool
@ -96,16 +96,16 @@ module FileContainsStringMatcher = struct
let regexp =
Str.regexp (join_strings "\\|" s_patterns) in
fun source_file ->
try
DB.SourceFileMap.find source_file !source_map
with Not_found ->
try
DB.SourceFileMap.find source_file !source_map
with Not_found ->
try
let file_in = open_in (DB.source_file_to_string source_file) in
let pattern_found = file_contains regexp file_in in
close_in file_in;
source_map := DB.SourceFileMap.add source_file pattern_found !source_map;
pattern_found
with Sys_error _ -> false
let file_in = open_in (DB.source_file_to_string source_file) in
let pattern_found = file_contains regexp file_in in
close_in file_in;
source_map := DB.SourceFileMap.add source_file pattern_found !source_map;
pattern_found
with Sys_error _ -> false
end
let filters_from_inferconfig inferconfig : filters =
@ -118,13 +118,13 @@ let filters_from_inferconfig inferconfig : filters =
let blacklist_files_containing_filter : path_filter =
FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing in
function source_file ->
whitelist_filter source_file &&
not (blacklist_filter source_file) &&
not (blacklist_files_containing_filter source_file) in
whitelist_filter source_file &&
not (blacklist_filter source_file) &&
not (blacklist_files_containing_filter source_file) in
let error_filter =
function error_name ->
let error_str = Localise.to_string error_name in
not (list_exists (string_equal error_str) inferconfig.suppress_errors) in
let error_str = Localise.to_string error_name in
not (list_exists (string_equal error_str) inferconfig.suppress_errors) in
{
path_filter = path_filter;
error_filter = error_filter;
@ -268,25 +268,25 @@ module NeverReturnNull = struct
let pattern_map =
list_fold_left
(fun map pattern ->
let previous =
try
StringMap.find pattern.class_name map
with Not_found -> [] in
StringMap.add pattern.class_name (pattern:: previous) map)
let previous =
try
StringMap.find pattern.class_name map
with Not_found -> [] in
StringMap.add pattern.class_name (pattern:: previous) map)
StringMap.empty
m_patterns in
fun source_file proc_name ->
let class_name = Procname.java_get_class proc_name
and method_name = Procname.java_get_method proc_name in
try
let class_patterns = StringMap.find class_name pattern_map in
list_exists
(fun p ->
match p.method_name with
| None -> true
| Some m -> string_equal m method_name)
class_patterns
with Not_found -> false
let class_name = Procname.java_get_class proc_name
and method_name = Procname.java_get_method proc_name in
try
let class_patterns = StringMap.find class_name pattern_map in
list_exists
(fun p ->
match p.method_name with
| None -> true
| Some m -> string_equal m method_name)
class_patterns
with Not_found -> false
let create_file_matcher language patterns =
let s_patterns, m_patterns =
@ -301,7 +301,7 @@ module NeverReturnNull = struct
fun source_file proc_name -> matcher source_file
and m_matcher = create_method_matcher language m_patterns in
fun source_file proc_name ->
m_matcher source_file proc_name || s_matcher source_file proc_name
m_matcher source_file proc_name || s_matcher source_file proc_name
let load_matcher language =
try
@ -313,7 +313,7 @@ module NeverReturnNull = struct
list_fold_left translate [] found in
create_file_matcher language patterns
with Sys_error _ ->
default_matcher
default_matcher
end (* of module NeverReturnNull *)
@ -330,14 +330,14 @@ let test () =
[] filters in
Utils.directory_iter
(fun path ->
if DB.is_source_file path then
let source_file = (DB.source_file_from_string path) in
let matching = matching_analyzers source_file in
if matching <> [] then
let matching_s =
Utils.join_strings ", "
(Utils.list_map Utils.string_of_analyzer matching) in
Logging.stderr "%s -> {%s}@."
(DB.source_file_to_rel_path source_file)
matching_s)
if DB.is_source_file path then
let source_file = (DB.source_file_from_string path) in
let matching = matching_analyzers source_file in
if matching <> [] then
let matching_s =
Utils.join_strings ", "
(Utils.list_map Utils.string_of_analyzer matching) in
Logging.stderr "%s -> {%s}@."
(DB.source_file_to_rel_path source_file)
matching_s)
(Sys.getcwd ())

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

@ -91,38 +91,38 @@ let arg_desc =
let base_arg =
let desc =
[
"-bugs", Arg.String (fun s -> bugs_csv := create_outfile s), Some "bugs.csv", "create file bugs.csv containing a list of bugs in CSV format";
"-bugs_json", Arg.String (fun s -> bugs_json := create_outfile s), Some "bugs.json", "create file bugs.json containing a list of bugs in JSON format";
"-bugs_txt", Arg.String (fun s -> bugs_txt := create_outfile s), Some "bugs.txt", "create file bugs.txt containing a list of bugs in text format";
"-bugs_xml", Arg.String (fun s -> bugs_xml := create_outfile s), Some "bugs.xml", "create file bugs.xml containing a list of bugs in XML format";
"-calls", Arg.String (fun s -> calls_csv := create_outfile s), Some "calls.csv", "write individual calls in csv format to file.csv";
"-load_results", Arg.String (fun s -> load_analysis_results := Some s), Some "file.iar", "load analysis results from Infer Analysis Results file file.iar";
"-procs", Arg.String (fun s -> procs_csv := create_outfile s), Some "procs.csv", "create file procs.csv containing statistics for each procedure in CSV format";
"-procs_xml", Arg.String (fun s -> procs_xml := create_outfile s), Some "procs.xml", "create file procs.xml containing statistics for each procedure in XML format";
"-results_dir", Arg.String (fun s -> results_dir_cmdline := true; Config.results_dir := s), Some "dir", "read all the .specs files in the results dir";
"-q", Arg.Set quiet, None, "quiet: do not print specs on standard output";
"-save_results", Arg.String (fun s -> save_analysis_results := Some s), Some "file.iar", "save analysis results to Infer Analysis Results file file.iar";
"-unit_test", Arg.Set unit_test, None, "print unit test code";
"-xml", Arg.Set xml_specs, None, "export specs into XML files file1.xml ... filen.xml";
"-test_filtering", Arg.Set test_filtering, None,
"list all the files Infer can report on (should be call at the root of the procject, where
"-bugs", Arg.String (fun s -> bugs_csv := create_outfile s), Some "bugs.csv", "create file bugs.csv containing a list of bugs in CSV format";
"-bugs_json", Arg.String (fun s -> bugs_json := create_outfile s), Some "bugs.json", "create file bugs.json containing a list of bugs in JSON format";
"-bugs_txt", Arg.String (fun s -> bugs_txt := create_outfile s), Some "bugs.txt", "create file bugs.txt containing a list of bugs in text format";
"-bugs_xml", Arg.String (fun s -> bugs_xml := create_outfile s), Some "bugs.xml", "create file bugs.xml containing a list of bugs in XML format";
"-calls", Arg.String (fun s -> calls_csv := create_outfile s), Some "calls.csv", "write individual calls in csv format to file.csv";
"-load_results", Arg.String (fun s -> load_analysis_results := Some s), Some "file.iar", "load analysis results from Infer Analysis Results file file.iar";
"-procs", Arg.String (fun s -> procs_csv := create_outfile s), Some "procs.csv", "create file procs.csv containing statistics for each procedure in CSV format";
"-procs_xml", Arg.String (fun s -> procs_xml := create_outfile s), Some "procs.xml", "create file procs.xml containing statistics for each procedure in XML format";
"-results_dir", Arg.String (fun s -> results_dir_cmdline := true; Config.results_dir := s), Some "dir", "read all the .specs files in the results dir";
"-q", Arg.Set quiet, None, "quiet: do not print specs on standard output";
"-save_results", Arg.String (fun s -> save_analysis_results := Some s), Some "file.iar", "save analysis results to Infer Analysis Results file file.iar";
"-unit_test", Arg.Set unit_test, None, "print unit test code";
"-xml", Arg.Set xml_specs, None, "export specs into XML files file1.xml ... filen.xml";
"-test_filtering", Arg.Set test_filtering, None,
"list all the files Infer can report on (should be call at the root of the procject, where
.inferconfig lives).";
"-analyzer", Arg.String (fun s -> analyzer := Some (Utils.analyzer_of_string s)), Some "analyzer",
"setup the analyzer for the path filtering";
"-inferconfig_home", Arg.String (fun s -> Inferconfig.inferconfig_home := Some s), Some "dir",
"Path to the .inferconfig file";
"-analyzer", Arg.String (fun s -> analyzer := Some (Utils.analyzer_of_string s)), Some "analyzer",
"setup the analyzer for the path filtering";
"-inferconfig_home", Arg.String (fun s -> Inferconfig.inferconfig_home := Some s), Some "dir",
"Path to the .inferconfig file";
] in
Arg2.create_options_desc false "Options" desc in
let reserved_arg =
let desc =
[
"-latex", Arg.String (fun s -> latex := create_outfile s), Some "file.tex", "print latex report to file.tex";
"-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps";
"-precondition_stats", Arg.Set precondition_stats, None, "print stats about preconditions to standard output";
"-report", Arg.String (fun s -> report := create_outfile s), Some "report_file", "create file report_file containing a report of the analysis results";
"-source_file_copy", Arg.String (fun s -> source_file_copy := Some (DB.abs_source_file_from_path s)), Some "source_file", "print the path of the copy of source_file in the results directory";
"-svg", Arg.Set svg, None, "generate .dot and .svg";
"-whole_seconds", Arg.Set whole_seconds, None, "print whole seconds only";
"-latex", Arg.String (fun s -> latex := create_outfile s), Some "file.tex", "print latex report to file.tex";
"-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps";
"-precondition_stats", Arg.Set precondition_stats, None, "print stats about preconditions to standard output";
"-report", Arg.String (fun s -> report := create_outfile s), Some "report_file", "create file report_file containing a report of the analysis results";
"-source_file_copy", Arg.String (fun s -> source_file_copy := Some (DB.abs_source_file_from_path s)), Some "source_file", "print the path of the copy of source_file in the results directory";
"-svg", Arg.Set svg, None, "generate .dot and .svg";
"-whole_seconds", Arg.Set whole_seconds, None, "print whole seconds only";
] in
Arg2.create_options_desc false "Reserved Options" desc in
base_arg @ reserved_arg
@ -196,7 +196,7 @@ let loc_trace_to_jsonbug_record trace_list ekind =
match ekind with
| Exceptions.Kinfo -> []
| _ ->
(* writes a trace as a record for atdgen conversion *)
(* writes a trace as a record for atdgen conversion *)
let node_tags_to_records tags_list =
list_map (fun tag -> { tag = fst tag; value = snd tag }) tags_list in
let trace_item_to_record trace_item =
@ -251,7 +251,7 @@ let summary_values top_proc_set summary =
list_iter do_spec specs;
let visited_lines = ref IntSet.empty in
Specs.Visitedset.iter (fun (n, ls) ->
list_iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls)
list_iter (fun l -> visited_lines := IntSet.add l !visited_lines) ls)
!visited;
Specs.Visitedset.cardinal !visited, IntSet.elements !visited_lines in
let proof_trace =
@ -337,26 +337,26 @@ module ProcsXml = struct
let attributes = [("id", string_of_int !xml_procs_id) ] in
let forest =
[
subtree Io_infer.Xml.tag_name (Escape.escape_xml sv.vname);
subtree Io_infer.Xml.tag_name_id (Escape.escape_xml sv.vname_id);
subtree Io_infer.Xml.tag_specs (string_of_int sv.vspecs);
subtree Io_infer.Xml.tag_time sv.vtime;
subtree Io_infer.Xml.tag_to sv.vto;
subtree Io_infer.Xml.tag_symop (string_of_int sv.vsymop);
subtree Io_infer.Xml.tag_err (string_of_int sv.verr);
subtree Io_infer.Xml.tag_file sv.vfile;
subtree Io_infer.Xml.tag_line (string_of_int sv.vline);
subtree Io_infer.Xml.tag_loc (string_of_int sv.vloc);
subtree Io_infer.Xml.tag_top sv.vtop;
subtree Io_infer.Xml.tag_signature (Escape.escape_xml sv.vsignature);
subtree Io_infer.Xml.tag_weight (string_of_int sv.vweight);
subtree Io_infer.Xml.tag_proof_coverage sv.vproof_coverage;
subtree Io_infer.Xml.tag_rank sv.vrank;
subtree Io_infer.Xml.tag_in_calls (string_of_int sv.vin_calls);
subtree Io_infer.Xml.tag_out_calls (string_of_int sv.vin_calls);
subtree Io_infer.Xml.tag_proof_trace sv.vproof_trace;
subtree Io_infer.Xml.tag_cyclomatic (string_of_int sv.vcyclomatic);
subtree Io_infer.Xml.tag_flags (string_of_int (Hashtbl.length sv.vflags));
subtree Io_infer.Xml.tag_name (Escape.escape_xml sv.vname);
subtree Io_infer.Xml.tag_name_id (Escape.escape_xml sv.vname_id);
subtree Io_infer.Xml.tag_specs (string_of_int sv.vspecs);
subtree Io_infer.Xml.tag_time sv.vtime;
subtree Io_infer.Xml.tag_to sv.vto;
subtree Io_infer.Xml.tag_symop (string_of_int sv.vsymop);
subtree Io_infer.Xml.tag_err (string_of_int sv.verr);
subtree Io_infer.Xml.tag_file sv.vfile;
subtree Io_infer.Xml.tag_line (string_of_int sv.vline);
subtree Io_infer.Xml.tag_loc (string_of_int sv.vloc);
subtree Io_infer.Xml.tag_top sv.vtop;
subtree Io_infer.Xml.tag_signature (Escape.escape_xml sv.vsignature);
subtree Io_infer.Xml.tag_weight (string_of_int sv.vweight);
subtree Io_infer.Xml.tag_proof_coverage sv.vproof_coverage;
subtree Io_infer.Xml.tag_rank sv.vrank;
subtree Io_infer.Xml.tag_in_calls (string_of_int sv.vin_calls);
subtree Io_infer.Xml.tag_out_calls (string_of_int sv.vin_calls);
subtree Io_infer.Xml.tag_proof_trace sv.vproof_trace;
subtree Io_infer.Xml.tag_cyclomatic (string_of_int sv.vcyclomatic);
subtree Io_infer.Xml.tag_flags (string_of_int (Hashtbl.length sv.vflags));
] in
Io_infer.Xml.create_tree "procedure" attributes forest in
Io_infer.Xml.pp_inner_node fmt tree
@ -506,11 +506,11 @@ module BugsXml = struct
| None -> "" in
Io_infer.Xml.create_tree Io_infer.Xml.tag_loc [("num", string_of_int !num)]
[(level_to_xml lt.Errlog.lt_level);
(file_to_xml (DB.source_file_to_string loc.Sil.file));
(line_to_xml loc.Sil.line);
(code_to_xml code);
(description_to_xml lt.Errlog.lt_description);
(node_tags_to_xml lt.Errlog.lt_node_tags)] in
(file_to_xml (DB.source_file_to_string loc.Sil.file));
(line_to_xml loc.Sil.line);
(code_to_xml code);
(description_to_xml lt.Errlog.lt_description);
(node_tags_to_xml lt.Errlog.lt_node_tags)] in
list_rev (list_rev_map loc_to_xml ltr)
(** print bugs from summary in xml *)
@ -539,19 +539,19 @@ module BugsXml = struct
let bug_hash = get_bug_hash kind type_str procedure_id filename node_key error_desc in
let forest =
[
subtree Io_infer.Xml.tag_class error_class;
subtree Io_infer.Xml.tag_kind kind;
subtree Io_infer.Xml.tag_type type_str;
subtree Io_infer.Xml.tag_qualifier err_desc_string;
subtree Io_infer.Xml.tag_severity severity;
subtree Io_infer.Xml.tag_line error_line;
subtree Io_infer.Xml.tag_procedure (Escape.escape_xml procedure_name);
subtree Io_infer.Xml.tag_procedure_id (Escape.escape_xml procedure_id);
subtree Io_infer.Xml.tag_file filename;
Io_infer.Xml.create_tree Io_infer.Xml.tag_trace [] (loc_trace_to_xml linereader ltr);
subtree Io_infer.Xml.tag_key (string_of_int node_key);
Io_infer.Xml.create_tree Io_infer.Xml.tag_qualifier_tags [] (error_desc_to_xml_tags error_desc);
subtree Io_infer.Xml.tag_hash (string_of_int bug_hash)
subtree Io_infer.Xml.tag_class error_class;
subtree Io_infer.Xml.tag_kind kind;
subtree Io_infer.Xml.tag_type type_str;
subtree Io_infer.Xml.tag_qualifier err_desc_string;
subtree Io_infer.Xml.tag_severity severity;
subtree Io_infer.Xml.tag_line error_line;
subtree Io_infer.Xml.tag_procedure (Escape.escape_xml procedure_name);
subtree Io_infer.Xml.tag_procedure_id (Escape.escape_xml procedure_id);
subtree Io_infer.Xml.tag_file filename;
Io_infer.Xml.create_tree Io_infer.Xml.tag_trace [] (loc_trace_to_xml linereader ltr);
subtree Io_infer.Xml.tag_key (string_of_int node_key);
Io_infer.Xml.create_tree Io_infer.Xml.tag_qualifier_tags [] (error_desc_to_xml_tags error_desc);
subtree Io_infer.Xml.tag_hash (string_of_int bug_hash)
]
@
(if include_precondition_tree then precondition_tree () else []) in
@ -614,7 +614,7 @@ module UnitTest = struct
end
(** Module to compute the top procedures.
A procedure is top if it has specs and any procedure calling it has no specs *)
A procedure is top if it has specs and any procedure calling it has no specs *)
module TopProcedures : sig
type t
val create : unit -> t
@ -675,8 +675,8 @@ module Stats = struct
let process_loc loc stats =
try Hashtbl.find stats.files loc.Sil.file
with Not_found ->
stats.nLOC <- stats.nLOC + loc.Sil.nLOC;
Hashtbl.add stats.files loc.Sil.file ()
stats.nLOC <- stats.nLOC + loc.Sil.nLOC;
Hashtbl.add stats.files loc.Sil.file ()
let loc_trace_to_string_list linereader indent_num ltr =
let res = ref [] in
@ -810,7 +810,7 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna
let always_report () =
Localise.error_desc_extract_tag_value error_desc "always_report" = "true" in
(filters.Inferconfig.path_filter summary.Specs.loc.Sil.file
|| always_report ()) &&
|| always_report ()) &&
filters.Inferconfig.error_filter error_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);
@ -829,11 +829,11 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna
let dot_file = DB.filename_add_suffix base ".dot" in
let svg_file = DB.filename_add_suffix base ".svg" in
if not (DB.file_exists dot_file)
|| DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time dot_file
|| DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time dot_file
then
Dotty.pp_speclist_dotty_file base specs;
if not (DB.file_exists svg_file)
|| DB.file_modified_time dot_file > DB.file_modified_time svg_file
|| DB.file_modified_time dot_file > DB.file_modified_time svg_file
then
ignore (Sys.command ("dot -Tsvg \"" ^ (DB.filename_to_string dot_file) ^ "\" >\"" ^ (DB.filename_to_string svg_file) ^"\""))
end;
@ -841,13 +841,13 @@ let process_summary filters linereader stats (top_proc_set: Procname.Set.t) (fna
let xml_file = DB.filename_add_suffix base ".xml" in
let specs = Specs.get_specs_from_payload summary in
if not (DB.file_exists xml_file)
|| DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time xml_file
|| DB.file_modified_time (DB.filename_from_string fname) > DB.file_modified_time xml_file
then
begin
let xml_out = ref (create_outfile (DB.filename_to_string xml_file)) in
do_outf xml_out (fun outf ->
Dotty.print_specs_xml (Specs.get_signature summary) specs summary.Specs.loc outf.fmt;
close_outf outf)
Dotty.print_specs_xml (Specs.get_signature summary) specs summary.Specs.loc outf.fmt;
close_outf outf)
end
end
(* ignore (Sys.command ("open " ^ base ^ ".svg")) *)
@ -868,11 +868,11 @@ module AnalysisResults = struct
exit(0)
end;
list_append (if !args = ["."] then begin
let arr = Sys.readdir "." in
let all_files = Array.to_list arr in
list_filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files
end
else !args) (results_dir_specsfiles ())
let arr = Sys.readdir "." in
let all_files = Array.to_list arr in
list_filter (fun fname -> (Filename.check_suffix fname ".specs")) all_files
end
else !args) (results_dir_specsfiles ())
(** apply [f] to [arg] with the gc compaction disabled during the execution *)
let apply_without_gc f arg =
@ -925,7 +925,7 @@ module AnalysisResults = struct
Serialization.to_file analysis_results_serializer filename analysis_results
(** Return an iterator over all the summaries.
If options - load_results or - save_results are used, all the summaries are loaded in memory *)
If options - load_results or - save_results are used, all the summaries are loaded in memory *)
let get_summary_iterator () =
let iterator_of_summary_list r =
fun f -> list_iter f r in
@ -987,10 +987,10 @@ let () =
do_outf bugs_txt close_outf;
do_outf bugs_xml (fun outf -> BugsXml.pp_bugs_close outf.fmt (); close_outf outf);
do_outf latex (fun outf ->
Latex.pp_end outf.fmt ();
close_outf outf;
pdflatex outf.fname;
let pdf_name = (Filename.chop_extension outf.fname) ^ ".pdf" in
ignore (Sys.command ("open " ^ pdf_name)));
Latex.pp_end outf.fmt ();
close_outf outf;
pdflatex outf.fname;
let pdf_name = (Filename.chop_extension outf.fname) ^ ".pdf" in
ignore (Sys.command ("open " ^ pdf_name)));
do_outf report (fun outf -> F.fprintf outf.fmt "%a@?" Report.pp_stats stats; close_outf outf);
if !precondition_stats then PreconditionStats.pp_stats ()

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

@ -67,9 +67,9 @@ module Worklist = struct
map := NodeMap.add min.node (min.visits + 1) !map; (* increase the visits *)
min.node
with Not_found -> begin
L.out "@\n...Work list is empty! Impossible to remove edge...@\n";
assert false
end
L.out "@\n...Work list is empty! Impossible to remove edge...@\n";
assert false
end
end
(* =============== END of module Worklist =============== *)
@ -100,8 +100,8 @@ let htable_retrieve (htable : (int, Paths.PathSet.t) Hashtbl.t) (key : int) : Pa
try
Hashtbl.find htable key
with Not_found ->
Hashtbl.replace htable key Paths.PathSet.empty;
Paths.PathSet.empty
Hashtbl.replace htable key Paths.PathSet.empty;
Paths.PathSet.empty
let path_set_get_visited (sid: int) : Paths.PathSet.t =
htable_retrieve path_set_visited sid
@ -130,8 +130,8 @@ let path_set_checkout_todo (node: Cfg.node) : Paths.PathSet.t =
Hashtbl.replace path_set_visited sid new_visited;
todo
with Not_found ->
L.out "@.@.ERROR: could not find todo for node %a@.@." Cfg.Node.pp node;
assert false
L.out "@.@.ERROR: could not find todo for node %a@.@." Cfg.Node.pp node;
assert false
(* =============== END of the edge_set object =============== *)
@ -166,11 +166,11 @@ let pp_path_dotty f path =
let pp_complete_path_dotty_file =
let counter = ref 0 in
fun path ->
incr counter;
let outc = open_out ("error_path" ^ string_of_int !counter ^ ".dot") in
let fmt = F.formatter_of_out_channel outc in
F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_path_dotty path;
close_out outc
incr counter;
let outc = open_out ("error_path" ^ string_of_int !counter ^ ".dot") in
let fmt = F.formatter_of_out_channel outc in
F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_path_dotty path;
close_out outc
(* =============== END: Print a complete path in a dotty file =============== *)
@ -306,10 +306,10 @@ let do_symexec_join pname tenv curr_node (edgeset_todo : Paths.PathSet.t) =
let old_dset', new_dset' = Dom.pathset_join curr_pname tenv old_dset new_dset in
Join_table.put curr_id (Paths.PathSet.union old_dset' new_dset');
list_iter (fun node ->
Paths.PathSet.iter (fun prop path ->
State.set_path path None;
propagate pname false (Paths.PathSet.from_renamed_list [(prop, path)]) node)
new_dset') succ_nodes
Paths.PathSet.iter (fun prop path ->
State.set_path path None;
propagate pname false (Paths.PathSet.from_renamed_list [(prop, path)]) node)
new_dset') succ_nodes
let prop_max_size = ref (0, Prop.prop_emp)
let prop_max_chain_size = ref (0, Prop.prop_emp)
@ -319,9 +319,9 @@ let check_prop_size p path =
let size = Prop.Metrics.prop_size p in
if size > fst !prop_max_size then
(prop_max_size := (size, p);
L.d_strln ("Prop with new max size " ^ string_of_int size ^ ":");
Prop.d_prop p;
L.d_ln ())
L.d_strln ("Prop with new max size " ^ string_of_int size ^ ":");
Prop.d_prop p;
L.d_ln ())
(* Check prop size and filter out possible unabstracted lists *)
let check_prop_size edgeset_todo =
@ -342,8 +342,8 @@ let d_path (path, pos_opt) =
incr step;
(* Propset.pp_proplist_dotty_file ("path" ^ (string_of_int !count) ^ ".dot") plist; *)
L.d_strln ("Path Step #" ^ string_of_int !step ^
" node " ^ string_of_int (Cfg.Node.get_id curr_node) ^
" session " ^ string_of_int session ^ ":");
" node " ^ string_of_int (Cfg.Node.get_id curr_node) ^
" session " ^ string_of_int session ^ ":");
Propset.d !prop_last_step (Propset.from_proplist plist); L.d_ln ();
Cfg.Node.d_instrs true None curr_node; L.d_ln (); L.d_ln ();
prop_last_step := (match plist with | [prop] -> prop | _ -> Prop.prop_emp) in
@ -435,13 +435,13 @@ let check_assignement_guard node =
let succs_loc = list_map (fun n -> Cfg.Node.get_loc n) succs in
let succs_are_all_prune_nodes () =
list_for_all (fun n -> match Cfg.Node.get_kind n with
| Cfg.Node.Prune_node(_) -> true
| _ -> false) succs in
| Cfg.Node.Prune_node(_) -> true
| _ -> false) succs in
let succs_same_loc_as_node () =
if verbose then (L.d_str ("LOCATION NODE: line: "^(string_of_int l_node.Sil.line)^" nLOC: "^(string_of_int l_node.Sil.nLOC)); L.d_strln " ");
list_for_all (fun l ->
if verbose then (L.d_str ("LOCATION l: line: "^(string_of_int l.Sil.line)^" nLOC: "^(string_of_int l.Sil.nLOC)); L.d_strln " ");
Sil.loc_equal l l_node) succs_loc in
if verbose then (L.d_str ("LOCATION l: line: "^(string_of_int l.Sil.line)^" nLOC: "^(string_of_int l.Sil.nLOC)); L.d_strln " ");
Sil.loc_equal l l_node) succs_loc in
let succs_have_simple_guards () = (* check that the guards of the succs are a var or its negation *)
let check_instr = function
| Sil.Prune (Sil.Var _, _, _, _) -> true
@ -453,20 +453,20 @@ let check_assignement_guard node =
list_for_all check_guard succs in
if !Sil.curr_language = Sil.C_CPP && succs_are_all_prune_nodes () && succs_same_loc_as_node () && succs_have_simple_guards () then
(let instr = Cfg.Node.get_instrs node in
match succs_loc with
| loc_succ:: _ -> (* at this point all successors are at the same location, so we can take the first*)
let set_instr_at_succs_loc = list_filter (fun i -> (Sil.loc_equal (Sil.instr_get_loc i) loc_succ) && is_set_instr i) instr in
(match set_instr_at_succs_loc with
| [Sil.Set(e, _, _, _)] -> (* we now check if e is the same expression used to prune*)
if (is_prune_exp e) && not ((node_contains_call node) && (is_cil_tmp e)) && not (is_edg_tmp e) then (
let desc = Errdesc.explain_condition_is_assignment l_node in
let exn = Exceptions.Condition_is_assignment (desc, try assert false with Assert_failure x -> x) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ~loc: (Some l_node) ~pre: pre_opt exn
)
else ()
| _ -> ())
| _ -> if verbose then L.d_strln "NOT FOUND loc_succ"
match succs_loc with
| loc_succ:: _ -> (* at this point all successors are at the same location, so we can take the first*)
let set_instr_at_succs_loc = list_filter (fun i -> (Sil.loc_equal (Sil.instr_get_loc i) loc_succ) && is_set_instr i) instr in
(match set_instr_at_succs_loc with
| [Sil.Set(e, _, _, _)] -> (* we now check if e is the same expression used to prune*)
if (is_prune_exp e) && not ((node_contains_call node) && (is_cil_tmp e)) && not (is_edg_tmp e) then (
let desc = Errdesc.explain_condition_is_assignment l_node in
let exn = Exceptions.Condition_is_assignment (desc, try assert false with Assert_failure x -> x) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ~loc: (Some l_node) ~pre: pre_opt exn
)
else ()
| _ -> ())
| _ -> if verbose then L.d_strln "NOT FOUND loc_succ"
) else ()
(** Perform symbolic execution for a node starting from an initial prop *)
@ -503,9 +503,9 @@ let forward_tabulate cfg tenv =
let pre_opt = (* precondition leading to error, if any *)
State.get_normalized_pre (Abs.abstract_no_symop curr_pname) in
(match pre_opt with
| Some pre ->
L.d_strln "Precondition:"; Prop.d_prop pre; L.d_ln ()
| None -> ());
| Some pre ->
L.d_strln "Precondition:"; Prop.d_prop pre; L.d_ln ()
| None -> ());
L.d_strln "SIL INSTR:";
Cfg.Node.d_instrs ~sub_instrs: true (State.get_instr ()) curr_node; L.d_ln ();
Reporting.log_error ~pre: pre_opt curr_pname exn;
@ -544,10 +544,10 @@ let forward_tabulate cfg tenv =
handled_some_exception := false;
check_prop_size pathset_todo;
L.d_strln ("**** " ^ (log_string proc_name) ^ " " ^
"Node: " ^ string_of_int sid_curr_node ^ ", " ^
"Procedure: " ^ Procname.to_string proc_name ^ ", " ^
"Session: " ^ string_of_int session ^ ", " ^
"Todo: " ^ string_of_int (Paths.PathSet.size pathset_todo) ^ " ****");
"Node: " ^ string_of_int sid_curr_node ^ ", " ^
"Procedure: " ^ Procname.to_string proc_name ^ ", " ^
"Session: " ^ string_of_int session ^ ", " ^
"Todo: " ^ string_of_int (Paths.PathSet.size pathset_todo) ^ " ****");
L.d_increase_indent 1;
Propset.d Prop.prop_emp (Paths.PathSet.to_propset pathset_todo);
L.d_strln ".... Instructions: .... ";
@ -563,24 +563,24 @@ let forward_tabulate cfg tenv =
| Cfg.Node.Start_node _ ->
exe_iter
(fun prop path cnt num_paths ->
try
L.d_strln ("Processing prop " ^ string_of_int cnt ^ "/" ^ string_of_int num_paths);
L.d_increase_indent 1;
State.reset_diverging_states_goto_node ();
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 kind_curr_node succ_nodes exn_nodes;
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 kind_curr_node succ_nodes exn_nodes;
L.d_decrease_indent 1; L.d_ln ())
try
L.d_strln ("Processing prop " ^ string_of_int cnt ^ "/" ^ string_of_int num_paths);
L.d_increase_indent 1;
State.reset_diverging_states_goto_node ();
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 kind_curr_node succ_nodes exn_nodes;
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 kind_curr_node succ_nodes exn_nodes;
L.d_decrease_indent 1; L.d_ln ())
pathset_todo in
try begin
doit();
if !handled_some_exception then Printer.force_delayed_prints ();
do_after_node curr_node
end
doit();
if !handled_some_exception then Printer.force_delayed_prints ();
do_after_node curr_node
end
with
| exn when Exceptions.handle_exception exn ->
handle_exn curr_node exn;
@ -709,9 +709,9 @@ let create_seed_vars sigma =
list_fold_left hpred_add_seed [] sigma
(** Initialize proposition for execution given formal and global
parameters. The footprint is initialized according to the
execution mode. The prop is not necessarily emp, so it
should be incorporated when the footprint is constructed. *)
parameters. The footprint is initialized according to the
execution mode. The prop is not necessarily emp, so it
should be incorporated when the footprint is constructed. *)
let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Prop.t =
let sigma_new_formals =
let do_formal (pv, typ) =
@ -726,17 +726,17 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
let new_pi =
let pi = Prop.get_pi prop in
pi
(* inactive until it becomes necessary, as it pollutes props
let fav_ids = Sil.fav_to_list (Prop.sigma_fav sigma_locals) in
let mk_undef_atom id = Prop.mk_neq (Sil.Var id) (Sil.Const (Sil.Cattribute (Sil.Aundef "UNINITIALIZED"))) in
let pi_undef = list_map mk_undef_atom fav_ids in
pi_undef @ pi *) in
(* inactive until it becomes necessary, as it pollutes props
let fav_ids = Sil.fav_to_list (Prop.sigma_fav sigma_locals) in
let mk_undef_atom id = Prop.mk_neq (Sil.Var id) (Sil.Const (Sil.Cattribute (Sil.Aundef "UNINITIALIZED"))) in
let pi_undef = list_map mk_undef_atom fav_ids in
pi_undef @ pi *) in
let prop' =
Prop.replace_pi new_pi (Prop.prop_sigma_star prop sigma) in
Prop.replace_sigma_footprint (Prop.get_sigma_footprint prop' @ sigma_new_formals) prop'
(** Construct an initial prop by extending [prop] with locals, and formals if [add_formals] is true
as well as seed variables *)
as well as seed variables *)
let initial_prop tenv (curr_f: Cfg.Procdesc.t) (prop : 'a Prop.t) add_formals : Prop.normal Prop.t =
let construct_decl (x, typ) =
(Sil.mk_pvar (Mangled.from_string x) (Cfg.Procdesc.get_proc_name curr_f), typ) in
@ -766,7 +766,7 @@ let initial_prop_from_pre tenv curr_f pre =
(** Re-execute one precondition and return some spec if there was no re-execution error. *)
let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Specs.Jprop.t)
: Prop.normal Specs.spec option =
: Prop.normal Specs.spec option =
let proc_name = Cfg.Procdesc.get_proc_name pdesc in
do_before_node 0 init_node;
L.d_strln ("#### Start: RE-execution for " ^ Procname.to_string proc_name ^ " ####");
@ -800,16 +800,16 @@ let execute_filter_prop cfg tenv pdesc init_node (precondition : Prop.normal Spe
do_after_node init_node;
Some spec
with RE_EXE_ERROR ->
do_before_node 0 init_node;
Printer.force_delayed_prints ();
L.d_strln_color Red ("#### [FUNCTION " ^ Procname.to_string proc_name ^ "] ...ERROR");
L.d_increase_indent 1;
L.d_strln "when starting from pre:";
Prop.d_prop (Specs.Jprop.to_prop precondition);
L.d_strln "This precondition is filtered out.";
L.d_decrease_indent 1;
do_after_node init_node;
None
do_before_node 0 init_node;
Printer.force_delayed_prints ();
L.d_strln_color Red ("#### [FUNCTION " ^ Procname.to_string proc_name ^ "] ...ERROR");
L.d_increase_indent 1;
L.d_strln "when starting from pre:";
Prop.d_prop (Specs.Jprop.to_prop precondition);
L.d_strln "This precondition is filtered out.";
L.d_decrease_indent 1;
do_after_node init_node;
None
(** get all the nodes in the current call graph with their defined children *)
let get_procs_and_defined_children call_graph =
@ -822,12 +822,12 @@ let pp_intra_stats cfg proc_desc fmt proc_name =
F.fprintf fmt "(%d nodes containing %d states)" (list_length nodes) !nstates
(** Return functions to perform one phase of the analysis for a procedure.
Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase
and [get_results ()] returns the results computed.
This function is architected so that [get_results ()] can be called even after
[go ()] was interrupted by and exception. *)
Given [proc_name], return [do, get_results] where [go ()] performs the analysis phase
and [get_results ()] returns the results computed.
This function is architected so that [get_results ()] can be called even after
[go ()] was interrupted by and exception. *)
let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t)
: (unit -> unit) * (unit -> Prop.normal Specs.spec list) =
: (unit -> unit) * (unit -> Prop.normal Specs.spec list) =
let start_node = Cfg.Procdesc.get_start_node pdesc in
let check_recursion_level () =
@ -878,7 +878,7 @@ let perform_analysis_phase cfg tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t
| Exceptions.Leak _ ->
let exn =
Exceptions.Internal_error
(Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint") in
(Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint") in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_error pname ~pre: pre_opt exn;
[] (* retuning no specs *) in
@ -975,7 +975,7 @@ let remove_this_not_null prop =
| hpred -> (var_option, hpred:: hpreds) in
let collect_atom var atoms = function
| Sil.Aneq (Sil.Var v, e)
when Ident.equal v var && Sil.exp_equal e Sil.exp_null -> atoms
when Ident.equal v var && Sil.exp_equal e Sil.exp_null -> atoms
| a -> a:: atoms in
match list_fold_left collect_hpred (None, []) (Prop.get_sigma prop) with
| None, _ -> prop
@ -988,8 +988,8 @@ let remove_this_not_null prop =
(** 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 } *)
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 pname = Specs.get_proc_name summary in
let is_public_method =
@ -1043,8 +1043,8 @@ let update_summary prev_summary specs proc_name elapsed res =
(** Analyze [proc_name] and return the updated summary. Use module
[Timeout] to call [perform_analysis_phase] with a time limit, and
then return the updated summary. Executed as a child process. *)
[Timeout] to call [perform_analysis_phase] with a time limit, and
then return the updated summary. Executed as a child process. *)
let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
if !Config.trace_anal then L.err "===analyze_proc@.";
let init_time = Unix.gettimeofday () in
@ -1067,7 +1067,7 @@ let analyze_proc exe_env (proc_name: Procname.t) : Specs.summary =
updated_summary
(** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for
the procedures enabled after the analysis of [proc_name] *)
the procedures enabled after the analysis of [proc_name] *)
let perform_transition exe_env cg proc_name =
let proc_names = Fork.should_perform_transition cg proc_name in
let transition pname =
@ -1090,19 +1090,19 @@ let perform_transition exe_env cg proc_name =
apply_start_node do_after_node;
res
with exn when exn_not_timeout exn ->
apply_start_node do_after_node;
Config.allowleak := allowleak;
L.err "Error in collect_preconditions for %a@." Procname.pp proc_name;
let err_name, _, mloco, _, _, _, _ = Exceptions.recognize_exception exn in
let err_str = "exception raised " ^ (Localise.to_string err_name) in
L.err "Error: %s %a@." err_str pp_ml_location_opt mloco;
[] in
apply_start_node do_after_node;
Config.allowleak := allowleak;
L.err "Error in collect_preconditions for %a@." Procname.pp proc_name;
let err_name, _, mloco, _, _, _, _ = Exceptions.recognize_exception exn in
let err_str = "exception raised " ^ (Localise.to_string err_name) in
L.err "Error: %s %a@." err_str pp_ml_location_opt mloco;
[] in
Fork.transition_footprint_re_exe pname joined_pres in
list_iter transition proc_names
(** Process the result of the analysis of [proc_name]: update the
returned summary and add it to the spec table. Executed in the
parent process as soon as a child process returns a result. *)
returned summary and add it to the spec table. Executed in the
parent process as soon as a child process returns a result. *)
let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary) : unit =
if !Config.trace_anal then L.err "===process_result@.";
Ident.reset_name_generator (); (* for consistency with multi-core mode *)
@ -1112,14 +1112,14 @@ let process_result (exe_env: Exe_env.t) (proc_name, calls) (_summ: Specs.summary
perform_transition exe_env call_graph proc_name;
if !Config.only_footprint || summ.Specs.phase != Specs.FOOTPRINT then
(try Specs.store_summary proc_name summ with
Sys_error s ->
L.err "@.### System Error while writing summary of procedure %a to disk: %s@." Procname.pp proc_name s);
Sys_error s ->
L.err "@.### System Error while writing summary of procedure %a to disk: %s@." Procname.pp proc_name s);
let procs_done = Fork.procs_become_done call_graph proc_name in
Fork.post_process_procs exe_env procs_done
(** Return true if the analysis of [proc_name] should be
skipped. Called by the parent process before attempting to analyze a
proc. *)
skipped. Called by the parent process before attempting to analyze a
proc. *)
let filter_out (call_graph: Cg.t) (proc_name: Procname.t) : bool =
if !Config.trace_anal then L.err "===filter_out@.";
let slice_out = (* filter out if slicing is active and [proc_name] not in slice *)
@ -1192,16 +1192,16 @@ let do_analysis exe_env =
Callbacks.proc_inline_synthetic_methods cfg pdesc;
Specs.init_summary
(pname, ret_type, formals, dep, loc, nodes, proc_flags,
static_err_log, calls, cyclomatic, None, attributes) in
static_err_log, calls, cyclomatic, None, attributes) in
let filter =
if !Config.only_skips then (filter_skipped_procs cg procs_and_defined_children)
else if !Config.only_nospecs then filter_nospecs
else (fun _ -> true) in
list_iter (fun x -> if filter x then init_proc x) procs_and_defined_children;
(try Fork.parallel_iter_nodes exe_env analyze_proc process_result filter_out with
exe when do_parallel ->
L.out "@.@. ERROR exception raised in parallel execution@.";
raise exe)
exe when do_parallel ->
L.out "@.@. ERROR exception raised in parallel execution@.";
raise exe)
let visited_and_total_nodes cfg =
let all_nodes =
@ -1218,7 +1218,7 @@ let visited_and_total_nodes cfg =
Cfg.NodeSet.elements visited_nodes_re, Cfg.NodeSet.elements counted_nodes
(** Print the stats for the given cfg; consider every defined proc unless a proc with the same name
was defined in another module, and was the one which was analyzed *)
was defined in another module, and was the one which was analyzed *)
let print_stats_cfg proc_shadowed proc_is_active cfg =
let err_table = Errlog.create_err_table () in
let active_procs = list_filter proc_is_active (Cfg.get_defined_procs cfg) in
@ -1248,9 +1248,9 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
tot_specs := (list_length specs) + !tot_specs;
let () =
match specs,
Errlog.size
(fun ekind in_footprint -> ekind = Exceptions.Kerror && in_footprint)
stats.Specs.err_log with
Errlog.size
(fun ekind in_footprint -> ekind = Exceptions.Kerror && in_footprint)
stats.Specs.err_log with
| [], 0 -> incr num_nospec_noerror_proc
| _, 0 -> incr num_spec_noerror_proc
| [], _ -> incr num_nospec_error_proc
@ -1264,7 +1264,7 @@ let print_stats_cfg proc_shadowed proc_is_active cfg =
let num_infos = Errlog.err_table_size_footprint Exceptions.Kinfo err_table in
let num_ok_proc = !num_spec_noerror_proc + !num_spec_error_proc in
(* F.fprintf fmt "VISITED: %a@\n" (pp_seq pp_node) nodes_visited;
F.fprintf fmt "TOTAL: %a@\n" (pp_seq pp_node) nodes_total; *)
F.fprintf fmt "TOTAL: %a@\n" (pp_seq pp_node) nodes_total; *)
F.fprintf fmt "@\n++++++++++++++++++++++++++++++++++++++++++++++++++@\n";
F.fprintf fmt "+ FILE: %s LOC: %n VISITED: %d/%d SYMOPS: %d@\n" (DB.source_file_to_string !DB.current_source) !Config.nLOC (list_length nodes_visited) (list_length nodes_total) !tot_symops;
F.fprintf fmt "+ num_procs: %d (%d ok, %d timeouts, %d errors, %d warnings, %d infos)@\n" !num_proc num_ok_proc !num_timeout num_errors num_warnings num_infos;
@ -1297,8 +1297,8 @@ 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 ->
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
Exe_env.get_source exe_env proc_name <> fname in
print_stats_cfg proc_shadowed proc_is_active cfg) exe_env
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
Exe_env.get_source exe_env proc_name <> fname in
print_stats_cfg proc_shadowed proc_is_active cfg) exe_env

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

@ -24,11 +24,11 @@ module Html : sig
val pp_end_color : Format.formatter -> unit -> unit (** Print end color *)
(** [pp_node_link path_to_root description isvisited isproof fmt id] prints an html link to the given node.
[path_to_root] is the path to the dir for the procedure in the spec db.
[description] is a string description.
[is_visited] indicates whether the node should be active or greyed out.
[is_proof] indicates whether the node is part of a proof and should be green.
[id] is the node identifier. *)
[path_to_root] is the path to the dir for the procedure in the spec db.
[description] is a string description.
[is_visited] indicates whether the node should be active or greyed out.
[is_proof] indicates whether the node is part of a proof and should be green.
[id] is the node identifier. *)
val pp_node_link : DB.Results_dir.path -> string -> int list -> int list -> int list -> bool -> bool -> Format.formatter -> int -> unit
val pp_proc_link : DB.Results_dir.path -> Procname.t -> Format.formatter -> string -> unit (** Print an html link to the given proc *)
val pp_session_link : ?with_name: bool -> string list -> Format.formatter -> int * int * int -> unit (** Print an html link given node id and session *)
@ -45,59 +45,59 @@ end = struct
let s =
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">" ++
"<html>\n<head>\n<title>" ^ fname ^ "</title>" ++
"<style type=\"text/css\">" ++
"body { color:#000000; background-color:#ffffff }" ++
"body { font-family:Helvetica, sans-serif; font-size:10pt }" ++
"h1 { font-size:14pt }" ++
".code { border-collapse:collapse; width:100%; }" ++
".code { font-family: \"Andale Mono\", monospace; font-size:10pt }" ++
".code { line-height: 1.2em }" ++
".comment { color: green; font-style: oblique }" ++
".keyword { color: blue }" ++
".string_literal { color: red }" ++
".color_black { color: black }" ++
".color_blue { color: blue }" ++
".color_green { color: green }" ++
".color_red { color: red }" ++
".color_orange { color: orange }" ++
".directive { color: darkmagenta }" ++
".expansion { display: none; }" ++
".visited:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".visited { color: darkmagenta; background-color:LemonChiffon; position: relative }" ++
".visitedproof:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".visitedproof { color: darkmagenta; background-color:lightgreen; position: relative }" ++
".dangling:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".dangling { color: gray; background-color:white; position: relative }" ++
".num { width:2.5em; padding-right:2ex; background-color:#eeeeee }" ++
".num { text-align:right; font-size: smaller }" ++
".num { color:#444444 }" ++
".line { padding-left: 1ex; border-left: 3px solid #ccc }" ++
".line { white-space: pre }" ++
".msg { background-color:#fff8b4; color:#000000 }" ++
".msg { -webkit-box-shadow:1px 1px 7px #000 }" ++
".msg { -webkit-border-radius:5px }" ++
".msg { font-family:Helvetica, sans-serif; font-size: smaller }" ++
".msg { font-weight: bold }" ++
".msg { float:left }" ++
".msg { padding:0.5em 1ex 0.5em 1ex }" ++
".msg { margin-top:10px; margin-bottom:10px }" ++
".msg { max-width:60em; word-wrap: break-word; white-space: pre-wrap;}" ++
".mrange { background-color:#dfddf3 }" ++
".mrange { border-bottom:1px solid #6F9DBE }" ++
".PathIndex { font-weight: bold }" ++
"table.simpletable {" ++
"padding: 5px;" ++
"font-size:12pt;" ++
"margin:20px;" ++
"border-collapse: collapse; border-spacing: 0px;" ++
"}" ++
"td.rowname {" ++
"text-align:right; font-weight:bold; color:#444444;" ++
"padding-right:2ex; }" ++
"</style>" ++
"</head>" ++
"<body" ^ ">" ++
"" in
"<style type=\"text/css\">" ++
"body { color:#000000; background-color:#ffffff }" ++
"body { font-family:Helvetica, sans-serif; font-size:10pt }" ++
"h1 { font-size:14pt }" ++
".code { border-collapse:collapse; width:100%; }" ++
".code { font-family: \"Andale Mono\", monospace; font-size:10pt }" ++
".code { line-height: 1.2em }" ++
".comment { color: green; font-style: oblique }" ++
".keyword { color: blue }" ++
".string_literal { color: red }" ++
".color_black { color: black }" ++
".color_blue { color: blue }" ++
".color_green { color: green }" ++
".color_red { color: red }" ++
".color_orange { color: orange }" ++
".directive { color: darkmagenta }" ++
".expansion { display: none; }" ++
".visited:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".visited { color: darkmagenta; background-color:LemonChiffon; position: relative }" ++
".visitedproof:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".visitedproof { color: darkmagenta; background-color:lightgreen; position: relative }" ++
".dangling:hover .expansion { display: block; border: 2px solid #FF0000; padding: 2px; background-color:#FFF0F0; font-weight: normal; -webkit-border-radius:5px; -webkit-box-shadow:1px 1px 7px #000; position: absolute; top: -1em; left:10em; z-index: 1 }" ++
".dangling { color: gray; background-color:white; position: relative }" ++
".num { width:2.5em; padding-right:2ex; background-color:#eeeeee }" ++
".num { text-align:right; font-size: smaller }" ++
".num { color:#444444 }" ++
".line { padding-left: 1ex; border-left: 3px solid #ccc }" ++
".line { white-space: pre }" ++
".msg { background-color:#fff8b4; color:#000000 }" ++
".msg { -webkit-box-shadow:1px 1px 7px #000 }" ++
".msg { -webkit-border-radius:5px }" ++
".msg { font-family:Helvetica, sans-serif; font-size: smaller }" ++
".msg { font-weight: bold }" ++
".msg { float:left }" ++
".msg { padding:0.5em 1ex 0.5em 1ex }" ++
".msg { margin-top:10px; margin-bottom:10px }" ++
".msg { max-width:60em; word-wrap: break-word; white-space: pre-wrap;}" ++
".mrange { background-color:#dfddf3 }" ++
".mrange { border-bottom:1px solid #6F9DBE }" ++
".PathIndex { font-weight: bold }" ++
"table.simpletable {" ++
"padding: 5px;" ++
"font-size:12pt;" ++
"margin:20px;" ++
"border-collapse: collapse; border-spacing: 0px;" ++
"}" ++
"td.rowname {" ++
"text-align:right; font-weight:bold; color:#444444;" ++
"padding-right:2ex; }" ++
"</style>" ++
"</head>" ++
"<body" ^ ">" ++
"" in
F.fprintf fmt "%s" s;
(fd, fmt)

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

@ -142,7 +142,7 @@ module BucketLevel = struct
end
(** takes in input a tag to extract from the given error_desc
and returns its value *)
and returns its value *)
let error_desc_extract_tag_value (_, _, tags) tag_to_extract =
let find_value tag v =
match v with
@ -286,7 +286,7 @@ let deref_str_undef (proc_name, loc) =
value_pre = Some (pointer_or_object ());
value_post = None;
problem_str = "could be assigned by a call to skip function " ^ proc_name_str ^
at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed"; }
at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed"; }
(** dereference strings for a freed pointer dereference *)
let deref_str_freed ra =
@ -403,8 +403,8 @@ let dereference_string deref_str value_str access_opt loc =
let problem_str =
match Tags.get !tags Tags.nullable_src with
| Some nullable_src ->
if nullable_src = value_str then "is annotated with @Nullable and is dereferenced without a null check"
else "is indirectly marked @Nullable (source: " ^ nullable_src ^ ") and is dereferenced without a null check"
if nullable_src = value_str then "is annotated with @Nullable and is dereferenced without a null check"
else "is indirectly marked @Nullable (source: " ^ nullable_src ^ ") and is dereferenced without a null check"
| None -> deref_str.problem_str in
[(problem_str ^ " " ^ at_line tags loc)] in
value_desc:: access_desc @ problem_desc, None, !tags

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

@ -181,7 +181,7 @@ let stdout fmt_string =
do_print F.std_formatter fmt_string
(** print a warning with information of the position in the ml source where it oririnated.
use as: warning_position "description" (try assert false with Assert_failure x -> x); *)
use as: warning_position "description" (try assert false with Assert_failure x -> x); *)
let warning_position (s: string) (mloc: ml_location) =
err "WARNING: %s in %a@." s pp_ml_location_opt (Some mloc)

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

@ -66,7 +66,7 @@ let pp f pn =
type mangled_t = t
module MangledSet = Set.Make
(struct
type t = mangled_t
let compare = compare
end)
(struct
type t = mangled_t
let compare = compare
end)

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

@ -18,8 +18,8 @@ let mem_idlist i l =
list_exists (Ident.equal i) l
(** Type for a hpred pattern. flag=false means that the implication
between hpreds is not considered, and flag = true means that it is
considered during pattern matching *)
between hpreds is not considered, and flag = true means that it is
considered during pattern matching *)
type hpred_pat = { hpred : Sil.hpred; flag : bool }
let pp_hpat pe f hpat =
@ -33,7 +33,7 @@ let rec pp_hpat_list pe f = function
F.fprintf f "%a * %a" (pp_hpat pe) hpat (pp_hpat_list pe) hpats
(** Checks e1 = e2[sub ++ sub'] for some sub' with dom(sub') subseteq vars.
Returns (sub ++ sub', vars - dom(sub')). *)
Returns (sub ++ sub', vars - dom(sub')). *)
let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
let check_equal sub vars e1 e2 =
let e2_inst = Sil.exp_sub sub e2
@ -63,8 +63,8 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
None (* Naive *)
| Sil.BinOp(b1, e1', e1''), Sil.BinOp(b2, e2', e2'') when Sil.binop_equal b1 b2 ->
(match exp_match e1' sub vars e2' with
| None -> None
| Some (sub', vars') -> exp_match e1'' sub' vars' e2'')
| None -> None
| Some (sub', vars') -> exp_match e1'' sub' vars' e2'')
| Sil.BinOp _, _ | _, Sil.BinOp _ ->
None (* Naive *)
| Sil.Lvar _, _ | _, Sil.Lvar _ ->
@ -75,8 +75,8 @@ let rec exp_match e1 sub vars e2 : (Sil.subst * Ident.t list) option =
None
| Sil.Lindex(base1, idx1), Sil.Lindex(base2, idx2) ->
(match exp_match base1 sub vars base2 with
| None -> None
| Some (sub', vars') -> exp_match idx1 sub' vars' idx2)
| None -> None
| Some (sub', vars') -> exp_match idx1 sub' vars' idx2)
let exp_list_match es1 sub vars es2 =
let f res_acc (e1, e2) = match res_acc with
@ -87,9 +87,9 @@ let exp_list_match es1 sub vars es2 =
in es_match_res
(** Checks sexp1 = sexp2[sub ++ sub'] for some sub' with
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')).
WARNING: This function does not consider the fact that the analyzer
sometimes forgets fields of hpred. It can possibly cause a problem. *)
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')).
WARNING: This function does not consider the fact that the analyzer
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) ->
@ -102,12 +102,12 @@ let rec strexp_match sexp1 sub vars sexp2 : (Sil.subst * Ident.t list) option =
None
| Sil.Earray (size1, isel1, _), Sil.Earray (size2, isel2, _) ->
(match exp_match size1 sub vars size2 with
| Some (sub', vars') -> isel_match isel1 sub' vars' isel2
| None -> None)
| Some (sub', vars') -> isel_match isel1 sub' vars' isel2
| None -> None)
(** Checks fsel1 = fsel2[sub ++ sub'] for some sub' with
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *)
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *)
and fsel_match fsel1 sub vars fsel2 =
match fsel1, fsel2 with
| [], [] -> Some (sub, vars)
@ -124,11 +124,11 @@ and fsel_match fsel1 sub vars fsel2 =
end
else if (n < 0 && !Config.abs_struct > 0) then
fsel_match fsel1' sub vars fsel2
(* This can lead to great information loss *)
(* This can lead to great information loss *)
else None
(** Checks isel1 = isel2[sub ++ sub'] for some sub' with
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *)
dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *)
and isel_match isel1 sub vars isel2 =
match isel1, isel2 with
| [], [] -> Some (sub, vars)
@ -203,8 +203,8 @@ let rec instantiate_to_emp p condition sub vars = function
instantiate_to_emp p condition sub_new vars_leftover hpats
(* This function has to be changed in order to
* implement the idea "All lsegs outside are NE, and all lsegs inside
* are PE" *)
* implement the idea "All lsegs outside are NE, and all lsegs inside
* are PE" *)
let rec iter_match_with_impl iter condition sub vars hpat hpats =
(*
@ -243,8 +243,8 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let gen_filter_pointsto lexp2 strexp2 te2 = function
| Sil.Hpointsto (lexp1, strexp1, te1) when Sil.exp_equal te1 te2 ->
(match (exp_match lexp1 sub vars lexp2) with
| None -> None
| Some (sub', vars_leftover) -> strexp_match strexp1 sub' vars_leftover strexp2)
| None -> None
| Some (sub', vars_leftover) -> strexp_match strexp1 sub' vars_leftover strexp2)
| _ -> None
in
let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function
@ -328,19 +328,19 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| Some _ -> None
in begin match ((Prop.prop_iter_find iter filter), hpats) with
| (None, _) when not hpat.flag ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
None
| (None, _) when Sil.lseg_kind_equal k2 Sil.Lseg_NE ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
do_para_lseg ()
| (None, _) ->
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
(* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *)
execute_with_backtracking [do_emp_lseg; do_para_lseg]
| (Some iter_cur, []) ->
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
do_empty_hpats iter_cur ()
| (Some iter_cur, _) ->
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
(* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *)
execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur]
end
| Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) ->
@ -460,10 +460,10 @@ and hpara_dll_match_with_impl impl_ok para1 para2 : bool =
(** [prop_match_with_impl p condition vars hpat hpats]
returns [(subst, p_leftover)] such that
1) [dom(subst) = vars]
2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover].
Using the flag [field], we can control the strength of |-. *)
returns [(subst, p_leftover)] such that
1) [dom(subst) = vars]
2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover].
Using the flag [field], we can control the strength of |-. *)
let prop_match_with_impl p condition vars hpat hpats =
prop_match_with_impl_sub p condition Sil.sub_empty vars hpat hpats
@ -571,10 +571,10 @@ let hpara_dll_iso para1 para2 =
(** [generic_find_partial_iso] finds isomorphic subsigmas of [sigma_todo].
The function [update] is used to get rid of hpred pairs from [sigma_todo].
[sigma_corres] records the isormophic copies discovered so far. The first
parameter determines how much flexibility we will allow during this partial
isomorphism finding. *)
The function [update] is used to get rid of hpred pairs from [sigma_todo].
[sigma_corres] records the isormophic copies discovered so far. The first
parameter determines how much flexibility we will allow during this partial
isomorphism finding. *)
let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_todo =
match todos with
| [] ->
@ -599,10 +599,10 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
| None, _ | _, None ->
None
| Some (Sil.Hpointsto (_, _, te1)), Some (Sil.Hpointsto (_, _, te2))
when not (Sil.exp_equal te1 te2) ->
when not (Sil.exp_equal te1 te2) ->
None
| Some (Sil.Hpointsto (_, se1, _) as hpred1),
Some (Sil.Hpointsto (_, se2, _) as hpred2) ->
Some (Sil.Hpointsto (_, se2, _) as hpred2) ->
begin
match generate_todos_from_strexp mode [] se1 se2 with
| None -> None
@ -620,51 +620,51 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
end
| Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1),
Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ->
Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ->
if k1 <> k2 || not (hpara_iso para1 para2) then None
else
(try
let new_corres = match corres_extend_front e1 e2 corres with
| None -> assert false
| Some new_corres -> new_corres in
let new_sigma_corres =
let sigma1, sigma2 = sigma_corres in
let new_sigma1 = hpred1 :: sigma1 in
let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in
let new_todos =
let shared12 = list_combine shared1 shared2 in
(root1, root2) :: (next1, next2) :: shared12 @ todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None)
let new_corres = match corres_extend_front e1 e2 corres with
| None -> assert false
| Some new_corres -> new_corres in
let new_sigma_corres =
let sigma1, sigma2 = sigma_corres in
let new_sigma1 = hpred1 :: sigma1 in
let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in
let new_todos =
let shared12 = list_combine shared1 shared2 in
(root1, root2) :: (next1, next2) :: shared12 @ todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None)
| Some (Sil.Hdllseg(k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1),
Some (Sil.Hdllseg(k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ->
Some (Sil.Hdllseg(k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ->
if k1 <> k2 || not (hpara_dll_iso para1 para2) then None
else
(try
let new_corres = match corres_extend_front e1 e2 corres with
| None -> assert false
| Some new_corres -> new_corres in
let new_sigma_corres =
let sigma1, sigma2 = sigma_corres in
let new_sigma1 = hpred1 :: sigma1 in
let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in
let new_todos =
let shared12 = list_combine shared1 shared2 in
(iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None)
let new_corres = match corres_extend_front e1 e2 corres with
| None -> assert false
| Some new_corres -> new_corres in
let new_sigma_corres =
let sigma1, sigma2 = sigma_corres in
let new_sigma1 = hpred1 :: sigma1 in
let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in
let new_todos =
let shared12 = list_combine shared1 shared2 in
(iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None)
| _ -> None
end
| _ -> None
(** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma.
The function returns a partial iso and three sigmas. The first sigma is the first
copy of the two isomorphic sigmas, so it uses expressions in the domain of
the returned isomorphism. The second is the second copy of the two isomorphic sigmas,
and it uses expressions in the range of the isomorphism. The third is the unused
part of the input sigma. *)
The function returns a partial iso and three sigmas. The first sigma is the first
copy of the two isomorphic sigmas, so it uses expressions in the domain of
the returned isomorphism. The second is the second copy of the two isomorphic sigmas,
and it uses expressions in the range of the isomorphism. The third is the unused
part of the input sigma. *)
let find_partial_iso eq corres todos sigma =
let update e1 e2 sigma0 =
let (hpredo1, sigma0_no_e1) = sigma_remove_hpred eq sigma0 e1 in
@ -675,11 +675,11 @@ let find_partial_iso eq corres todos sigma =
generic_find_partial_iso Exact update corres init_sigma_corres todos init_sigma_todo
(** [find_partial_iso_from_two_sigmas] finds isomorphic sub-sigmas inside two
given sigmas. The function returns a partial iso and four sigmas. The first
sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of
the returned isomorphism. The second is the second copy of the two isomorphic sigmas,
and it uses expressions in the range of the isomorphism. The third and fourth
are the unused parts of the two input sigmas. *)
given sigmas. The function returns a partial iso and four sigmas. The first
sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of
the returned isomorphism. The second is the second copy of the two isomorphic sigmas,
and it uses expressions in the range of the isomorphism. The third and fourth
are the unused parts of the two input sigmas. *)
let find_partial_iso_from_two_sigmas mode eq corres todos sigma1 sigma2 =
let update e1 e2 sigma_todo =
let sigma_todo1, sigma_todo2 = sigma_todo in
@ -703,12 +703,12 @@ let sigma_lift_to_pe sigma =
list_map hpred_lift_to_pe sigma
(** [generic_para_create] takes a correspondence, and a sigma
and a list of expressions for the first part of this
correspondence. Then, it creates a renaming of expressions
in the domain of the given correspondence, and applies this
renaming to the given sigma. The result is a tuple of the renaming,
the renamed sigma, ids for existentially quantified expressions,
ids for shared expressions, and shared expressions. *)
and a list of expressions for the first part of this
correspondence. Then, it creates a renaming of expressions
in the domain of the given correspondence, and applies this
renaming to the given sigma. The result is a tuple of the renaming,
the renamed sigma, ids for existentially quantified expressions,
ids for shared expressions, and shared expressions. *)
let generic_para_create corres sigma1 elist1 =
let corres_ids =
let not_same_consts = function
@ -732,9 +732,9 @@ let generic_para_create corres sigma1 elist1 =
(renaming, body, ids_exists, ids_shared, es_shared)
(** [hpara_create] takes a correspondence, and a sigma, a root
and a next for the first part of this correspondence. Then, it creates a
hpara and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *)
and a next for the first part of this correspondence. Then, it creates a
hpara and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *)
let hpara_create corres sigma1 root1 next1 =
let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; next1] in
@ -755,9 +755,9 @@ let hpara_create corres sigma1 root1 next1 =
(hpara, es_shared)
(** [hpara_dll_create] takes a correspondence, and a sigma, a root,
a blink and a flink for the first part of this correspondence. Then, it creates a
hpara_dll and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *)
a blink and a flink for the first part of this correspondence. Then, it creates a
hpara_dll and discovers a list of shared expressions that are
passed as arguments to hpara. Both of them are returned as a result. *)
let hpara_dll_create corres sigma1 root1 blink1 flink1 =
let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; blink1; flink1] in

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

@ -12,7 +12,7 @@
open Utils
(** This module models special c struct types from the Apple's Core Foundation libraries
for which there are particular rules for memory management. *)
for which there are particular rules for memory management. *)
module Core_foundation_model =
struct
@ -57,7 +57,7 @@ struct
"__CFTree";
"__CFURLEnumerator";
"__CFUUID"
]
]
let cf_network = [
"_CFHTTPAuthentication";
@ -67,7 +67,7 @@ struct
"__CFNetService";
"__CFNetServiceMonitor";
"__CFNetServiceBrowser"
]
]
let core_media = [
"OpaqueCMBlockBuffer";
@ -79,7 +79,7 @@ struct
"opaqueCMSimpleQueue";
"OpaqueCMClock";
"OpaqueCMTimebase"
]
]
let core_text = [
"__CTFont";
@ -95,21 +95,21 @@ struct
"__CTRunDelegate";
"__CTTextTab";
"__CTTypesetter"
]
]
let core_video = [
"__CVBuffer";
"__CVMetalTextureCache";
"__CVOpenGLESTextureCache";
"__CVPixelBufferPool"
]
]
let image_io = [
"CGImageDestination";
"CGImageMetadata";
"CGImageMetadataTag";
"CGImageSource"
]
]
let security = [
"__SecCertificate";
@ -121,7 +121,7 @@ struct
"__SecCode";
"__SecTrust";
"__SecRequirement"
]
]
let system_configuration = [
"__SCDynamicStore";
@ -133,7 +133,7 @@ struct
"__SCNetworkConnection";
"__SCNetworkReachability";
"__SCPreferences"
]
]
let core_graphics_types = [
"CGAffineTransform";
@ -165,7 +165,7 @@ struct
"CGPDFStream";
"CGPDFString";
"CGShading"
]
]
let core_foundation_types =
core_foundation @
@ -227,7 +227,7 @@ struct
let is_core_lib_create typ funct =
is_core_lib_type typ &&
((string_contains create funct) ||
(string_contains copy funct ))
(string_contains copy funct ))
let function_arg_is_cftype typ =
(string_contains cf_type typ)

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

@ -17,7 +17,7 @@ type procedure_type =
let print_map procname_map =
Procname.Hash.iter
(fun pname redefined ->
print_endline ((Procname.to_string pname)^" "^(string_of_bool redefined)))
print_endline ((Procname.to_string pname)^" "^(string_of_bool redefined)))
procname_map
let process_all_cfgs process_function default_value =
@ -86,13 +86,13 @@ let update_cfgs generated_proc_map =
with Not_found -> assert false in
if is_redefined then
(Cfg.Procdesc.remove cfg pname true;
Cg.node_set_defined cg pname false;
true)
Cg.node_set_defined cg pname false;
true)
else need_updating in
let need_updating = list_fold_right update_cfg_procdesc generated_procs false in
if need_updating then
(Cfg.store_cfg_to_file cfg_name false cfg;
Cg.store_to_file cg_name cg) in
Cg.store_to_file cg_name cg) in
process_all_cfgs update_cfg ()
let do_objc_preanalysis () =

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

@ -17,7 +17,7 @@ open Utils
(* =============== START of the Path module ===============*)
module Path : sig
(** type for paths *)
(** type for paths *)
type t
type session = int
@ -58,8 +58,8 @@ module Path : sig
val iter_all_nodes_nocalls : (Cfg.node -> unit) -> t -> unit
(** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
Do not iterate past the given position.
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] *)
Do not iterate past the given position.
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] *)
val iter_longest_sequence : (int -> t -> int -> Mangled.t option -> unit) -> Sil.path_pos option -> t -> unit
(** join two paths *)
@ -164,100 +164,100 @@ end = struct
else p
module Invariant = (** functions in this module either do not assume, or do not re-establish, the invariant on dummy stats *)
struct
(** check whether a stats is the dummy stats *)
let stats_is_dummy stats =
stats.max_length == - 1
(** return the stats of the path *)
(** assumes that the stats are computed *)
let get_stats = function
| Pstart (_, stats) -> stats
| Pnode (_, _, _, _, stats, _) -> stats
| Pjoin (_, _, stats) -> stats
| Pcall (_, _, _, stats) -> stats
(** 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) ->
if not (stats_is_dummy stats) then set_dummy_stats stats
| Pnode (node, exn_opt, session, path, stats, _) ->
if not (stats_is_dummy stats) then
begin
reset_stats path;
set_dummy_stats stats
end
| Pjoin (path1, path2, stats) ->
if not (stats_is_dummy stats) then
begin
reset_stats path1;
reset_stats path2;
set_dummy_stats stats
end
| Pcall (path1, pname, path2, stats) ->
if not (stats_is_dummy stats) then
begin
reset_stats path1;
reset_stats path2;
set_dummy_stats stats
end
(** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *)
(** Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats
is the length of a longest sequence of nodes in the path where [f] returned [true] on at least one node.
max_length is 0 if the path was visited but no node satisfying [f] was found. *)
(** Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *)
(** Since this breaks the invariant, it must be followed by reset_stats. *)
let rec compute_stats do_calls (f : Cfg.Node.t -> bool) =
let nodes_found stats = stats.max_length > 0 in
function
| Pstart (node, stats) ->
if stats_is_dummy stats then
begin
let found = f node in
stats.max_length <- if found then 1 else 0;
stats.linear_num <- 1.0;
end
| Pnode (node, exn_opt, session, path, stats, _) ->
if stats_is_dummy stats then
begin
compute_stats do_calls f path;
let stats1 = get_stats path in
let found = f node || nodes_found stats1 (* the order is important as f has side-effects *) in
stats.max_length <- if found then 1 + stats1.max_length else 0;
stats.linear_num <- stats1.linear_num;
end
| Pjoin (path1, path2, stats) ->
if stats_is_dummy stats then
begin
compute_stats do_calls f path1;
compute_stats do_calls f path2;
let stats1, stats2 = get_stats path1, get_stats path2 in
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) ->
if stats_is_dummy stats then
begin
let stats2 = match do_calls with
| true ->
compute_stats do_calls f path2;
get_stats path2
| false ->
{ max_length = 0;
linear_num = 0.0 } in
let stats1 =
let f' =
if nodes_found stats2
then fun _ -> true (* already found in call, no need to search before the call *)
else f in
compute_stats do_calls f' path1;
get_stats path1 in
stats.max_length <- stats1.max_length + stats2.max_length;
stats.linear_num <- stats1.linear_num;
end
end (* End of module Invariant *)
struct
(** check whether a stats is the dummy stats *)
let stats_is_dummy stats =
stats.max_length == - 1
(** return the stats of the path *)
(** assumes that the stats are computed *)
let get_stats = function
| Pstart (_, stats) -> stats
| Pnode (_, _, _, _, stats, _) -> stats
| Pjoin (_, _, stats) -> stats
| Pcall (_, _, _, stats) -> stats
(** 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) ->
if not (stats_is_dummy stats) then set_dummy_stats stats
| Pnode (node, exn_opt, session, path, stats, _) ->
if not (stats_is_dummy stats) then
begin
reset_stats path;
set_dummy_stats stats
end
| Pjoin (path1, path2, stats) ->
if not (stats_is_dummy stats) then
begin
reset_stats path1;
reset_stats path2;
set_dummy_stats stats
end
| Pcall (path1, pname, path2, stats) ->
if not (stats_is_dummy stats) then
begin
reset_stats path1;
reset_stats path2;
set_dummy_stats stats
end
(** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. *)
(** Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats
is the length of a longest sequence of nodes in the path where [f] returned [true] on at least one node.
max_length is 0 if the path was visited but no node satisfying [f] was found. *)
(** Assumes that the invariant holds beforehand, and ensures that all the stats are computed afterwards. *)
(** Since this breaks the invariant, it must be followed by reset_stats. *)
let rec compute_stats do_calls (f : Cfg.Node.t -> bool) =
let nodes_found stats = stats.max_length > 0 in
function
| Pstart (node, stats) ->
if stats_is_dummy stats then
begin
let found = f node in
stats.max_length <- if found then 1 else 0;
stats.linear_num <- 1.0;
end
| Pnode (node, exn_opt, session, path, stats, _) ->
if stats_is_dummy stats then
begin
compute_stats do_calls f path;
let stats1 = get_stats path in
let found = f node || nodes_found stats1 (* the order is important as f has side-effects *) in
stats.max_length <- if found then 1 + stats1.max_length else 0;
stats.linear_num <- stats1.linear_num;
end
| Pjoin (path1, path2, stats) ->
if stats_is_dummy stats then
begin
compute_stats do_calls f path1;
compute_stats do_calls f path2;
let stats1, stats2 = get_stats path1, get_stats path2 in
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) ->
if stats_is_dummy stats then
begin
let stats2 = match do_calls with
| true ->
compute_stats do_calls f path2;
get_stats path2
| false ->
{ max_length = 0;
linear_num = 0.0 } in
let stats1 =
let f' =
if nodes_found stats2
then fun _ -> true (* already found in call, no need to search before the call *)
else f in
compute_stats do_calls f' path1;
get_stats path1 in
stats.max_length <- stats1.max_length + stats2.max_length;
stats.linear_num <- stats1.linear_num;
end
end (* End of module Invariant *)
(** iterate over each node in the path, excluding calls, once *)
let iter_all_nodes_nocalls f path =
@ -279,7 +279,7 @@ end = struct
!found
(** iterate over the longest sequence belonging to the path, restricting to those where [filter] holds of some element.
if a node is reached via an exception, pass the exception information to [f] on the previous node *)
if a node is reached via an exception, pass the exception information to [f] on the previous node *)
let iter_longest_sequence_filter (f : int -> t -> int -> Mangled.t option -> unit) (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
@ -298,8 +298,8 @@ end = struct
Invariant.reset_stats path
(** iterate over the longest sequence belonging to the path, restricting to those containing the given position if given.
Do not iterate past the last occurrence of the given position.
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *)
Do not iterate past the last occurrence of the given position.
[f level path session exn_opt] is passed the current nesting [level] and [path] and previous [session] and possible exception [exn_opt] *)
let iter_longest_sequence (f : int -> t -> int -> Mangled.t option -> unit) (pos_opt : Sil.path_pos option) (path: t) : unit =
let filter node = match pos_opt with
| None -> true
@ -338,7 +338,7 @@ end = struct
let n = NodeMap.find node !map in
map := NodeMap.add node (n + 1) !map
with Not_found ->
map := NodeMap.add node 1 !map in
map := NodeMap.add node 1 !map in
iter_longest_sequence (fun level p s exn_opt -> add_node (curr_node p)) None path;
let max_rep_node = ref (Cfg.Node.dummy ()) in
let max_rep_num = ref 0 in
@ -372,8 +372,8 @@ end = struct
let delayed = ref PathMap.empty in
let add_path p =
try ignore (PathMap.find p !delayed) with Not_found ->
incr delayed_num;
delayed := PathMap.add p !delayed_num !delayed in
incr delayed_num;
delayed := PathMap.add p !delayed_num !delayed in
let path_seen p = (* path seen before *)
PathMap.mem p !delayed in
let rec add_delayed path =
@ -392,11 +392,11 @@ end = struct
let num = PathMap.find path !delayed in
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
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
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
@ -474,7 +474,7 @@ end = struct
if n <> 0 then n else Sil.loc_compare lt1.Errlog.lt_loc lt2.Errlog.lt_loc in
let relevant lt = lt.Errlog.lt_node_tags <> [] in
list_remove_irrelevant_duplicates compare relevant (list_rev !trace)
(* list_remove_duplicates compare (list_sort compare !trace) *)
(* list_remove_duplicates compare (list_sort compare !trace) *)
end
(* =============== END of the Path module ===============*)
@ -610,7 +610,7 @@ end = struct
if path_nodes_subset path path_old (* do not propagate new path if it has no new nodes *)
then res := PropMap.remove p !res
with Not_found ->
res := PropMap.remove p !res in
res := PropMap.remove p !res in
PropMap.iter rem ps2;
!res

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

@ -30,7 +30,7 @@ module AllPreds = struct
let preds' = Cfg.NodeSet.add nfrom preds in
NodeHash.replace preds_table nto preds'
with Not_found ->
NodeHash.add preds_table nto (Cfg.NodeSet.singleton nfrom) in
NodeHash.add preds_table nto (Cfg.NodeSet.singleton nfrom) in
let do_node n =
list_iter (add_edge false n) (Cfg.Node.get_succs n);
list_iter (add_edge true n) (Cfg.Node.get_exn n) in
@ -44,7 +44,7 @@ module AllPreds = struct
let preds = NodeHash.find preds_table n in
Cfg.NodeSet.elements preds
with Not_found ->
Cfg.Node.get_preds n
Cfg.Node.get_preds n
end
module Vset = Set.Make (struct
@ -69,21 +69,21 @@ let rec use_exp cfg pdesc (exp: Sil.exp) acc =
match exp with
| Sil.Var _ | Sil.Sizeof _ -> acc
| Sil.Const (Sil.Ctuple((Sil.Const (Sil.Cfun pname)):: _)) ->
(* for tuples representing the assignment of a block we take the block name *)
(* look for its procdesc and add its captured vars to the set of captured vars. *)
(* for tuples representing the assignment of a block we take the block name *)
(* look for its procdesc and add its captured vars to the set of captured vars. *)
let found_pd = ref None in
Cfg.iter_proc_desc cfg (fun pn pd -> if Procname.equal pn pname then found_pd:= Some pd);
let defining_proc = Cfg.Procdesc.get_proc_name pdesc in
(match !found_pd with
| Some pd ->
list_iter (fun (x, _) ->
captured_var:= Vset.add (Sil.mk_pvar x defining_proc) !captured_var
) (Cfg.Procdesc.get_captured pd)
| _ -> ());
| Some pd ->
list_iter (fun (x, _) ->
captured_var:= Vset.add (Sil.mk_pvar x defining_proc) !captured_var
) (Cfg.Procdesc.get_captured pd)
| _ -> ());
acc
| Sil.Const _ -> acc
| Sil.Lvar x ->
(* If x is a captured var in the current procdesc don't add it to acc *)
(* If x is a captured var in the current procdesc don't add it to acc *)
if is_captured_pvar pdesc x then acc else Vset.add x acc
| Sil.Cast (_, e) | Sil.UnOp (_, e, _) | Sil.Lfield (e, _, _) -> use_exp cfg pdesc e acc
| Sil.BinOp (_, e1, e2) | Sil.Lindex (e1, e2) -> use_exp cfg pdesc e1 (use_exp cfg pdesc e2 acc)
@ -193,7 +193,7 @@ end = struct
replace node newset;
if not (Vset.equal oldset newset) then Worklist.add node
with Not_found ->
replace node set; Worklist.add node in
replace node set; Worklist.add node in
list_iter do_node preds
let iter init f =
@ -298,7 +298,7 @@ let node_assigns_no_variables cfg node =
Vset.is_empty assign_set
(** Set the dead variables of a node, by default as dead_after.
If the node is a prune or a join node, propagate as dead_before in the successors *)
If the node is a prune or a join node, propagate as dead_before in the successors *)
let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
(* L.out " node %d: %a@." (Cfg.Node.get_id n) (Sil.pp_pvar_list pe_text) dead_pvars; *)
let seen = ref Cfg.NodeSet.empty in
@ -316,7 +316,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
| _ -> false in
match Cfg.Node.get_kind node with
| Cfg.Node.Prune_node _ | Cfg.Node.Join_node when node_assigns_no_variables cfg node && not (next_is_exit node) ->
(* cannot push nullify instructions after an assignment, as they could nullify the same variable *)
(* cannot push nullify instructions after an assignment, as they could nullify the same variable *)
let succs = Cfg.Node.get_succs node in
list_iter (add_after_prune_join false) succs
| _ ->
@ -329,7 +329,7 @@ let add_dead_pvars_after_conditionals_join cfg n dead_pvars =
add_after_prune_join true n
(** Find the set of dead variables for the procedure pname and add nullify instructions.
The variables that are possibly aliased are only considered just before the exit node. *)
The variables that are possibly aliased are only considered just before the exit node. *)
let analyze_and_annotate_proc cfg tenv pname pdesc =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in
let exit_node_is_succ node =
@ -341,7 +341,7 @@ let analyze_and_annotate_proc cfg tenv pname pdesc =
captured_var:= Vset.empty;
analyze_proc cfg tenv 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); *)
L.out " PROCEDURE %s@." (Procname.to_string pname); *)
let dead_pvars_added = ref 0 in
let dead_pvars_limit = 100000 in
let incr_dead_pvars_added pvars =
@ -350,26 +350,26 @@ let analyze_and_annotate_proc cfg tenv pname pdesc =
if !dead_pvars_added > dead_pvars_limit && !dead_pvars_added - num <= dead_pvars_limit
then L.err "WARNING: liveness: more than %d dead pvars added in procedure %a, stopping@." dead_pvars_limit Procname.pp pname in
Table.iter cand (fun n live_at_predecessors live_current -> (* set dead variables on nodes *)
let nonnull_pvars = Vset.inter (def_node cfg n live_at_predecessors) cand in (* live before, or assigned to *)
let dead_pvars = Vset.diff nonnull_pvars live_current in (* only nullify when variable become live *)
(* L.out " Node %s " (string_of_int (Cfg.Node.get_id n)); *)
let dead_pvars_no_captured = Vset.diff dead_pvars !captured_var in
(* print_aliased_var "@.@.Non-nullable variable computed: " nonnull_pvars;
print_aliased_var "@.Dead variable computed: " dead_pvars;
print_aliased_var "@.Captured variable computed: " !captured_var;
print_aliased_var "@.Dead variable excluding captured computed: " dead_pvars_no_captured; *)
let dead_pvars_no_alias = get_sorted_cand (Vset.diff dead_pvars_no_captured !aliased_var) in
(* print_aliased_var_l "@. Final Dead variable computed: " dead_pvars_no_alias; *)
let dead_pvars_to_add =
if exit_node_is_succ n (* add dead aliased vars just before the exit node *)
then dead_pvars_no_alias @ (get_sorted_cand (Vset.inter cand !aliased_var))
else dead_pvars_no_alias in
incr_dead_pvars_added dead_pvars_to_add;
if !dead_pvars_added < dead_pvars_limit then add_dead_pvars_after_conditionals_join cfg n dead_pvars_to_add);
let nonnull_pvars = Vset.inter (def_node cfg n live_at_predecessors) cand in (* live before, or assigned to *)
let dead_pvars = Vset.diff nonnull_pvars live_current in (* only nullify when variable become live *)
(* L.out " Node %s " (string_of_int (Cfg.Node.get_id n)); *)
let dead_pvars_no_captured = Vset.diff dead_pvars !captured_var in
(* print_aliased_var "@.@.Non-nullable variable computed: " nonnull_pvars;
print_aliased_var "@.Dead variable computed: " dead_pvars;
print_aliased_var "@.Captured variable computed: " !captured_var;
print_aliased_var "@.Dead variable excluding captured computed: " dead_pvars_no_captured; *)
let dead_pvars_no_alias = get_sorted_cand (Vset.diff dead_pvars_no_captured !aliased_var) in
(* print_aliased_var_l "@. Final Dead variable computed: " dead_pvars_no_alias; *)
let dead_pvars_to_add =
if exit_node_is_succ n (* add dead aliased vars just before the exit node *)
then dead_pvars_no_alias @ (get_sorted_cand (Vset.inter cand !aliased_var))
else dead_pvars_no_alias in
incr_dead_pvars_added dead_pvars_to_add;
if !dead_pvars_added < dead_pvars_limit then add_dead_pvars_after_conditionals_join cfg n dead_pvars_to_add);
list_iter (fun n -> (* generate nullify instructions *)
let dead_pvs_after = Cfg.Node.get_dead_pvars n true in
let dead_pvs_before = Cfg.Node.get_dead_pvars n false in
node_add_nullify_instrs n dead_pvs_after dead_pvs_before)
let dead_pvs_after = Cfg.Node.get_dead_pvars n true in
let dead_pvs_before = Cfg.Node.get_dead_pvars n false in
node_add_nullify_instrs n dead_pvs_after dead_pvs_before)
(Cfg.Procdesc.get_nodes pdesc);
Table.reset ()

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

@ -57,16 +57,16 @@ end = struct
Hashtbl.replace log_files (node_fname, !DB.current_source) fd;
if needs_initialization then
(F.fprintf fmt "<center><h1>Cfg Node %a</h1></center>" (Io_infer.Html.pp_line_link ~text: (Some (string_of_int nodeid)) [".."]) loc.Sil.line;
F.fprintf fmt "PROC: %a LINE:%a\n" (Io_infer.Html.pp_proc_link [".."] proc_name) (Escape.escape_xml (Procname.to_string proc_name)) (Io_infer.Html.pp_line_link [".."]) loc.Sil.line;
F.fprintf fmt "<br>PREDS:@\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) preds;
F.fprintf fmt "<br>SUCCS: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) succs;
F.fprintf fmt "<br>EXN: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) exn;
F.fprintf fmt "<br>@\n";
F.pp_print_flush fmt ();
true
F.fprintf fmt "PROC: %a LINE:%a\n" (Io_infer.Html.pp_proc_link [".."] proc_name) (Escape.escape_xml (Procname.to_string proc_name)) (Io_infer.Html.pp_line_link [".."]) loc.Sil.line;
F.fprintf fmt "<br>PREDS:@\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) preds;
F.fprintf fmt "<br>SUCCS: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) succs;
F.fprintf fmt "<br>EXN: @\n";
list_iter (fun node -> Io_infer.Html.pp_node_link [".."] "" (list_map Cfg.Node.get_id (Cfg.Node.get_preds node)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs node)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn node)) (is_visited node) false fmt (Cfg.Node.get_id node)) exn;
F.fprintf fmt "<br>@\n";
F.pp_print_flush fmt ();
true
)
else false
@ -220,7 +220,7 @@ let force_delayed_prints () =
let _start_session node (loc: Sil.location) proc_name session =
let node_id = Cfg.Node.get_id node in
(if Log_nodes.start_node node_id loc proc_name (Cfg.Node.get_preds node) (Cfg.Node.get_succs node) (Cfg.Node.get_exn node)
then F.fprintf !html_formatter "%a@[<v>%a@]%a" Io_infer.Html.pp_start_color Green (Cfg.Node.pp_instr (pe_html Green) None ~sub_instrs: true) node Io_infer.Html.pp_end_color ());
then F.fprintf !html_formatter "%a@[<v>%a@]%a" Io_infer.Html.pp_start_color Green (Cfg.Node.pp_instr (pe_html Green) None ~sub_instrs: true) node Io_infer.Html.pp_end_color ());
F.fprintf !html_formatter "%a%a" Io_infer.Html.pp_hline () (Io_infer.Html.pp_session_link ~with_name: true [".."]) (node_id, session, loc.Sil.line);
F.fprintf !html_formatter "<LISTING>%a" Io_infer.Html.pp_start_color Black
@ -249,17 +249,17 @@ let _proc_write_log whole_seconds cfg pname =
linenum;
list_iter
(fun n -> Io_infer.Html.pp_node_link []
(Cfg.Node.get_description (pe_html Black) n)
(list_map Cfg.Node.get_id (Cfg.Node.get_preds n))
(list_map Cfg.Node.get_id (Cfg.Node.get_succs n))
(list_map Cfg.Node.get_id (Cfg.Node.get_exn n))
(is_visited n) false fmt (Cfg.Node.get_id n))
(Cfg.Node.get_description (pe_html Black) n)
(list_map Cfg.Node.get_id (Cfg.Node.get_preds n))
(list_map Cfg.Node.get_id (Cfg.Node.get_succs n))
(list_map Cfg.Node.get_id (Cfg.Node.get_exn n))
(is_visited n) false fmt (Cfg.Node.get_id n))
nodes;
(match Specs.get_summary pname with
| None -> ()
| Some summary ->
Specs.pp_summary (pe_html Black) whole_seconds fmt summary;
Io_infer.Html.close (fd, fmt))
| None -> ()
| Some summary ->
Specs.pp_summary (pe_html Black) whole_seconds fmt summary;
Io_infer.Html.close (fd, fmt))
| None -> ()
let proc_write_log whole_seconds cfg pname =
@ -275,7 +275,7 @@ let create_errors_per_line err_log =
let set = Hashtbl.find err_per_line loc.Sil.line in
Hashtbl.replace err_per_line loc.Sil.line (StringSet.add err_str set)
with Not_found ->
Hashtbl.add err_per_line loc.Sil.line (StringSet.singleton err_str) in
Hashtbl.add err_per_line loc.Sil.line (StringSet.singleton err_str) in
Errlog.iter add_err err_log;
err_per_line
@ -284,7 +284,7 @@ let create_err_message err_string =
"\n<div class=\"msg\" style=\"margin-left:9ex\">" ^ err_string ^ "</div>"
(** Module to read specific lines from files.
The data from any file will stay in memory until the handle is collected by the gc *)
The data from any file will stay in memory until the handle is collected by the gc *)
module LineReader : sig
type t
@ -322,18 +322,18 @@ end = struct
done;
assert false (* execution never reaches here *)
with End_of_file ->
(close_in cin;
Array.of_list (list_rev !lines))
(close_in cin;
Array.of_list (list_rev !lines))
let file_data (hash: t) fname =
try
Some (Hashtbl.find hash fname)
with Not_found ->
try
let lines_arr = read_file (DB.source_file_to_string fname) in
Hashtbl.add hash fname lines_arr;
Some lines_arr
with exn when exn_not_timeout exn -> None
try
let lines_arr = read_file (DB.source_file_to_string fname) in
Hashtbl.add hash fname lines_arr;
Some lines_arr
with exn when exn_not_timeout exn -> None
let from_file_linenum_original hash fname linenum =
match file_data hash fname with
@ -382,8 +382,8 @@ let c_file_write_html proc_is_active linereader fname tenv cfg =
let err_per_line = create_errors_per_line global_err_log in
try
(let s = "<center><h1>File " ^ (DB.source_file_to_string !DB.current_source) ^ "</h1></center>\n" ^
"<table class=\"code\">\n" in
F.fprintf fmt "%s" s);
"<table class=\"code\">\n" in
F.fprintf fmt "%s" s);
let linenum = ref 0 in
while true do
incr linenum;
@ -404,22 +404,22 @@ let c_file_write_html proc_is_active linereader fname tenv cfg =
"<tr><td class=\"num\" id=\"" ^ line_str ^ "\">" ^ linenum_str ^ "</td><td class=\"line\">" ^ line_html in
F.fprintf fmt "%s" str;
list_iter (fun n ->
let isproof = Specs.Visitedset.mem (Cfg.Node.get_id n, []) !proof_cover in
Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum;
let isproof = Specs.Visitedset.mem (Cfg.Node.get_id n, []) !proof_cover in
Io_infer.Html.pp_node_link [fname_encoding] (Cfg.Node.get_description (pe_html Black) n) (list_map Cfg.Node.get_id (Cfg.Node.get_preds n)) (list_map Cfg.Node.get_id (Cfg.Node.get_succs n)) (list_map Cfg.Node.get_id (Cfg.Node.get_exn n)) (is_visited n) isproof fmt (Cfg.Node.get_id n)) nodes_at_linenum;
list_iter (fun n -> match Cfg.Node.get_kind n with
| Cfg.Node.Start_node proc_desc ->
let proc_name = Cfg.Procdesc.get_proc_name proc_desc in
let num_specs = list_length (Specs.get_specs proc_name) in
let label = (Escape.escape_xml (Procname.to_string proc_name)) ^ ": " ^ (string_of_int num_specs) ^ " specs" in
Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label
| _ -> ()) nodes_at_linenum;
| Cfg.Node.Start_node proc_desc ->
let proc_name = Cfg.Procdesc.get_proc_name proc_desc in
let num_specs = list_length (Specs.get_specs proc_name) in
let label = (Escape.escape_xml (Procname.to_string proc_name)) ^ ": " ^ (string_of_int num_specs) ^ " specs" in
Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label
| _ -> ()) nodes_at_linenum;
list_iter (fun err_string -> F.fprintf fmt "%s" (create_err_message err_string)) errors_at_linenum;
F.fprintf fmt "%s" "</td></tr>\n"
done
with End_of_file ->
(F.fprintf fmt "%s" "</table>\n";
Errlog.pp_html [fname_encoding] fmt global_err_log;
Io_infer.Html.close (fd, fmt))
(F.fprintf fmt "%s" "</table>\n";
Errlog.pp_html [fname_encoding] fmt global_err_log;
Io_infer.Html.close (fd, fmt))
let c_files_write_html linereader exe_env =
let proc_is_active = Exe_env.proc_is_active exe_env in

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

@ -238,9 +238,9 @@ let java_is_static = function
let java_to_string ?withclass: (wc = false) j verbosity =
match verbosity with
| VERBOSE | NON_VERBOSE ->
(* if verbose, then package.class.method(params): rtype,
else rtype package.class.method(params)
verbose is used for example to create unique filenames, non_verbose to create reports *)
(* if verbose, then package.class.method(params): rtype,
else rtype package.class.method(params)
verbose is used for example to create unique filenames, non_verbose to create reports *)
let return_type = java_return_type_to_string j verbosity in
let params = java_param_list_to_string j.parameters verbosity in
let classname = java_type_to_string j.classname verbosity in
@ -279,16 +279,16 @@ let java_is_anonymous_inner_class = function
| _ -> false
(** Check if the last parameter is a hidden inner class, and remove it if present.
This is used in private constructors, where a proxy constructor is generated
with an extra parameter and calls the normal constructor. *)
This is used in private constructors, where a proxy constructor is generated
with an extra parameter and calls the normal constructor. *)
let java_remove_hidden_inner_class_parameter = function
| JAVA js ->
(match list_rev js.parameters with
| (so, s) :: par' ->
if is_anonymous_inner_class_name s
then Some (JAVA { js with parameters = list_rev par'})
else None
| [] -> None)
| (so, s) :: par' ->
if is_anonymous_inner_class_name s
then Some (JAVA { js with parameters = list_rev par'})
else None
| [] -> None)
| _ -> None
(** Check if the procedure name is an anonymous inner class constructor. *)
@ -299,19 +299,19 @@ let java_is_anonymous_inner_class_constructor = function
| _ -> false
(** Check if the procedure name is an acess method (e.g. access$100 used to
access private members from a nested class. *)
access private members from a nested class. *)
let java_is_access_method = function
| JAVA js ->
(match string_split_character js.methodname '$' with
| Some "access", s ->
let is_int =
try ignore (int_of_string s); true with Failure _ -> false in
is_int
| _ -> false)
| Some "access", s ->
let is_int =
try ignore (int_of_string s); true with Failure _ -> false in
is_int
| _ -> false)
| _ -> false
(** Check if the proc name has the type of a java vararg.
Note: currently only checks that the last argument has type Object[]. *)
Note: currently only checks that the last argument has type Object[]. *)
let java_is_vararg = function
| JAVA js ->
begin
@ -342,7 +342,7 @@ let is_infer_undefined pn = match pn with
let regexp = Str.regexp "com.facebook.infer.models.InferUndefined" in
Str.string_match regexp (java_get_class pn) 0
| _ ->
(* TODO: add cases for obj-c, c, c++ *)
(* TODO: add cases for obj-c, c, c++ *)
false
(** to_string for C_FUNCTION and STATIC types *)

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

@ -15,8 +15,8 @@ module F = Format
open Utils
(** type to describe different strategies for initializing fields of a structure. [No_init] does not
initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh
variables (C) or default values (Java). *)
initialize any fields of the struct. [Fld_init] initializes the fields of the struct with fresh
variables (C) or default values (Java). *)
type struct_init_mode =
| No_init
| Fld_init
@ -31,12 +31,12 @@ type normal = Normal (** kind for normal props, i.e. normalized *)
type exposed = Exposed (** kind for exposed props *)
(** A proposition. The following invariants are mantained. [sub] is of
the form id1 = e1 ... idn = en where: the id's are distinct and do not
occur in the e's nor in [pi] or [sigma]; the id's are in sorted
order; the id's are not existentials; if idn = yn (for yn not
existential) then idn < yn in the order on ident's. [pi] is sorted
and normalized, and does not contain x = e. [sigma] is sorted and
normalized. *)
the form id1 = e1 ... idn = en where: the id's are distinct and do not
occur in the e's nor in [pi] or [sigma]; the id's are in sorted
order; the id's are not existentials; if idn = yn (for yn not
existential) then idn < yn in the order on ident's. [pi] is sorted
and normalized, and does not contain x = e. [sigma] is sorted and
normalized. *)
type 'a t =
{ sigma: Sil.hpred list;
sub: Sil.subst;
@ -127,10 +127,10 @@ let pp_hpred_stackvar pe0 env f hpred =
{ pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *)
| _ -> pe in
(match pe'.pe_kind with
| PP_TEXT | PP_HTML ->
F.fprintf f "%a = %a:%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te
| PP_LATEX ->
F.fprintf f "%a{=}%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se)
| PP_TEXT | PP_HTML ->
F.fprintf f "%a = %a:%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te
| PP_LATEX ->
F.fprintf f "%a{=}%a" (Sil.pp_pvar_value pe') pvar (Sil.pp_sexp pe') se)
| Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> assert false (* should not happen *)
end;
Sil.color_post_wrapper changed pe0 f
@ -173,7 +173,7 @@ let pp_sigma pe =
pp_semicolon_seq pe (Sil.pp_hpred pe)
(** Split sigma into stack and nonstack parts.
The boolean indicates whether the stack should only include local variales. *)
The boolean indicates whether the stack should only include local variales. *)
let sigma_get_stack_nonstack only_local_vars sigma =
let hpred_is_stack_var = function
| Sil.Hpointsto (Sil.Lvar pvar, _, _) -> not only_local_vars || Sil.pvar_is_local pvar
@ -188,8 +188,8 @@ let pp_sigma_simple pe env fmt sigma =
if sg != [] then Format.fprintf fmt "%a" (pp_semicolon_seq pe (pp_hpred_stackvar pe env)) sg in
let pp_nl fmt doit = if doit then
(match pe.pe_kind with
| PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n"
| PP_LATEX -> Format.fprintf fmt " ; \\\\@\n") in
| PP_TEXT | PP_HTML -> Format.fprintf fmt " ;@\n"
| PP_LATEX -> Format.fprintf fmt " ; \\\\@\n") in
let pp_nonstack fmt = pp_semicolon_seq pe (Sil.pp_hpred_env pe (Some env)) fmt in
if sigma_stack != [] || sigma_nonstack != [] then
Format.fprintf fmt "%a%a%a" pp_stack sigma_stack pp_nl (sigma_stack != [] && sigma_nonstack != []) pp_nonstack sigma_nonstack
@ -312,7 +312,7 @@ let pp_prop pe0 f prop =
else
F.fprintf f "%a%a%a" pp_pure () (pp_sigma pe) prop.sigma (pp_footprint pe) prop in
if !Config.forcing_delayed_prints then (** print in html mode *)
F.fprintf f "%a%a%a" Io_infer.Html.pp_start_color Blue do_print () Io_infer.Html.pp_end_color ()
F.fprintf f "%a%a%a" Io_infer.Html.pp_start_color Blue do_print () Io_infer.Html.pp_end_color ()
else
do_print f () (** print in text mode *)
@ -590,20 +590,20 @@ let sym_eval abs e =
let e' = Sil.BinOp (Sil.PlusA, e1, e2) in
eval (Sil.Lindex (ep, e'))
| Sil.BinOp (Sil.PlusPI, (Sil.BinOp (Sil.PlusPI, e11, e12)), e2) -> (* take care of pattern ((ptr + off1) + off2) *)
(* progress: convert inner +I to +A *)
(* progress: convert inner +I to +A *)
let e2' = Sil.BinOp (Sil.PlusA, e12, e2) in
eval (Sil.BinOp (Sil.PlusPI, e11, e2'))
| Sil.BinOp (Sil.PlusA, (Sil.Sizeof (Sil.Tstruct (ftal, sftal, csu, name_opt, supers, def_mthds, iann), st) 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 struct s { ... t arr[n + k] ... } *)
given a struct declatead as struct s { ... t arr[n] ... }, allocation pattern malloc(sizeof(struct s) + k * siezof(t))
turn it into struct s { ... t arr[n + k] ... } *)
let e1' = eval e1 in
let e2' = eval e2 in
(match list_rev ftal, e2' with
(fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp ->
let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in
let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in
Sil.Sizeof(Sil.Tstruct (list_rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st)
| _ -> Sil.BinOp(Sil.PlusA, e1', e2'))
(fname, Sil.Tarray(typ, size), _):: ltfa, Sil.BinOp(Sil.Mult, num_elem, Sil.Sizeof (texp, st)) when ftal != [] && Sil.typ_equal typ texp ->
let size' = Sil.BinOp(Sil.PlusA, size, num_elem) in
let ltfa' = (fname, Sil.Tarray(typ, size'), Sil.item_annotation_empty) :: ltfa in
Sil.Sizeof(Sil.Tstruct (list_rev ltfa', sftal, csu, name_opt, supers, def_mthds, iann), st)
| _ -> Sil.BinOp(Sil.PlusA, e1', e2'))
| Sil.BinOp (Sil.PlusA as oplus, e1, e2)
| Sil.BinOp (Sil.PlusPI as oplus, e1, e2) ->
let e1' = eval e1 in
@ -638,7 +638,7 @@ let sym_eval abs e =
| Sil.Const (Sil.Cint n2), Sil.BinOp (Sil.MinusA, Sil.Const (Sil.Cint n1), e) ->
Sil.exp_int (n1 ++ n2) --- e
| Sil.BinOp (Sil.MinusA, e1, e2), e3 -> (* (e1-e2)+e3 --> e1 + (e3-e2) *)
(* progress: brings + to the outside *)
(* progress: brings + to the outside *)
eval (e1 +++ (e3 --- e2))
| _, Sil.Const _ ->
e1' +++ e2'
@ -732,7 +732,7 @@ let sym_eval abs e =
| Sil.Const (Sil.Cfloat v), Sil.Const (Sil.Cfloat w) ->
Sil.exp_float (v /.w)
| Sil.Sizeof(Sil.Tarray(typ, size), _), Sil.Sizeof(_typ, _) (* pattern: sizeof(arr) / sizeof(arr[0]) = size of arr *)
when Sil.typ_equal _typ typ ->
when Sil.typ_equal _typ typ ->
size
| _ ->
if abs then Sil.exp_get_undefined false else Sil.BinOp (Sil.Div, e1', e2')
@ -884,57 +884,57 @@ let atom_const_lt_exp = function
let mk_inequality e =
match e with
| Sil.BinOp (Sil.Le, base, Sil.Const (Sil.Cint n)) ->
(* base <= n case *)
(* base <= n case *)
let nbase = exp_normalize_noabs Sil.sub_empty base in
(match nbase with
| Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n ++ n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.UnOp(Sil.Neg, new_base, _) ->
(* In this case, base = -new_base. Construct -n-1 < new_base. *)
let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Lt, new_offset, new_base) in
Sil.Aeq (new_e, Sil.exp_one)
| _ -> Sil.Aeq (e, Sil.exp_one))
| Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n ++ n') in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.UnOp(Sil.Neg, new_base, _) ->
(* In this case, base = -new_base. Construct -n-1 < new_base. *)
let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Lt, new_offset, new_base) in
Sil.Aeq (new_e, Sil.exp_one)
| _ -> Sil.Aeq (e, Sil.exp_one))
| Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n), base) ->
(* n < base case *)
(* n < base case *)
let nbase = exp_normalize_noabs Sil.sub_empty base in
(match nbase with
| Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n ++ n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.UnOp(Sil.Neg, new_base, _) ->
(* In this case, base = -new_base. Construct new_base <= -n-1 *)
let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Le, new_base, new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| _ -> Sil.Aeq (e, Sil.exp_one))
| Sil.BinOp(Sil.PlusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.PlusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n -- n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, base', Sil.Const (Sil.Cint n')) ->
let new_offset = Sil.exp_int (n ++ n') in
let new_e = Sil.BinOp (Sil.Lt, new_offset, base') in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.BinOp(Sil.MinusA, Sil.Const (Sil.Cint n'), base') ->
let new_offset = Sil.exp_int (n' -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Le, base', new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| Sil.UnOp(Sil.Neg, new_base, _) ->
(* In this case, base = -new_base. Construct new_base <= -n-1 *)
let new_offset = Sil.exp_int (Sil.Int.zero -- n -- Sil.Int.one) in
let new_e = Sil.BinOp (Sil.Le, new_base, new_offset) in
Sil.Aeq (new_e, Sil.exp_one)
| _ -> Sil.Aeq (e, Sil.exp_one))
| _ -> Sil.Aeq (e, Sil.exp_one)
(** Normalize an inequality *)
@ -962,9 +962,9 @@ let inequality_normalize a =
let rec combine pacc nacc = function
| x:: ps, y:: ng ->
(match Sil.exp_compare x y with
| n when n < 0 -> combine (x:: pacc) nacc (ps, y :: ng)
| 0 -> combine pacc nacc (ps, ng)
| _ -> combine pacc (y:: nacc) (x :: ps, ng))
| n when n < 0 -> combine (x:: pacc) nacc (ps, y :: ng)
| 0 -> combine pacc nacc (ps, ng)
| _ -> combine pacc (y:: nacc) (x :: ps, ng))
| ps, ng -> (list_rev pacc) @ ps, (list_rev nacc) @ ng in
let pos'', neg'' = combine [] [] (pos', neg') in
(pos'', neg'', off) in
@ -997,8 +997,8 @@ let inequality_normalize a =
let exp_reorder e1 e2 = if Sil.exp_compare e1 e2 <= 0 then (e1, e2) else (e2, e1)
(** Normalize an atom.
We keep the convention that inequalities with constants
are only of the form [e <= n] and [n < e]. *)
We keep the convention that inequalities with constants
are only of the form [e <= n] and [n < e]. *)
let atom_normalize sub a0 =
let a = Sil.atom_sub sub a0 in
let rec normalize_eq eq = match eq with
@ -1072,7 +1072,7 @@ let rec strexp_normalize sub se =
| _ ->
let fld_cnts' =
list_map (fun (fld, cnt) ->
fld, strexp_normalize sub cnt) fld_cnts in
fld, strexp_normalize sub cnt) fld_cnts in
let fld_cnts'' = list_sort Sil.fld_strexp_compare fld_cnts' in
Sil.Estruct (fld_cnts'', inst)
end
@ -1085,8 +1085,8 @@ let rec strexp_normalize sub se =
| _ ->
let idx_cnts' =
list_map (fun (idx, cnt) ->
let idx' = exp_normalize sub idx in
idx', strexp_normalize sub cnt) idx_cnts in
let idx' = exp_normalize sub idx in
idx', strexp_normalize sub cnt) idx_cnts in
let idx_cnts'' =
list_sort Sil.exp_strexp_compare idx_cnts' in
Sil.Earray (size', idx_cnts'', inst)
@ -1144,7 +1144,7 @@ let mk_ptsto lexp sexp te =
Sil.Hpointsto(lexp, nsexp, te)
(** Construct a points-to predicate for an expression using either the provided expression [name] as
base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
base for fresh identifiers. If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
let mk_ptsto_exp tenvo struct_init_mode (exp, te, expo) inst : Sil.hpred =
let default_strexp () = match te with
| Sil.Sizeof (typ, st) ->
@ -1177,12 +1177,12 @@ let rec hpred_normalize sub hpred =
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 *)
(* 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 *)
(* 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)
@ -1269,12 +1269,12 @@ let pi_tighten_ineq pi =
(** remove duplicate atoms and redundant inequalities from a sorted pi *)
let rec pi_sorted_remove_redundant = function
| (Sil.Aeq(Sil.BinOp (Sil.Le, e1, Sil.Const (Sil.Cint n1)), Sil.Const (Sil.Cint i1)) as a1) ::
Sil.Aeq(Sil.BinOp (Sil.Le, e2, Sil.Const (Sil.Cint n2)), Sil.Const (Sil.Cint i2)) :: rest
when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* second inequality redundant *)
Sil.Aeq(Sil.BinOp (Sil.Le, e2, Sil.Const (Sil.Cint n2)), Sil.Const (Sil.Cint i2)) :: rest
when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* second inequality redundant *)
pi_sorted_remove_redundant (a1 :: rest)
| Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n1), e1), Sil.Const (Sil.Cint i1)) ::
(Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n2), e2), Sil.Const (Sil.Cint i2)) as a2) :: rest
when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* first inequality redundant *)
(Sil.Aeq(Sil.BinOp (Sil.Lt, Sil.Const (Sil.Cint n2), e2), Sil.Const (Sil.Cint i2)) as a2) :: rest
when Sil.Int.isone i1 && Sil.Int.isone i2 && Sil.exp_equal e1 e2 && Sil.Int.lt n1 n2 -> (* first inequality redundant *)
pi_sorted_remove_redundant (a2 :: rest)
| a1:: a2:: rest ->
if Sil.atom_equal a1 a2 then pi_sorted_remove_redundant (a2 :: rest)
@ -1293,19 +1293,19 @@ let sigma_get_unsigned_exps sigma =
!uexps
(** Normalization of pi.
The normalization filters out obviously - true disequalities, such as e <> e + 1. *)
The normalization filters out obviously - true disequalities, such as e <> e + 1. *)
let pi_normalize sub sigma pi0 =
let pi = list_map (atom_normalize sub) pi0 in
let ineq_list, nonineq_list = pi_tighten_ineq pi in
let syntactically_different = function
| Sil.BinOp(op1, e1, Sil.Const(c1)), Sil.BinOp(op2, e2, Sil.Const(c2))
when Sil.exp_equal e1 e2 ->
when Sil.exp_equal e1 e2 ->
Sil.binop_equal op1 op2 && Sil.binop_injective op1 && not (Sil.const_equal c1 c2)
| e1, Sil.BinOp(op2, e2, Sil.Const(c2))
when Sil.exp_equal e1 e2 ->
when Sil.exp_equal e1 e2 ->
Sil.binop_injective op2 && Sil.binop_is_zero_runit op2 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c2)
| Sil.BinOp(op1, e1, Sil.Const(c1)), e2
when Sil.exp_equal e1 e2 ->
when Sil.exp_equal e1 e2 ->
Sil.binop_injective op1 && Sil.binop_is_zero_runit op1 && not (Sil.const_equal (Sil.Cint Sil.Int.zero) c1)
| _ -> false in
let filter_useful_atom =
@ -1347,13 +1347,13 @@ let footprint_normalize prop =
let npi', nsigma' =
if Sil.fav_is_empty fp_vars then npi, nsigma
else (* replace primed vars by fresh footprint vars *)
let ids_primed = Sil.fav_to_list fp_vars in
let ids_footprint =
list_map (fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in
let ren_sub = Sil.sub_of_list (list_map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_footprint) in
let nsigma' = sigma_normalize Sil.sub_empty (sigma_sub ren_sub nsigma) in
let npi' = pi_normalize Sil.sub_empty nsigma' (pi_sub ren_sub npi) in
(npi', nsigma') in
let ids_primed = Sil.fav_to_list fp_vars in
let ids_footprint =
list_map (fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in
let ren_sub = Sil.sub_of_list (list_map (fun (id1, id2) -> (id1, Sil.Var id2)) ids_footprint) in
let nsigma' = sigma_normalize Sil.sub_empty (sigma_sub ren_sub nsigma) in
let npi' = pi_normalize Sil.sub_empty nsigma' (pi_sub ren_sub npi) in
(npi', nsigma') in
{ prop with foot_pi = npi'; foot_sigma = nsigma' }
let exp_normalize_prop prop exp =
@ -1366,14 +1366,14 @@ let lexp_normalize_prop p lexp =
let nroot = exp_normalize_prop p root in
let noffsets =
list_map (fun n -> match n with
| Sil.Off_fld _ -> n
| Sil.Off_index e -> Sil.Off_index (exp_normalize_prop p e)
| Sil.Off_fld _ -> n
| Sil.Off_index e -> Sil.Off_index (exp_normalize_prop p e)
) offsets in
Sil.exp_add_offsets nroot noffsets
(** 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. *)
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 typ_is_base = function
| Sil.Tint _ | Sil.Tfloat _ | Sil.Tstruct _ | Sil.Tvoid | Sil.Tfun _ -> true
@ -1464,24 +1464,24 @@ let prop_replace_sub sub p =
let mk_neq e1 e2 =
run_with_abs_val_eq_zero
(fun () ->
let ne1 = exp_normalize Sil.sub_empty e1 in
let ne2 = exp_normalize Sil.sub_empty e2 in
atom_normalize Sil.sub_empty (Sil.Aneq (ne1, ne2)))
let ne1 = exp_normalize Sil.sub_empty e1 in
let ne2 = exp_normalize Sil.sub_empty e2 in
atom_normalize Sil.sub_empty (Sil.Aneq (ne1, ne2)))
(** Sil.Construct an equality. *)
let mk_eq e1 e2 =
run_with_abs_val_eq_zero
(fun () ->
let ne1 = exp_normalize Sil.sub_empty e1 in
let ne2 = exp_normalize Sil.sub_empty e2 in
atom_normalize Sil.sub_empty (Sil.Aeq (ne1, ne2)))
let ne1 = exp_normalize Sil.sub_empty e1 in
let ne2 = exp_normalize Sil.sub_empty e2 in
atom_normalize Sil.sub_empty (Sil.Aeq (ne1, ne2)))
let unstructured_type = function
| Sil.Tstruct _ | Sil.Tarray _ -> false
| _ -> true
(** Construct a points-to predicate for a single program variable.
If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
let mk_ptsto_lvar tenv expand_structs inst ((pvar: Sil.pvar), texp, expo) : Sil.hpred =
mk_ptsto_exp tenv expand_structs (Sil.Lvar pvar, texp, expo) inst
@ -1518,12 +1518,12 @@ let prop_sigma_star (p : 'a t) (sigma : Sil.hpred list) : exposed t =
{ p with sigma = sigma' }
(** Eliminates all empty lsegs from sigma, and collect equalities
The empty lsegs include
(a) "lseg_pe para 0 e elist",
(b) "dllseg_pe para iF oB oF iB elist" with iF = 0 or iB = 0,
(c) "lseg_pe para e1 e2 elist" and the rest of sigma contains the "cell" e1,
(d) "dllseg_pe para iF oB oF iB elist" and the rest of sigma contains
cell iF or iB. *)
The empty lsegs include
(a) "lseg_pe para 0 e elist",
(b) "dllseg_pe para iF oB oF iB elist" with iF = 0 or iB = 0,
(c) "lseg_pe para e1 e2 elist" and the rest of sigma contains the "cell" e1,
(d) "dllseg_pe para iF oB oF iB elist" and the rest of sigma contains
cell iF or iB. *)
let sigma_remove_emptylseg sigma =
let alloc_set =
let rec f_alloc set = function
@ -1543,13 +1543,13 @@ let sigma_remove_emptylseg sigma =
| Sil.Hpointsto _ as hpred :: sigma' ->
f eqs_zero (hpred :: sigma_passed) sigma'
| Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) :: sigma'
when (Sil.exp_equal e1 Sil.exp_zero) || (Sil.ExpSet.mem e1 alloc_set) ->
when (Sil.exp_equal e1 Sil.exp_zero) || (Sil.ExpSet.mem e1 alloc_set) ->
f (Sil.Aeq(e1, e2) :: eqs_zero) sigma_passed sigma'
| Sil.Hlseg _ as hpred :: sigma' ->
f eqs_zero (hpred :: sigma_passed) sigma'
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) :: sigma'
when (Sil.exp_equal iF Sil.exp_zero) || (Sil.ExpSet.mem iF alloc_set)
|| (Sil.exp_equal iB Sil.exp_zero) || (Sil.ExpSet.mem iB alloc_set) ->
when (Sil.exp_equal iF Sil.exp_zero) || (Sil.ExpSet.mem iF alloc_set)
|| (Sil.exp_equal iB Sil.exp_zero) || (Sil.ExpSet.mem iB alloc_set) ->
f (Sil.Aeq(iF, oF):: Sil.Aeq(iB, oB):: eqs_zero) sigma_passed sigma'
| Sil.Hdllseg _ as hpred :: sigma' ->
f eqs_zero (hpred :: sigma_passed) sigma'
@ -1563,16 +1563,16 @@ let sigma_intro_nonemptylseg e1 e2 sigma =
| Sil.Hpointsto _ as hpred :: sigma' ->
f (hpred :: sigma_passed) sigma'
| Sil.Hlseg (Sil.Lseg_PE, para, f1, f2, shared) :: sigma'
when (Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2)
|| (Sil.exp_equal e2 f1 && Sil.exp_equal e1 f2) ->
when (Sil.exp_equal e1 f1 && Sil.exp_equal e2 f2)
|| (Sil.exp_equal e2 f1 && Sil.exp_equal e1 f2) ->
f (Sil.Hlseg (Sil.Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma'
| Sil.Hlseg _ as hpred :: sigma' ->
f (hpred :: sigma_passed) sigma'
| Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared) :: sigma'
when (Sil.exp_equal e1 iF && Sil.exp_equal e2 oF)
|| (Sil.exp_equal e2 iF && Sil.exp_equal e1 oF)
|| (Sil.exp_equal e1 iB && Sil.exp_equal e2 oB)
|| (Sil.exp_equal e2 iB && Sil.exp_equal e1 oB) ->
when (Sil.exp_equal e1 iF && Sil.exp_equal e2 oF)
|| (Sil.exp_equal e2 iF && Sil.exp_equal e1 oF)
|| (Sil.exp_equal e1 iB && Sil.exp_equal e2 oB)
|| (Sil.exp_equal e2 iB && Sil.exp_equal e1 oB) ->
f (Sil.Hdllseg (Sil.Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma'
| Sil.Hdllseg _ as hpred :: sigma' ->
f (hpred :: sigma_passed) sigma'
@ -1708,10 +1708,10 @@ let attributes_in_same_category attr1 attr2 =
let get_attribute prop exp category =
let atts = get_exp_attributes prop exp in
try Some (list_find
(fun att ->
Sil.attribute_category_equal
(Sil.attribute_to_category att) category)
atts)
(fun att ->
Sil.attribute_category_equal
(Sil.attribute_to_category att) category)
atts)
with Not_found -> None
let get_resource_undef_attribute prop exp =
@ -1875,12 +1875,12 @@ let find_arithmetic_problem proc_node_session prop exp =
walk exp;
try Some (Div0 (list_find check_zero !exps_divided)), !res
with Not_found ->
(match !uminus_unsigned with
| (e, t):: _ -> Some (UminusUnsigned (e, t)), !res
| _ -> None, !res)
(match !uminus_unsigned with
| (e, t):: _ -> Some (UminusUnsigned (e, t)), !res
| _ -> None, !res)
(** Deallocate the stack variables in [pvars], and replace them by normal variables.
Return the list of stack variables whose address was still present after deallocation. *)
Return the list of stack variables whose address was still present after deallocation. *)
let deallocate_stack_vars p pvars =
let filter = function
| Sil.Hpointsto (Sil.Lvar v, _, _) ->
@ -1890,11 +1890,11 @@ let deallocate_stack_vars p pvars =
let fresh_address_vars = ref [] in (* fresh vars substituted for the address of stack vars *)
let stack_vars_address_in_post = ref [] in (* stack vars whose address is still present *)
let exp_replace = list_map (function
| Sil.Hpointsto (Sil.Lvar v, _, _) ->
let freshv = Ident.create_fresh Ident.kprimed in
fresh_address_vars := (v, freshv) :: !fresh_address_vars;
(Sil.Lvar v, Sil.Var freshv)
| _ -> assert false) sigma_stack in
| Sil.Hpointsto (Sil.Lvar v, _, _) ->
let freshv = Ident.create_fresh Ident.kprimed in
fresh_address_vars := (v, freshv) :: !fresh_address_vars;
(Sil.Lvar v, Sil.Var freshv)
| _ -> assert false) sigma_stack in
let pi1 = list_map (fun (id, e) -> Sil.Aeq (Sil.Var id, e)) (Sil.sub_to_list p.sub) in
let pi = list_map (Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in
let p' = { p with sub = Sil.sub_empty; pi = []; sigma = sigma_replace_exp exp_replace sigma_other } in
@ -1903,11 +1903,11 @@ let deallocate_stack_vars p pvars =
let p'_fav = prop_fav p' in
let do_var (v, freshv) =
if Sil.fav_mem p'_fav freshv then (* the address of a de-allocated stack var in in the post *)
begin
stack_vars_address_in_post := v :: !stack_vars_address_in_post;
let check_attribute_change att_old att_new = () in
res := add_or_replace_exp_attribute check_attribute_change !res (Sil.Var freshv) (Sil.Adangling Sil.DAaddr_stack_var)
end in
begin
stack_vars_address_in_post := v :: !stack_vars_address_in_post;
let check_attribute_change att_old att_new = () in
res := add_or_replace_exp_attribute check_attribute_change !res (Sil.Var freshv) (Sil.Adangling Sil.DAaddr_stack_var)
end in
list_iter do_var !fresh_address_vars;
!res in
!stack_vars_address_in_post, list_fold_left prop_atom_and p'' pi
@ -1916,8 +1916,8 @@ let deallocate_stack_vars p pvars =
(** {1 Functions for transforming footprints into propositions.} *)
(** The ones used for abstraction add/remove local stacks in order to
stop the firing of some abstraction rules. The other usual
transforation functions do not use this hack. *)
stop the firing of some abstraction rules. The other usual
transforation functions do not use this hack. *)
(** Extract the footprint and return it as a prop *)
let extract_footprint p =
@ -1986,7 +1986,7 @@ let sigma_dfs_sort sigma =
list_iter ExpStack.push (next:: shared);
(hpred:: visited, list_rev_append cur seen)
| Sil.Hdllseg (_, _, iF, oB, oF, iB, shared)
when Sil.exp_equal e iF || Sil.exp_equal e iB ->
when Sil.exp_equal e iF || Sil.exp_equal e iB ->
list_iter ExpStack.push (oB:: oF:: shared);
(hpred:: visited, list_rev_append cur seen)
| _ ->
@ -2095,7 +2095,7 @@ let prop_rename_array_indices prop =
let not_same_base_lt_offsets e1 e2 =
match e1, e2 with
| Sil.BinOp(Sil.PlusA, e1', Sil.Const (Sil.Cint n1')),
Sil.BinOp(Sil.PlusA, e2', Sil.Const (Sil.Cint n2')) ->
Sil.BinOp(Sil.PlusA, e2', Sil.Const (Sil.Cint n2')) ->
not (Sil.exp_equal e1' e2' && Sil.Int.lt n1' n2')
| _ -> true in
let rec select_minimal_indices indices_seen = function
@ -2272,7 +2272,7 @@ let prop_rename_primed_footprint_vars p =
let sub_for_normalize = Sil.sub_empty in
(* It is fine to use the empty substituion during normalization
because the renaming maintains that a substitution is normalized *)
because the renaming maintains that a substitution is normalized *)
let nsub' = sub_normalize sub' in
let nsigma' = sigma_normalize sub_for_normalize sigma' in
let npi' = pi_normalize sub_for_normalize nsigma' pi' in
@ -2318,7 +2318,7 @@ let prop_ren_sub (ren_sub: Sil.subst) (prop: normal t) : normal t =
normalize (prop_sub ren_sub prop)
(** Existentially quantify the [ids] in [prop].
[ids] should not contain any primed variables. *)
[ids] should not contain any primed variables. *)
let exist_quantify fav prop =
let ids = Sil.fav_to_list fav in
if list_exists Ident.is_primed ids then assert false; (* sanity check *)
@ -2412,15 +2412,15 @@ type 'a prop_iter =
let prop_iter_create prop =
match prop.sigma with
| hpred:: sigma' -> Some
{ pit_sub = prop.sub;
pit_pi = prop.pi;
pit_newpi = [];
pit_old = [];
pit_curr = hpred;
pit_state = ();
pit_new = sigma';
pit_foot_pi = prop.foot_pi;
pit_foot_sigma = prop.foot_sigma }
{ pit_sub = prop.sub;
pit_pi = prop.pi;
pit_newpi = [];
pit_old = [];
pit_curr = hpred;
pit_state = ();
pit_new = sigma';
pit_foot_pi = prop.foot_pi;
pit_foot_sigma = prop.foot_sigma }
| _ -> None
(** Return the prop associated to the iterator. *)
@ -2434,13 +2434,13 @@ let prop_iter_to_prop iter =
prop iter.pit_newpi
(** Add an atom to the pi part of prop iter. The
first parameter records whether it is done
during footprint or during re - execution. *)
first parameter records whether it is done
during footprint or during re - execution. *)
let prop_iter_add_atom footprint iter atom =
{ iter with pit_newpi = (footprint, atom):: iter.pit_newpi }
(** Remove the current element of the iterator, and return the prop
associated to the resulting iterator *)
associated to the resulting iterator *)
let prop_iter_remove_curr_then_to_prop iter =
let sigma = list_rev_append iter.pit_old iter.pit_new in
let normalized_sigma = sigma_normalize iter.pit_sub sigma in
@ -2477,21 +2477,21 @@ let prop_iter_next iter =
match iter.pit_new with
| [] -> None
| hpred':: new' -> Some
{ iter with
pit_old = iter.pit_curr:: iter.pit_old;
pit_curr = hpred';
pit_state = ();
pit_new = new'}
{ iter with
pit_old = iter.pit_curr:: iter.pit_old;
pit_curr = hpred';
pit_state = ();
pit_new = new'}
let prop_iter_remove_curr_then_next iter =
match iter.pit_new with
| [] -> None
| hpred':: new' -> Some
{ iter with
pit_old = iter.pit_old;
pit_curr = hpred';
pit_state = ();
pit_new = new'}
{ iter with
pit_old = iter.pit_old;
pit_curr = hpred';
pit_state = ();
pit_new = new'}
(** Insert before the current element of the iterator. *)
let prop_iter_prev_then_insert iter hpred =
@ -2505,8 +2505,8 @@ let rec prop_iter_find iter filter =
| Some st -> Some { iter with pit_state = st }
| None ->
(match prop_iter_next iter with
| None -> None
| Some iter' -> prop_iter_find iter' filter)
| None -> None
| Some iter' -> prop_iter_find iter' filter)
(** Set the state of the iterator *)
let prop_iter_set_state iter state =
@ -2627,10 +2627,10 @@ let hpred_gc_fields (fav: Sil.fav) hpred = match hpred with
Sil.exp_fav_add fav e;
Sil.exp_fav_add fav te;
(match strexp_gc_fields fav se with
| None -> hpred
| Some se' ->
if Sil.strexp_compare se se' = 0 then hpred
else Sil.Hpointsto (e, se', te))
| None -> hpred
| Some se' ->
if Sil.strexp_compare se se' = 0 then hpred
else Sil.Hpointsto (e, se', te))
| Sil.Hlseg _ | Sil.Hdllseg _ ->
hpred
@ -2697,38 +2697,38 @@ let trans_land_lor op ((idl1, stml1), e1) ((idl2, stml2), e2) loc =
end
(** Input of this mehtod is an exp in a prop. Output is a formal variable or path from a
formal variable that is equal to the expression, or the OBJC_NULL attribute of the expression. *)
formal variable that is equal to the expression, or the OBJC_NULL attribute of the expression. *)
let find_equal_formal_path e prop =
let rec find_in_sigma e seen_hpreds =
list_fold_right (
fun hpred res ->
if list_mem Sil.hpred_equal hpred seen_hpreds then None
else
let seen_hpreds = hpred :: seen_hpreds in
match res with
| Some _ -> res
| None ->
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal(_, _) ), _)
when Sil.exp_equal exp2 e && (Sil.pvar_is_local pvar1 || Sil.pvar_is_seed pvar1) ->
Some (Sil.Lvar pvar1)
| Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) ->
list_fold_right (fun (field, strexp) res ->
match res with
| Some _ -> res
| None ->
match strexp with
| Sil.Eexp (exp2, _) when Sil.exp_equal exp2 e ->
(match find_in_sigma exp1 seen_hpreds with
| Some exp' -> Some (Sil.Lfield (exp', field, Sil.Tvoid))
| None -> None)
| _ -> None) fields None
| _ -> None) (get_sigma prop) None in
fun hpred res ->
if list_mem Sil.hpred_equal hpred seen_hpreds then None
else
let seen_hpreds = hpred :: seen_hpreds in
match res with
| Some _ -> res
| None ->
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal(_, _) ), _)
when Sil.exp_equal exp2 e && (Sil.pvar_is_local pvar1 || Sil.pvar_is_seed pvar1) ->
Some (Sil.Lvar pvar1)
| Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) ->
list_fold_right (fun (field, strexp) res ->
match res with
| Some _ -> res
| None ->
match strexp with
| Sil.Eexp (exp2, _) when Sil.exp_equal exp2 e ->
(match find_in_sigma exp1 seen_hpreds with
| Some exp' -> Some (Sil.Lfield (exp', field, Sil.Tvoid))
| None -> None)
| _ -> None) fields None
| _ -> None) (get_sigma prop) None in
match find_in_sigma e [] with
| Some res -> Some res
| None -> match get_objc_null_attribute prop e with
| Some (Sil.Aobjc_null exp) -> Some exp
| _ -> None
| Some (Sil.Aobjc_null exp) -> Some exp
| _ -> None
(** translate an if-then-else expression *)
let trans_if_then_else ((idl1, stml1), e1) ((idl2, stml2), e2) ((idl3, stml3), e3) loc =
@ -2772,8 +2772,8 @@ end = struct
(** Approximate the size of the longest chain by counting the max
number of |-> with the same type and whose lhs is primed or
footprint *)
number of |-> with the same type and whose lhs is primed or
footprint *)
let sigma_chain_size sigma =
let tbl = ref Sil.ExpMap.empty in
let add t =
@ -2786,8 +2786,8 @@ end = struct
let process_hpred = function
| Sil.Hpointsto (e, _, te) ->
(match e with
| Sil.Var id when Ident.is_primed id || Ident.is_footprint id -> add te
| _ -> ())
| Sil.Var id when Ident.is_primed id || Ident.is_footprint id -> add te
| _ -> ())
| Sil.Hlseg _ | Sil.Hdllseg _ -> () in
list_iter process_hpred sigma;
let size = ref 0 in
@ -2795,15 +2795,15 @@ end = struct
!size
(** Compute a size value for the prop, which indicates its
complexity *)
complexity *)
let prop_size p =
let size_current = sigma_size p.sigma in
let size_footprint = sigma_size p.foot_sigma in
max size_current size_footprint
(** Approximate the size of the longest chain by counting the max
number of |-> with the same type and whose lhs is primed or
footprint *)
number of |-> with the same type and whose lhs is primed or
footprint *)
let prop_chain_size p =
let fp_size = pi_size p.foot_pi + sigma_size p.foot_sigma in
pi_size p.pi + sigma_size p.sigma + fp_size

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

@ -67,7 +67,7 @@ let get_subl footprint_part g =
if footprint_part then [] else Sil.sub_to_list (Prop.get_sub g)
(** [edge_from_source g n footprint_part is_hpred] finds and edge with the given source [n] in prop [g].
[footprint_part] indicates whether to search the edge in the footprint part, and [is_pred] whether it is an hpred edge. *)
[footprint_part] indicates whether to search the edge in the footprint part, and [is_pred] whether it is an hpred edge. *)
let edge_from_source g n footprint_part is_hpred =
let edges =
if is_hpred
@ -78,7 +78,7 @@ let edge_from_source g n footprint_part is_hpred =
| edge:: _ -> Some edge
(** [get_succs g n footprint_part is_hpred] returns the successor nodes of [n] in [g].
[footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *)
[footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *)
let get_succs g n footprint_part is_hpred =
match edge_from_source g n footprint_part is_hpred with
| None -> []
@ -98,13 +98,13 @@ let edge_equal e1 e2 = match e1, e2 with
| _ -> false
(** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e],
searching the footprint part if [footprint_part] is true. *)
searching the footprint part if [footprint_part] is true. *)
let contains_edge (footprint_part: bool) (g: t) (e: edge) =
try ignore (list_find (fun e' -> edge_equal e e') (get_edges footprint_part g)); true
with Not_found -> false
(** [iter_edges footprint_part f g] iterates function [f] on the edges in [g] in the same order as returned by [get_edges];
if [footprint_part] is true the edges are taken from the footprint part. *)
if [footprint_part] is true the edges are taken from the footprint part. *)
let iter_edges footprint_part f g =
list_iter f (get_edges footprint_part g) (* For now simple iterator; later might use a specific traversal *)
@ -133,9 +133,9 @@ let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list = mat
and compute_fsel_diff fsel1 fsel2 : Obj.t list = match fsel1, fsel2 with
| ((f1, se1):: fsel1'), (((f2, se2) as x):: fsel2') ->
(match Sil.fld_compare f1 f2 with
| n when n < 0 -> compute_fsel_diff fsel1' fsel2
| 0 -> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2'
| _ -> (Obj.repr x) :: compute_fsel_diff fsel1 fsel2')
| n when n < 0 -> compute_fsel_diff fsel1' fsel2
| 0 -> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2'
| _ -> (Obj.repr x) :: compute_fsel_diff fsel1 fsel2')
| _, [] -> []
| [], x:: fsel2' ->
(Obj.repr x) :: compute_fsel_diff [] fsel2'
@ -143,9 +143,9 @@ and compute_fsel_diff fsel1 fsel2 : Obj.t list = match fsel1, fsel2 with
and compute_esel_diff esel1 esel2 : Obj.t list = match esel1, esel2 with
| ((e1, se1):: esel1'), (((e2, se2) as x):: esel2') ->
(match Sil.exp_compare e1 e2 with
| n when n < 0 -> compute_esel_diff esel1' esel2
| 0 -> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2'
| _ -> (Obj.repr x) :: compute_esel_diff esel1 esel2')
| n when n < 0 -> compute_esel_diff esel1' esel2
| 0 -> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2'
| _ -> (Obj.repr x) :: compute_esel_diff esel1 esel2')
| _, [] -> []
| [], x:: esel2' ->
(Obj.repr x) :: compute_esel_diff [] esel2'
@ -192,13 +192,13 @@ let compute_diff default_color oldgraph newgraph : diff =
diff_cmap_foot = colormap_foot }
(** [diff_get_colormap footprint_part diff] returns the colormap of a computed diff,
selecting the footprint colormap if [footprint_part] is true. *)
selecting the footprint colormap if [footprint_part] is true. *)
let diff_get_colormap footprint_part diff =
if footprint_part then diff.diff_cmap_foot else diff.diff_cmap_norm
(** Print a list of propositions, prepending each one with the given string.
If !Config.pring_using_diff is true, print the diff w.r.t. the given prop,
extracting its local stack vars if the boolean is true. *)
If !Config.pring_using_diff is true, print the diff w.r.t. the given prop,
extracting its local stack vars if the boolean is true. *)
let pp_proplist pe0 s (base_prop, extract_stack) f plist =
let num = list_length plist in
let base_stack = fst (Prop.sigma_get_stack_nonstack true (Prop.get_sigma base_prop)) in
@ -218,16 +218,16 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist =
let pe = update_pe_diff _x in
let x = add_base_stack _x in
(match pe.pe_kind with
| PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x
| PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x
| PP_LATEX -> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x)
| PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x
| PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x
| PP_LATEX -> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x)
| _x:: l ->
let pe = update_pe_diff _x in
let x = add_base_stack _x in
(match pe.pe_kind with
| PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l
| PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l
| PP_LATEX -> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l)
| PP_TEXT -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l
| PP_HTML -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l
| PP_LATEX -> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l)
in pp_seq_newline 1 f plist
(** dump a propset *)

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

@ -25,7 +25,7 @@ module PropSet =
let compare = PropSet.compare
(** Sets of propositions.
The invariant is maintaned that Prop.prop_rename_primed_footprint_vars is called on any prop added to the set. *)
The invariant is maintaned that Prop.prop_rename_primed_footprint_vars is called on any prop added to the set. *)
type t = PropSet.t
let add p pset =
@ -78,13 +78,13 @@ let map f pset =
from_proplist (list_map f (to_proplist pset))
(** [fold f pset a] computes [f (... (f (f a p1) p2) ...) pn]
where [p1 ... pN] are the elements of pset, in increasing order. *)
where [p1 ... pN] are the elements of pset, in increasing order. *)
let fold f a pset =
let l = to_proplist pset in
list_fold_left f a l
(** [iter f pset] computes (f p1;f p2;..;f pN)
where [p1 ... pN] are the elements of pset, in increasing order. *)
where [p1 ... pN] are the elements of pset, in increasing order. *)
let iter =
PropSet.iter

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

@ -74,21 +74,21 @@ end = struct
let from_leq acc (e1, e2) =
match e1, e2 with
| Sil.BinOp(Sil.MinusA, (Sil.Var id11 as e11), (Sil.Var id12 as e12)), Sil.Const (Sil.Cint n)
when not (Ident.equal id11 id12) ->
when not (Ident.equal id11 id12) ->
(match Sil.Int.to_signed n with
| None -> acc (* ignore: constraint algorithm only terminates on signed integers *)
| Some n' ->
(e11, e12, n') :: acc)
| None -> acc (* ignore: constraint algorithm only terminates on signed integers *)
| Some n' ->
(e11, e12, n') :: acc)
| _ -> acc
let from_lt acc (e1, e2) =
match e1, e2 with
| Sil.Const (Sil.Cint n), Sil.BinOp(Sil.MinusA, (Sil.Var id21 as e21), (Sil.Var id22 as e22))
when not (Ident.equal id21 id22) ->
when not (Ident.equal id21 id22) ->
(match Sil.Int.to_signed n with
| None -> acc (* ignore: constraint algorithm only terminates on signed integers *)
| Some n' ->
let m = Sil.Int.zero -- n' -- Sil.Int.one in
(e22, e21, m) :: acc)
| None -> acc (* ignore: constraint algorithm only terminates on signed integers *)
| Some n' ->
let m = Sil.Int.zero -- n' -- Sil.Int.one in
(e22, e21, m) :: acc)
| _ -> acc
let rec generate ((e1, e2, n) as constr) acc = function
@ -191,7 +191,7 @@ let check_type_size_lt t1 t2 = match type_size_compare t1 t2 with
(** Reasoning about inequalities *)
module Inequalities : sig
(** type for inequalities (and implied disequalities) *)
(** type for inequalities (and implied disequalities) *)
type t
(** Extract inequalities and disequalities from [pi] *)
@ -310,7 +310,7 @@ end = struct
let new_umap = umap_add umap e1 new_upper1 in
umap_improve_by_difference_constraints new_umap constrs_rest
with Not_found ->
umap_improve_by_difference_constraints umap constrs_rest in
umap_improve_by_difference_constraints umap constrs_rest in
let rec lmap_improve_by_difference_constraints lmap = function
| [] -> lmap
| constr:: constrs_rest -> (* e2 - e1 > -n-1 *)
@ -321,7 +321,7 @@ end = struct
let new_lmap = lmap_add lmap e2 new_lower2 in
lmap_improve_by_difference_constraints new_lmap constrs_rest
with Not_found ->
lmap_improve_by_difference_constraints lmap constrs_rest in
lmap_improve_by_difference_constraints lmap constrs_rest in
let leqs_res =
let umap = umap_create_from_leqs Sil.ExpMap.empty leqs in
let umap' = umap_improve_by_difference_constraints umap diff_constraints2 in
@ -375,8 +375,8 @@ end = struct
| Sil.Earray (size, isel, _) ->
add_lt_minus1_e size;
list_iter (fun (idx, se) ->
add_lt_minus1_e idx;
strexp_extract se) isel in
add_lt_minus1_e idx;
strexp_extract se) isel in
let hpred_extract = function
| Sil.Hpointsto(_, se, texp) ->
if texp_is_unsigned texp then strexp_lt_minus1 se;
@ -408,7 +408,7 @@ end = struct
match e1, e2 with
| Sil.Const (Sil.Cint n1), Sil.Const (Sil.Cint n2) -> Sil.Int.leq n1 n2
| Sil.BinOp (Sil.MinusA, Sil.Sizeof (t1, _), Sil.Sizeof (t2, _)), Sil.Const(Sil.Cint n2)
when Sil.Int.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *)
when Sil.Int.isminusone n2 && type_size_comparable t1 t2 -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *)
check_type_size_lt t1 t2
| e, Sil.Const (Sil.Cint n) -> (* [e <= n' <= n |- e <= n] *)
list_exists (function
@ -533,9 +533,9 @@ let check_zero e =
check_equal Prop.prop_emp e Sil.exp_zero
(** [is_root prop base_exp exp] checks whether [base_exp =
exp.offlist] for some list of offsets [offlist]. If so, it returns
[Some(offlist)]. Otherwise, it returns [None]. Assumes that
[base_exp] points to the beginning of a structure, not the middle.
exp.offlist] for some list of offsets [offlist]. If so, it returns
[Some(offlist)]. Otherwise, it returns [None]. Assumes that
[base_exp] points to the beginning of a structure, not the middle.
*)
let is_root prop base_exp exp =
let rec f offlist_past e = match e with
@ -599,27 +599,27 @@ let check_disequal prop e1 e2 =
| [] -> None
| Sil.Hpointsto (base, _, _) as hpred :: sigma_rest ->
(match is_root prop base e with
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
| Some _ ->
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant'))
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
| Some _ ->
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant'))
| Sil.Hlseg (k, _, e1, e2, _) as hpred :: sigma_rest ->
(match is_root prop e1 e with
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
| Some _ ->
if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else if (Sil.exp_equal e2 Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest')
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
| Some _ ->
if (k == Sil.Lseg_NE || check_pi_implies_disequal e1 e2) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else if (Sil.exp_equal e2 Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest')
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, oB, oF, iB, _) :: sigma_rest ->
if is_root prop iF e != None || is_root prop iB e != None then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
@ -629,19 +629,19 @@ let check_disequal prop e1 e2 =
in Some (false, sigma_irrelevant')
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, oB, oF, iB, _) as hpred :: sigma_rest ->
(match is_root prop iF e with
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
| Some _ ->
if (check_pi_implies_disequal iF oF) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else if (Sil.exp_equal oF Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
in f [] oF sigma_rest') in
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
| Some _ ->
if (check_pi_implies_disequal iF oF) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else if (Sil.exp_equal oF Sil.exp_zero) then
let sigma_irrelevant' = (list_rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
else
let sigma_rest' = (list_rev sigma_irrelevant) @ sigma_rest
in f [] oF sigma_rest') in
let f_null_check sigma_irrelevant e sigma_rest =
if not (Sil.exp_equal e Sil.exp_zero) then f sigma_irrelevant e sigma_rest
else
@ -651,8 +651,8 @@ let check_disequal prop e1 e2 =
| None -> false
| Some (e1_allocated, spatial_part_leftover) ->
(match f_null_check [] n_e2 spatial_part_leftover with
| None -> false
| Some ((e2_allocated : bool), _) -> e1_allocated || e2_allocated) in
| None -> false
| Some ((e2_allocated : bool), _) -> e1_allocated || e2_allocated) in
let neq_pure_part () =
check_pi_implies_disequal n_e1 n_e2 in
check_disequal_const () || neq_pure_part () || neq_spatial_part ()
@ -841,12 +841,12 @@ let check_inconsistency_base prop =
let inconsistent_atom = function
| Sil.Aeq (e1, e2) ->
(match e1, e2 with
| Sil.Const c1, Sil.Const c2 -> not (Sil.const_equal c1 c2)
| _ -> check_disequal prop e1 e2)
| Sil.Const c1, Sil.Const c2 -> not (Sil.const_equal c1 c2)
| _ -> check_disequal prop e1 e2)
| Sil.Aneq (e1, e2) ->
(match e1, e2 with
| Sil.Const c1, Sil.Const c2 -> Sil.const_equal c1 c2
| _ -> (Sil.exp_compare e1 e2 = 0)) in
| Sil.Const c1, Sil.Const c2 -> Sil.const_equal c1 c2
| _ -> (Sil.exp_compare e1 e2 = 0)) in
let inconsistent_inequalities () =
let ineq = Inequalities.from_prop prop in
(*
@ -1097,8 +1097,8 @@ let extend_sub sub v e =
Sil.sub_join new_sub (Sil.sub_range_map (Sil.exp_sub new_sub) sub)
(** Extend [sub1] and [sub2] to witnesses that each instance of
[e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not
possible. *)
[e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not
possible. *)
let exp_imply calc_missing subs e1_in e2_in : subst2 =
let e1 = Prop.exp_normalize_noabs (fst subs) e1_in in
let e2 = Prop.exp_normalize_noabs (snd subs) e2_in in
@ -1128,7 +1128,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
| e1, Sil.Var v2 ->
let occurs_check v e = (* check whether [v] occurs in normalized [e] *)
if Sil.fav_mem (Sil.exp_fav e) v
&& Sil.fav_mem (Sil.exp_fav (Prop.exp_normalize_prop Prop.prop_emp e)) v
&& Sil.fav_mem (Sil.exp_fav (Prop.exp_normalize_prop Prop.prop_emp e)) v
then raise (IMPL_EXC ("occurs check", subs, (EXC_FALSE_EXPS (e1, e2)))) in
if Ident.is_primed v2 then
let () = occurs_check v2 e1 in
@ -1177,9 +1177,9 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
do_imply subs e1 e2
(** Convert a path (from lhs of a |-> to a field name present only in
the rhs) into an id. If the lhs was a footprint var, the id is a
new footprint var. Othewise it is a var with the path in the name
and stamp - 1 *)
the rhs) into an id. If the lhs was a footprint var, the id is a
new footprint var. Othewise it is a var with the path in the name
and stamp - 1 *)
let path_to_id path =
let rec f = function
| Sil.Var id ->
@ -1187,12 +1187,12 @@ let path_to_id path =
else Some (Ident.name_to_string (Ident.get_name id) ^ (string_of_int (Ident.get_stamp id)))
| Sil.Lfield (e, fld, t) ->
(match f e with
| None -> None
| Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld)))
| None -> None
| Some s -> Some (s ^ "_" ^ (Ident.fieldname_to_string fld)))
| Sil.Lindex (e, ind) ->
(match f e with
| None -> None
| Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind)))
| None -> None
| Some s -> Some (s ^ "_" ^ (Sil.exp_to_string ind)))
| Sil.Lvar pv ->
Some (Sil.exp_to_string path)
| Sil.Const (Sil.Cstr s) ->
@ -1216,15 +1216,15 @@ let array_size_imply calc_missing subs size1 size2 indices2 =
| _, Sil.BinOp (Sil.PlusA, _, Sil.Var _)
| Sil.BinOp (Sil.Mult, _, _), _ ->
(try exp_imply calc_missing subs size1 size2 with
| IMPL_EXC (s, subs', x) ->
raise (IMPL_EXC ("array size:" ^ s, subs', x)))
| IMPL_EXC (s, subs', x) ->
raise (IMPL_EXC ("array size:" ^ s, subs', x)))
| _ ->
ProverState.add_bounds_check (ProverState.BCsize_imply (size1, size2, indices2));
subs
(** Extend [sub1] and [sub2] to witnesses that each instance of
[se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not
possible. *)
[se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not
possible. *)
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
@ -1309,8 +1309,8 @@ and struct_imply source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Ident.fi
subs'', fld_frame, (f2, se2):: fld_missing
and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2
: subst2 * ((Sil.exp * Sil.strexp) list) * ((Sil.exp * Sil.strexp) list)
=
: subst2 * ((Sil.exp * Sil.strexp) list) * ((Sil.exp * Sil.strexp) list)
=
let typ_elem = Sil.array_typ_elem (Some Sil.Tvoid) typ2 in
match esel1, esel2 with
| _,[] -> subs, esel1, []
@ -1321,8 +1321,8 @@ and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2
if n < 0 then array_imply source calc_index_frame calc_missing subs esel1' esel2 typ2
else if n > 0 then array_imply source calc_index_frame calc_missing subs esel1 esel2' typ2
else (* n=0 *)
let subs', _, _ = sexp_imply (Sil.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in
array_imply source calc_index_frame calc_missing subs' esel1' esel2' typ2
let subs', _, _ = sexp_imply (Sil.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in
array_imply source calc_index_frame calc_missing subs' esel1' esel2' typ2
| [], (e2, se2) :: esel2' ->
let subs' = sexp_imply_nolhs (Sil.Lindex (source, e2)) calc_missing subs se2 typ_elem in
let subs'', index_frame, index_missing = array_imply source calc_index_frame calc_missing subs' [] esel2' typ2 in
@ -1415,7 +1415,7 @@ let move_primed_lhs_from_front subs sigma = match sigma with
let name_n = Ident.string_to_name "n"
(** [expand_hpred_pointer calc_index_frame hpred] expands [hpred] if it is a |-> whose lhs is a Lfield or Lindex or ptr+off.
Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *)
Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *)
let expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred =
let rec expand changed calc_index_frame hpred = match hpred with
| Sil.Hpointsto (Sil.Lfield (e, fld, typ_fld), se, t) ->
@ -1509,7 +1509,7 @@ let rec case_analysis_type tenv (t1, st1) (t2, st2) =
| Sil.Tstruct (_, _, Sil.Class, Some c1, _, _, _), Sil.Tarray _ ->
if ((Mangled.equal c1 serializable_type) || (Mangled.equal c1 cloneable_type) || (Mangled.equal c1 object_type)) &&
(st1 <> Sil.Subtype.exact) then (Some st1, None)
(st1 <> Sil.Subtype.exact) then (Some st1, None)
else (None, Some st1)
| _ -> if (check_subtype_basic_type t1 t2) then (Some st1, None)
@ -1565,27 +1565,27 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing =
not (texp_equal_modulo_subtype_flag texp1' texp1)
| None -> false in
if (calc_missing) then (* footprint *)
begin
match pos_type_opt with
| None -> cast_exception tenv texp1 texp2 e1 subs
| Some texp1' ->
if has_changed then None, pos_type_opt (* missing *)
else pos_type_opt, None (* frame *)
end
begin
match pos_type_opt with
| None -> cast_exception tenv texp1 texp2 e1 subs
| Some texp1' ->
if has_changed then None, pos_type_opt (* missing *)
else pos_type_opt, None (* frame *)
end
else (* re-execution *)
begin
match neg_type_opt with
| Some _ -> cast_exception tenv texp1 texp2 e1 subs
| None ->
if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *)
else pos_type_opt, None (* frame *)
end
begin
match neg_type_opt with
| Some _ -> cast_exception tenv texp1 texp2 e1 subs
| None ->
if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *)
else pos_type_opt, None (* frame *)
end
end
else
None, None
(** pre-process implication between a non-array and an array: the non-array is turned into an array of size given by its type
only active in type_size mode *)
only active in type_size mode *)
let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with
| Sil.Eexp (e1, inst), Sil.Sizeof _, Sil.Earray _ when !Config.type_size ->
let se1' = Sil.Earray (texp1, [(Sil.exp_zero, se1)], inst) in
@ -1594,7 +1594,7 @@ let sexp_imply_preprocess se1 texp1 se2 = match se1, texp1, se2 with
| _ -> se1
(** handle parameter subtype for java: when the type of a callee variable in the caller is a strict subtype
of the one in the callee, add a type frame and type missing *)
of the one in the callee, add a type frame and type missing *)
let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) =
let is_callee = match e1 with
| Sil.Lvar pv -> Sil.pvar_is_callee pv
@ -1639,84 +1639,84 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Lvar p -> ()
| 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 (try assert false with Assert_failure x -> x)))
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> () in
(match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_ne_lhs (fst subs) e2) with
| None -> raise (IMPL_EXC ("lhs does not have e|->", subs, (EXC_FALSE_HPRED hpred2)))
| Some iter1' ->
(match Prop.prop_iter_current iter1' with
| Sil.Hpointsto (e1, se1, texp1), _ ->
(try
let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) texp2 in
let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in
let se1' = sexp_imply_preprocess se1 texp1 se2 in
let subs', fld_frame, fld_missing = sexp_imply e1 calc_index_frame calc_missing subs se1' se2 typ2 in
if calc_missing then
begin
handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2);
(match fld_missing with
| Some fld_missing ->
ProverState.add_missing_fld (Sil.Hpointsto(_e2, fld_missing, texp1))
| None -> ());
(match fld_frame with
| Some fld_frame ->
ProverState.add_frame_fld (Sil.Hpointsto(e1, fld_frame, texp1))
| None -> ());
(match typing_missing with
| Some t_missing ->
ProverState.add_missing_typ (_e2, t_missing)
| None -> ());
(match typing_frame with
| Some t_frame ->
ProverState.add_frame_typ (e1, t_frame)
| None -> ())
end;
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1')
with
| IMPL_EXC (s, _, body) 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
let (_, para_inst1) = Sil.hpara_instantiate para1 e1 n' elist1 in
let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para1 n' f1 elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Sil.exp_equal (Sil.exp_sub (fst subs) iF1) e2 -> (** Unroll dllseg forward *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in
let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 n' iF1 oF1 iB1 elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Sil.exp_equal (Sil.exp_sub (fst subs) iB1) e2 -> (** Unroll dllseg backward *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in
let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 iF1 oB1 iB1 n' elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| _ -> assert false
)
)
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_ne_lhs (fst subs) e2) with
| None -> raise (IMPL_EXC ("lhs does not have e|->", subs, (EXC_FALSE_HPRED hpred2)))
| Some iter1' ->
(match Prop.prop_iter_current iter1' with
| Sil.Hpointsto (e1, se1, texp1), _ ->
(try
let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) texp2 in
let typing_frame, typing_missing = texp_imply tenv subs texp1 texp2 e1 calc_missing in
let se1' = sexp_imply_preprocess se1 texp1 se2 in
let subs', fld_frame, fld_missing = sexp_imply e1 calc_index_frame calc_missing subs se1' se2 typ2 in
if calc_missing then
begin
handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2);
(match fld_missing with
| Some fld_missing ->
ProverState.add_missing_fld (Sil.Hpointsto(_e2, fld_missing, texp1))
| None -> ());
(match fld_frame with
| Some fld_frame ->
ProverState.add_frame_fld (Sil.Hpointsto(e1, fld_frame, texp1))
| None -> ());
(match typing_missing with
| Some t_missing ->
ProverState.add_missing_typ (_e2, t_missing)
| None -> ());
(match typing_frame with
| Some t_frame ->
ProverState.add_frame_typ (e1, t_frame)
| None -> ())
end;
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1')
with
| IMPL_EXC (s, _, body) 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
let (_, para_inst1) = Sil.hpara_instantiate para1 e1 n' elist1 in
let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para1 n' f1 elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Sil.exp_equal (Sil.exp_sub (fst subs) iF1) e2 -> (** Unroll dllseg forward *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in
let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 n' iF1 oF1 iB1 elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Sil.exp_equal (Sil.exp_sub (fst subs) iB1) e2 -> (** Unroll dllseg backward *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in
let hpred_list1 = para_inst1@[Prop.mk_dllseg Sil.Lseg_PE para1 iF1 oB1 iB1 n' elist1] in
let iter1'' = Prop.prop_iter_update_current_by_list iter1' hpred_list1 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| _ -> assert false
)
)
)
| 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
@ -1724,58 +1724,58 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Lvar p -> ()
| 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 (try assert false with Assert_failure x -> x)))
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> ()
in
if Sil.exp_equal e2 f2 && k == Sil.Lseg_PE then (subs, prop1)
else
(match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in
(* calc_missing is false as we're checking an instantiation of the original list *)
L.d_decrease_indent 1;
res
| Some iter1' ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in
let hpred1 = match Prop.prop_iter_current iter1' with
| hpred1, b ->
if b then ProverState.add_missing_pi (Sil.Aneq(_e2, _f2)); (* for PE |- NE *)
hpred1
in match hpred1 with
| Sil.Hlseg _ -> (subs', prop1')
| Sil.Hpointsto _ -> (* unroll rhs list and try again *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst2) = Sil.hpara_instantiate para2 _e2 n' elist2 in
let hpred_list2 = para_inst2@[Prop.mk_lseg Sil.Lseg_PE para2 n' _f2 _elist2] in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () ->
try sigma_imply tenv calc_index_frame calc_missing subs prop1 hpred_list2
with exn when exn_not_timeout exn ->
begin
(L.d_strln_color Red) "backtracking lseg: trying rhs of length exactly 1";
let (_, para_inst3) = Sil.hpara_instantiate para2 _e2 _f2 elist2 in
sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3
end) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg _ -> assert false
)
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in
(* calc_missing is false as we're checking an instantiation of the original list *)
L.d_decrease_indent 1;
res
| Some iter1' ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in
let hpred1 = match Prop.prop_iter_current iter1' with
| hpred1, b ->
if b then ProverState.add_missing_pi (Sil.Aneq(_e2, _f2)); (* for PE |- NE *)
hpred1
in match hpred1 with
| Sil.Hlseg _ -> (subs', prop1')
| Sil.Hpointsto _ -> (* unroll rhs list and try again *)
let n' = Sil.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst2) = Sil.hpara_instantiate para2 _e2 n' elist2 in
let hpred_list2 = para_inst2@[Prop.mk_lseg Sil.Lseg_PE para2 n' _f2 _elist2] in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () ->
try sigma_imply tenv calc_index_frame calc_missing subs prop1 hpred_list2
with exn when exn_not_timeout exn ->
begin
(L.d_strln_color Red) "backtracking lseg: trying rhs of length exactly 1";
let (_, para_inst3) = Sil.hpara_instantiate para2 _e2 _f2 elist2 in
sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3
end) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg _ -> assert false
)
)
| Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) ->
(d_impl_err ("rhs dllsegPE not implemented", subs, (EXC_FALSE_HPRED hpred2));
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| Sil.Hdllseg (k, 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
@ -1783,53 +1783,53 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Lvar p -> ()
| 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 (try assert false with Assert_failure x -> x)))
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> ()
in
let _ = match oB2 with
| Sil.Lvar p -> ()
| 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 (try assert false with Assert_failure x -> x)))
raise (Exceptions.Abduction_case_not_implemented (try assert false with Assert_failure x -> x)))
| _ -> ()
in
(match Prop.prop_iter_create prop1 with
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let _, para_inst2 =
if Sil.exp_equal iF2 iB2 then
Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2
else assert false in (** Only base case of rhs list considered for now *)
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in
(* calc_missing is false as we're checking an instantiation of the original list *)
L.d_decrease_indent 1;
res
| Some iter1' -> (** Only consider implications between identical listsegs for now *)
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let subs' = exp_list_imply calc_missing subs (iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1')
)
| None -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE))
| Some iter1 ->
(match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (snd subs) hpred2)) with
| None ->
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let _, para_inst2 =
if Sil.exp_equal iF2 iB2 then
Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2
else assert false in (** Only base case of rhs list considered for now *)
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame false subs prop1 para_inst2) in
(* calc_missing is false as we're checking an instantiation of the original list *)
L.d_decrease_indent 1;
res
| Some iter1' -> (** Only consider implications between identical listsegs for now *)
let elist2 = list_map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
let subs' = exp_list_imply calc_missing subs (iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in (* force instantiation of existentials *)
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
in (subs', prop1')
)
)
(** Check that [sigma1] implies [sigma2] and return two substitution
instantiations for the primed variables of [sigma1] and [sigma2]
and a frame. Raise IMPL_FALSE if the implication cannot be
proven. *)
instantiations for the primed variables of [sigma1] and [sigma2]
and a frame. Raise IMPL_FALSE if the implication cannot be
proven. *)
and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 * Prop.normal Prop.t) =
let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *)
| Sil.Hpointsto (_e2, _, _) ->
let e2 = Sil.exp_sub (snd subs) _e2 in
(match e2 with
| Sil.Const (Sil.Cstr s) -> Some (s, true)
| Sil.Const (Sil.Cclass c) -> Some (Ident.name_to_string c, false)
| _ -> None)
| Sil.Const (Sil.Cstr s) -> Some (s, true)
| Sil.Const (Sil.Cclass c) -> Some (Ident.name_to_string c, false)
| _ -> None)
| _ -> None in
let mk_constant_string_hpred s = (* create an hpred from a constant string *)
let size = Sil.exp_int (Sil.Int.of_int (1 + String.length s)) in
@ -1869,60 +1869,60 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
Sil.Hpointsto (root, sexp, class_texp) in
try
(match move_primed_lhs_from_front subs sigma2 with
| [] ->
L.d_strln "Final Implication";
d_impl subs (prop1, Prop.prop_emp);
(subs, prop1)
| hpred2 :: sigma2' ->
L.d_strln "Current Implication";
d_impl subs (prop1, Prop.normalize (Prop.from_sigma (hpred2 :: sigma2')));
L.d_ln ();
L.d_ln ();
let normal_case hpred2' =
let (subs', prop1') =
try
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2') in
L.d_decrease_indent 1;
res
with IMPL_EXC _ when calc_missing ->
begin
match is_constant_string_class subs hpred2' with
| Some (s, is_string) -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *)
let hpred1' = if is_string then mk_constant_string_hpred s else mk_constant_class_hpred s in
let prop1' = Prop.normalize (Prop.replace_sigma (hpred1' :: Prop.get_sigma prop1) prop1) in
let subs', frame_prop = hpred_imply tenv calc_index_frame calc_missing subs prop1' sigma2 hpred2' in
(* ProverState.add_missing_sigma [hpred1']; *)
subs', frame_prop
| None ->
let subs' = match hpred2' with
| Sil.Hpointsto (e2, se2, te2) ->
let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) te2 in
sexp_imply_nolhs e2 calc_missing subs se2 typ2
| _ -> subs in
ProverState.add_missing_sigma [hpred2'];
subs', prop1
end in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame calc_missing subs' prop1' sigma2') in
L.d_decrease_indent 1;
res in
(match hpred2 with
| Sil.Hpointsto(_e2, se2, t) ->
let changed, calc_index_frame', hpred2' = expand_hpred_pointer calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs (snd subs) _e2, se2, t)) in
if changed
then sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') (* calc_index_frame=true *)
else normal_case hpred2'
| _ -> normal_case hpred2)
| [] ->
L.d_strln "Final Implication";
d_impl subs (prop1, Prop.prop_emp);
(subs, prop1)
| hpred2 :: sigma2' ->
L.d_strln "Current Implication";
d_impl subs (prop1, Prop.normalize (Prop.from_sigma (hpred2 :: sigma2')));
L.d_ln ();
L.d_ln ();
let normal_case hpred2' =
let (subs', prop1') =
try
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2') in
L.d_decrease_indent 1;
res
with IMPL_EXC _ when calc_missing ->
begin
match is_constant_string_class subs hpred2' with
| Some (s, is_string) -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *)
let hpred1' = if is_string then mk_constant_string_hpred s else mk_constant_class_hpred s in
let prop1' = Prop.normalize (Prop.replace_sigma (hpred1' :: Prop.get_sigma prop1) prop1) in
let subs', frame_prop = hpred_imply tenv calc_index_frame calc_missing subs prop1' sigma2 hpred2' in
(* ProverState.add_missing_sigma [hpred1']; *)
subs', frame_prop
| None ->
let subs' = match hpred2' with
| Sil.Hpointsto (e2, se2, te2) ->
let typ2 = Sil.texp_to_typ (Some Sil.Tvoid) te2 in
sexp_imply_nolhs e2 calc_missing subs se2 typ2
| _ -> subs in
ProverState.add_missing_sigma [hpred2'];
subs', prop1
end in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
(fun () -> sigma_imply tenv calc_index_frame calc_missing subs' prop1' sigma2') in
L.d_decrease_indent 1;
res in
(match hpred2 with
| Sil.Hpointsto(_e2, se2, t) ->
let changed, calc_index_frame', hpred2' = expand_hpred_pointer calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs (snd subs) _e2, se2, t)) in
if changed
then sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') (* calc_index_frame=true *)
else normal_case hpred2'
| _ -> normal_case hpred2)
)
with IMPL_EXC (s, _, _) when calc_missing ->
L.d_strln ("Adding rhs as missing: " ^ s);
ProverState.add_missing_sigma sigma2;
subs, prop1
L.d_strln ("Adding rhs as missing: " ^ s);
ProverState.add_missing_sigma sigma2;
subs, prop1
let prepare_prop_for_implication (sub1, sub2) pi1 sigma1 =
let pi1' = (Prop.pi_sub sub2 (ProverState.get_missing_pi ())) @ pi1 in
@ -1946,8 +1946,8 @@ let imply_atom calc_missing (sub1, sub2) prop a =
imply_pi calc_missing (sub1, sub2) prop [a]
(** Check pure implications before looking at the spatial part. Add
necessary instantiations for equalities and check that instantiations
are possible for disequalities. *)
necessary instantiations for equalities and check that instantiations
are possible for disequalities. *)
let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
match pi2 with
| [] -> subs
@ -1956,21 +1956,21 @@ let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
if Sil.exp_equal e2 f2 then pre_check_pure_implication calc_missing subs pi1 pi2'
else
(match e2, f2 with
| Sil.Var v2, f2
when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) ->
(* The commented-out condition should always hold. *)
let sub2' = extend_sub (snd subs) v2 f2 in
pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2'
| e2, Sil.Var v2
when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) ->
(* 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.Var v2, f2
when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) ->
(* The commented-out condition should always hold. *)
let sub2' = extend_sub (snd subs) v2 f2 in
pre_check_pure_implication calc_missing (fst subs, sub2') pi1 pi2'
| e2, Sil.Var v2
when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) ->
(* 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 *)
pre_check_pure_implication calc_missing subs pi1 pi2'
@ -1983,8 +1983,8 @@ let rec 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))
(** Perform the array bound checks delayed (to instantiate variables) by the prover.
If there is a provable violation of the array bounds, set the prover status to Bounds_check
and make the proof fail. *)
If there is a provable violation of the array bounds, set the prover status to Bounds_check
and make the proof fail. *)
let check_array_bounds (sub1, sub2) prop =
let check_failed atom =
ProverState.checks := Bounds_check :: !ProverState.checks;
@ -2008,7 +2008,7 @@ let check_array_bounds (sub1, sub2) prop =
list_iter check_bound (ProverState.get_bounds_checks ())
(** [check_implication_base] returns true if [prop1|-prop2],
ignoring the footprint part of the props *)
ignoring the footprint part of the props *)
let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 =
try
ProverState.reset prop1 prop2;
@ -2063,9 +2063,9 @@ type implication_result =
| ImplFail of check list
(** [check_implication_for_footprint p1 p2] returns
[Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)]
where [sub] is a substitution which instantiates the
primed vars of [p1] and [p2], which are assumed to be disjoint. *)
[Some(sub, frame, missing)] if [sub(p1 * missing) |- sub(p2 * frame)]
where [sub] is a substitution which instantiates the
primed vars of [p1] and [p2], which are assumed to be disjoint. *)
let check_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) =
let check_frame_empty = false in
let calc_missing = true in

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

@ -30,13 +30,13 @@ let rec list_rev_and_concat l1 l2 =
let pp_off fmt off =
list_iter (fun n -> match n with
| Sil.Off_fld (f, t) -> F.fprintf fmt "%a " Ident.pp_fieldname f
| Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off
| Sil.Off_fld (f, t) -> F.fprintf fmt "%a " Ident.pp_fieldname f
| Sil.Off_index e -> F.fprintf fmt "%a " (Sil.pp_exp pe_text) e) off
(** Check whether the index is out of bounds.
If the size is - 1, no check is performed.
If the index is provably out of bound, a bound error is given.
If the size is a constant and the index is not provably in bound, a warning is given.
If the size is - 1, no check is performed.
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 size_is_constant = match size with
@ -145,7 +145,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
| Sil.Tint _, [Sil.Off_index e] | Sil.Tfloat _, [Sil.Off_index e]
| Sil.Tvoid, [Sil.Off_index e]
| Sil.Tfun _, [Sil.Off_index e] | Sil.Tptr _, [Sil.Off_index e] ->
(* In this case, we lift t to the t array. *)
(* In this case, we lift t to the t array. *)
let t' = match t with
| Sil.Tptr(t', _) -> t'
| _ -> t in
@ -177,10 +177,10 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
res
(** Extend the strexp by populating the path indicated by [off].
This means that it will add missing flds and do the case - analysis
for array accesses. This does not catch the array - bounds errors.
If we want to implement the checks for array bounds errors,
we need to change this function. *)
This means that it will add missing flds and do the case - analysis
for array accesses. This does not catch the array - bounds errors.
If we want to implement the checks for array bounds errors,
we need to change this function. *)
let rec _strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp
se typ (off : Sil.offset list) inst =
@ -215,13 +215,13 @@ let rec _strexp_extend_values
(res_atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann)) :: acc in
list_fold_left replace [] atoms_se_typ_list'
with Not_found ->
let atoms', se', res_typ' =
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in
let res_fsel' = list_sort Sil.fld_strexp_compare ((f, se'):: fsel) in
let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in
let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in
[(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))]
let atoms', se', res_typ' =
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in
let res_fsel' = list_sort Sil.fld_strexp_compare ((f, se'):: fsel) in
let replace_fta (f', t', a') = if Ident.fieldname_equal f' f then (f, res_typ', a') else (f', t', a') in
let res_ftl' = list_sort Sil.fld_typ_ann_compare (list_map replace_fta ftal) in
[(atoms', Sil.Estruct (res_fsel', inst'), Sil.Tstruct (res_ftl', sftal, csu, nameo, supers, def_mthds, iann))]
end
| (Sil.Off_fld (f, _)):: off', _, _ ->
raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x))
@ -232,7 +232,7 @@ let rec _strexp_extend_values
| (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tfun _
| (Sil.Off_index _):: _, Sil.Eexp _, Sil.Tptr _
| (Sil.Off_index _):: _, Sil.Estruct _, Sil.Tstruct _ ->
(* L.d_strln_color Orange "turn into an array"; *)
(* L.d_strln_color Orange "turn into an array"; *)
let size = match se with
| Sil.Eexp (_, Sil.Ialloc) -> Sil.exp_one (* if allocated explicitly, we know size is 1 *)
| _ ->
@ -259,11 +259,11 @@ let rec _strexp_extend_values
else raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
list_fold_left replace [] atoms_se_typ_list'
with Not_found ->
array_case_analysis_index pname tenv orig_prop
footprint_part kind max_stamp
size esel
size_for_typ' typ'
e off' inst_arr inst
array_case_analysis_index pname tenv orig_prop
footprint_part kind max_stamp
size esel
size_for_typ' typ'
e off' inst_arr inst
end
| _, _, _ ->
raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x))
@ -273,7 +273,7 @@ and array_case_analysis_index pname tenv orig_prop
array_size array_cont
typ_array_size typ_cont
index off inst_arr inst
=
=
let check_sound t' =
if not (Sil.typ_equal typ_cont t' || array_cont == [])
then raise (Exceptions.Bad_footprint (try assert false with Assert_failure x -> x)) in
@ -319,12 +319,12 @@ and array_case_analysis_index pname tenv orig_prop
pname tenv orig_prop footprint_part kind max_stamp se typ_cont off inst in
let atoms_se_typ_list' =
list_fold_left (fun acc' (atoms', se', typ') ->
check_sound typ';
let atoms_new = Sil.Aeq(index, i) :: atoms' in
let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in
let array_new = Sil.Earray(array_size, isel_new, inst_arr) in
let typ_new = Sil.Tarray(typ', typ_array_size) in
(atoms_new, array_new, typ_new):: acc'
check_sound typ';
let atoms_new = Sil.Aeq(index, i) :: atoms' in
let isel_new = list_rev_and_concat isel_seen_rev ((i, se'):: isel_unseen) in
let array_new = Sil.Earray(array_size, isel_new, inst_arr) in
let typ_new = Sil.Tarray(typ', typ_array_size) in
(atoms_new, array_new, typ_new):: acc'
) [] atoms_se_typ_list in
let acc_new = atoms_se_typ_list' :: acc in
let isel_seen_rev_new = ise :: isel_seen_rev in
@ -370,7 +370,7 @@ let strexp_extend_values
off', list_map (fun (id, e) -> Prop.mk_eq (Sil.Var id) e) eqs
else off, [] in
if !Config.trace_rearrange then (L.d_str "entering strexp_extend_values se: "; Sil.d_sexp se; L.d_str " typ: ";
Sil.d_typ_full typ; L.d_str " off': "; Sil.d_offset_list off'; L.d_strln (if footprint_part then " FP" else " RE"));
Sil.d_typ_full typ; L.d_str " off': "; Sil.d_offset_list off'; L.d_strln (if footprint_part then " FP" else " RE"));
let atoms_se_typ_list =
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se typ off' inst in
@ -397,7 +397,7 @@ let mk_ptsto_exp_footprint
if not (exp_has_only_footprint_ids root)
then begin
(* in angelic mode, purposely ignore dangling pointer warnings during the footprint phase -- we
* will fix them during the re - execution phase *)
* will fix them during the re - execution phase *)
if not (!Config.angelic_execution && !Config.footprint) then
begin
if !Config.developer_mode then
@ -407,7 +407,7 @@ let mk_ptsto_exp_footprint
Errdesc.explain_dereference deref_str orig_prop (State.get_loc ()) in
raise
(Exceptions.Dangling_pointer_dereference
(None, err_desc, try assert false with Assert_failure x -> x))
(None, err_desc, try assert false with Assert_failure x -> x))
end
end;
let off_foot, eqs = laundry_offset_for_footprint max_stamp off in
@ -436,7 +436,7 @@ let mk_ptsto_exp_footprint
(ptsto, ptsto_foot, atoms @ atoms')
(** Check if the path in exp exists already in the current ptsto predicate.
If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *)
If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *)
let prop_iter_check_fields_ptsto_shallow iter lexp =
let offset = Sil.exp_get_offsets lexp in
let (e, se, t) =
@ -447,12 +447,12 @@ let prop_iter_check_fields_ptsto_shallow iter lexp =
| [] -> None
| (Sil.Off_fld (fld, _)):: off' ->
(match se with
| Sil.Estruct (fsel, _) ->
(try
| Sil.Estruct (fsel, _) ->
(try
let _, se' = list_find (fun (fld', _) -> Sil.fld_equal fld fld') fsel in
check_offset se' off'
with Not_found -> Some fld)
| _ -> Some fld)
| _ -> Some fld)
| (Sil.Off_index e):: off' -> None in
check_offset se offset
@ -463,9 +463,9 @@ let fav_max_stamp fav =
max_stamp
(** [prop_iter_extend_ptsto iter lexp] extends the current psto
predicate in [iter] with enough fields to follow the path in
[lexp] -- field splitting model. It also materializes all
indices accessed in lexp. *)
predicate in [iter] with enough fields to follow the path in
[lexp] -- field splitting model. It also materializes all
indices accessed in lexp. *)
let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
if !Config.trace_rearrange then (L.d_str "entering prop_iter_extend_ptsto lexp: "; Sil.d_exp lexp; L.d_ln ());
let offset = Sil.exp_get_offsets lexp in
@ -515,29 +515,29 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
if Ident.kind_equal extend_kind Ident.kprimed
then iter_list (* normal part already extended: nothing to do *)
else (* extend footprint part *)
let atoms_fp_sigma_list =
let footprint_sigma = Prop.prop_iter_get_footprint_sigma iter in
let sigma_pto, sigma_rest =
list_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
) footprint_sigma in
let atoms_sigma_list =
match sigma_pto with
| [hpred] ->
let atoms_hpred_list = extend_footprint_pred hpred in
list_map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list
| _ ->
L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln();
[([], footprint_sigma)] in
list_map (fun (atoms, sigma') -> (atoms, list_stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in
let iter_atoms_fp_sigma_list =
list_product iter_list atoms_fp_sigma_list in
list_map (fun (iter, (atoms, fp_sigma)) ->
let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in
Prop.prop_iter_replace_footprint_sigma iter' fp_sigma
) iter_atoms_fp_sigma_list in
let atoms_fp_sigma_list =
let footprint_sigma = Prop.prop_iter_get_footprint_sigma iter in
let sigma_pto, sigma_rest =
list_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
) footprint_sigma in
let atoms_sigma_list =
match sigma_pto with
| [hpred] ->
let atoms_hpred_list = extend_footprint_pred hpred in
list_map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list
| _ ->
L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln();
[([], footprint_sigma)] in
list_map (fun (atoms, sigma') -> (atoms, list_stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in
let iter_atoms_fp_sigma_list =
list_product iter_list atoms_fp_sigma_list in
list_map (fun (iter, (atoms, fp_sigma)) ->
let iter' = list_fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms in
Prop.prop_iter_replace_footprint_sigma iter' fp_sigma
) iter_atoms_fp_sigma_list in
let res_prop_list =
list_map Prop.prop_iter_to_prop res_iter_list in
begin
@ -558,10 +558,10 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
end
(** Add a pointsto for [root(lexp): typ] to the sigma and footprint of a
prop, if it's compatible with the allowed footprint
variables. Then, change it into a iterator. This function ensures
that [root(lexp): typ] is the current hpred of the iterator. typ
is the type of the root of lexp. *)
prop, if it's compatible with the allowed footprint
variables. Then, change it into a iterator. This function ensures
that [root(lexp): typ] is the current hpred of the iterator. typ
is the type of the root of lexp. *)
let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
let max_stamp = fav_max_stamp (Prop.prop_footprint_fav prop) in
let ptsto, ptsto_foot, atoms =
@ -587,9 +587,9 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
Prop.prop_iter_set_state iter offsets_default
(** Add a pointsto for [root(lexp): typ] to the iterator and to the
footprint, if it's compatible with the allowed footprint
variables. This function ensures that [root(lexp): typ] is the
current hpred of the iterator. typ is the type of the root of lexp. *)
footprint, if it's compatible with the allowed footprint
variables. This function ensures that [root(lexp): typ] is the
current hpred of the iterator. typ is the type of the root of lexp. *)
let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst =
let max_stamp = fav_max_stamp (Prop.prop_iter_footprint_fav iter) in
let ptsto, ptsto_foot, atoms =
@ -794,11 +794,11 @@ let type_at_offset texp off =
| [], _ -> Some typ
| (Sil.Off_fld (f, _)):: off', Sil.Tstruct (ftal, sftal, _, _, _, _, _) ->
(try
let typ' =
(fun (x, y, z) -> y)
(list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in
strip_offset off' typ'
with Not_found -> None)
let typ' =
(fun (x, y, z) -> y)
(list_find (fun (f', t', a') -> Ident.fieldname_equal f f') ftal) in
strip_offset off' typ'
with Not_found -> None)
| (Sil.Off_index _):: off', Sil.Tarray (typ', _) ->
strip_offset off' typ'
| _ -> None in
@ -808,7 +808,7 @@ let type_at_offset texp off =
| _ -> None
(** Check that the size of a type coming from an instruction does not exceed the size of the type from the pointsto predicate
For example, that a pointer to int is not used to assign to a char *)
For example, that a pointer to int is not used to assign to a char *)
let check_type_size pname prop texp off typ_from_instr =
L.d_strln_color Orange "check_type_size";
L.d_str "off: "; Sil.d_offset_list off; L.d_ln ();
@ -831,14 +831,14 @@ let check_type_size pname prop texp off typ_from_instr =
L.d_str "texp: "; Sil.d_texp_full texp; L.d_ln ()
(** Exposes lexp |->- from iter. In case that it is not possible to
* expose lexp |->-, this function prints an error message and
* faults. There are four things to note. First, typ is the type of the
* root of lexp. Second, prop should mean the same as iter. Third, the
* result [] means that the given input iter is inconsistent. This
* happens when the theorem prover can prove the inconsistency of prop,
* only after unrolling some predicates in prop. This function ensures
* that the theorem prover cannot prove the inconsistency of any of the
* new iters in the result. *)
* expose lexp |->-, this function prints an error message and
* faults. There are four things to note. First, typ is the type of the
* root of lexp. Second, prop should mean the same as iter. Third, the
* result [] means that the given input iter is inconsistent. This
* happens when the theorem prover can prove the inconsistency of prop,
* only after unrolling some predicates in prop. This function ensures
* that the theorem prover cannot prove the inconsistency of any of the
* new iters in the result. *)
let rec iter_rearrange
pname tenv lexp typ_from_instr prop iter
inst: (Sil.offset list) Prop.prop_iter list =
@ -938,24 +938,24 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
let ann_sig = Models.get_annotated_signature pdesc (Cfg.Procdesc.get_proc_name pdesc) in
list_exists
(fun hpred ->
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (exp, _), _)
when Sil.exp_equal exp deref_exp && Annotations.param_is_nullable pvar ann_sig ->
nullable_obj_str := Sil.pvar_to_string pvar;
true
| Sil.Hpointsto (_, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) ->
let is_nullable fld =
match Annotations.get_field_type_and_annotation fld typ with
| Some (_, annot) -> Annotations.ia_is_nullable annot
| _ -> false in
let is_strexp_pt_by_nullable_fld (fld, strexp) =
match strexp with
| Sil.Eexp (exp, _) when Sil.exp_equal exp deref_exp && is_nullable fld ->
nullable_obj_str := Ident.fieldname_to_string fld;
true
| _ -> false in
list_exists is_strexp_pt_by_nullable_fld flds
| _ -> false)
match hpred with
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (exp, _), _)
when Sil.exp_equal exp deref_exp && Annotations.param_is_nullable pvar ann_sig ->
nullable_obj_str := Sil.pvar_to_string pvar;
true
| Sil.Hpointsto (_, Sil.Estruct (flds, inst), Sil.Sizeof (typ, _)) ->
let is_nullable fld =
match Annotations.get_field_type_and_annotation fld typ with
| Some (_, annot) -> Annotations.ia_is_nullable annot
| _ -> false in
let is_strexp_pt_by_nullable_fld (fld, strexp) =
match strexp with
| Sil.Eexp (exp, _) when Sil.exp_equal exp deref_exp && is_nullable fld ->
nullable_obj_str := Ident.fieldname_to_string fld;
true
| _ -> false in
list_exists is_strexp_pt_by_nullable_fld flds
| _ -> false)
(Prop.get_sigma prop) in
let root = Sil.root_of_lexp lexp in
let is_deref_of_nullable =
@ -970,8 +970,8 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
let rec fold_getters = function
| [] -> None
| getter:: tl -> match getter prop exp with
| Some _ as some_attr -> some_attr
| None -> fold_getters tl in
| Some _ as some_attr -> some_attr
| None -> fold_getters tl in
fold_getters relevant_attributes_getters in
let attribute_opt = match get_relevant_attributes root with
| Some att -> Some att
@ -1024,8 +1024,8 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
match e with
| Sil.Var id ->
(match (Errdesc.find_ident_assignment (State.get_node ()) id) with
| Some (_, e') -> e'
| None -> e)
| Some (_, e') -> e'
| None -> e)
| _ -> e in
let get_exp_called () = (* Exp called in the block's function call*)
match State.get_instr () with
@ -1069,8 +1069,8 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
end
(** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ].
It returns an iterator with [lexp |-> strexp: typ] as current predicate
and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *)
It returns an iterator with [lexp |-> strexp: typ] as current predicate
and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *)
let rearrange pdesc tenv lexp typ prop loc : (Sil.offset list) Prop.prop_iter list =
let nlexp = match Prop.exp_normalize_prop prop lexp with
| Sil.BinOp(Sil.PlusPI, ep, e) -> (* array access with pointer arithmetic *)

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

@ -304,9 +304,9 @@ module Subtype = struct
try
SubtypesMap.find (c1, c2) !subtMap
with Not_found ->
let is_subt = f c1 c2 in
subtMap := (SubtypesMap.add (c1, c2) is_subt !subtMap);
is_subt
let is_subt = f c1 c2 in
subtMap := (SubtypesMap.add (c1, c2) is_subt !subtMap);
is_subt
let flag_to_string flag =
match flag with
@ -385,12 +385,12 @@ module Subtype = struct
match st_opt with
| Some st ->
(match st with
| Exact, flag ->
let new_flag = update_flag c1 c2 flag flag' in
Some (Exact, new_flag)
| Subtypes t, flag ->
let new_flag = update_flag c1 c2 flag flag' in
Some (Subtypes t, new_flag))
| Exact, flag ->
let new_flag = update_flag c1 c2 flag flag' in
Some (Exact, new_flag)
| Subtypes t, flag ->
let new_flag = update_flag c1 c2 flag flag' in
Some (Subtypes t, new_flag))
| None -> None
let normalize_subtypes t_opt c1 c2 flag1 flag2 =
@ -398,9 +398,9 @@ module Subtype = struct
match t_opt with
| Some t ->
(match t with
| Exact -> Some (t, new_flag)
| Subtypes l ->
Some (Subtypes (list_sort Mangled.compare l), new_flag))
| Exact -> Some (t, new_flag)
| Subtypes l ->
Some (Subtypes (list_sort Mangled.compare l), new_flag))
| None -> None
let subtypes_to_string t =
@ -417,9 +417,9 @@ module Subtype = struct
f c1 c2 && not (Mangled.equal c1 c2)
(* checks for redundancies when adding c to l
Xi in A - { X1,..., Xn } is redundant in two cases:
1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A
2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj *)
Xi in A - { X1,..., Xn } is redundant in two cases:
1) not (Xi <: A) because removing the subtypes of Xi has no effect unless Xi is a subtype of A
2) Xi <: Xj because the subtypes of Xi are a subset of the subtypes of Xj *)
let check_redundancies f c l =
let aux (l, add) ci =
let l, should_add =
@ -437,7 +437,7 @@ module Subtype = struct
else (updates_head f c rest)
(* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur
A - { X1,..., Xn } is inconsistent if A <: Xi for some i *)
A - { X1,..., Xn } is inconsistent if A <: Xi for some i *)
let rec add_not_subtype f c1 l1 l2 =
match l2 with
| [] -> l1
@ -494,10 +494,10 @@ module Subtype = struct
(change_flag pos_st c1 c2 flag2), (change_flag neg_st c1 c2 flag2)
(** [case_analysis (c1, st1) (c2,st2) f] performs case analysis on [c1 <: c2] according to [st1] and [st2]
where f c1 c2 is true if c1 is a subtype of c2.
get_subtypes returning a pair:
- whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1]
- whether [st1] and [st2] admit [not(c1 <: c2)], and in case return the updated subtype [st1] *)
where f c1 c2 is true if c1 is a subtype of c2.
get_subtypes returning a pair:
- whether [st1] and [st2] admit [c1 <: c2], and in case return the updated subtype [st1]
- whether [st1] and [st2] admit [not(c1 <: c2)], and in case return the updated subtype [st1] *)
let case_analysis (c1, st1) (c2, st2) f is_interface =
let f = check_subtype f in
if (!Config.subtype_multirange) then
@ -651,7 +651,7 @@ type dexp =
| Dretcall of dexp * dexp list * location * call_flags
(** Value paths: identify an occurrence of a value in a symbolic heap
each expression represents a path, with Dpvar being the simplest one *)
each expression represents a path, with Dpvar being the simplest one *)
and vpath =
dexp option
@ -708,9 +708,9 @@ and typ =
| Tptr of typ * ptr_kind (** pointer type *)
| Tstruct of struct_fields * struct_fields * csu * Mangled.t option * (csu * Mangled.t) list * Procname.t list * item_annotation (** structure type with class/struct/union flag and name and list of superclasses *)
(** Structure type with nonstatic and static fields, class/struct/union flag, name, list of superclasses,
methods defined, and annotations.
The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts
of C structs. *)
methods defined, and annotations.
The fld - typ pairs are always sorted. This means that we don't support programs that exploit specific layouts
of C structs. *)
| Tarray of typ * exp (** array type with fixed size *)
| Tenum of (Mangled.t * const) list
@ -753,7 +753,7 @@ type instr =
| Prune of exp * location * bool * if_kind (** prune the state based on [exp=1], the boolean indicates whether true branch *)
| Call of Ident.t list * exp * (exp * typ) list * location * call_flags
(** [Call (ret_id1..ret_idn, e_fun, arg_ts, loc, call_flags)] represents an instructions
[ret_id1..ret_idn = e_fun(arg_ts);] where n = 0 for void return and n > 1 for struct return *)
[ret_id1..ret_idn = e_fun(arg_ts);] where n = 0 for void return and n > 1 for struct return *)
| Nullify of pvar * location * bool (** nullify stack variable, the bool parameter indicates whether to deallocate the variable *)
| Abstract of location (** apply abstraction *)
| Remove_temps of Ident.t list * location (** remove temporaries *)
@ -810,31 +810,31 @@ type strexp =
| Estruct of (Ident.fieldname * strexp) list * inst (** C structure *)
| Earray of exp * (exp * strexp) list * inst (** Array of given size. *)
(** There are two conditions imposed / used in the array case.
First, if some index and value pair appears inside an array
in a strexp, then the index is less than the size of the array.
For instance, x |->[10 | e1: v1] implies that e1 <= 9.
Second, if two indices appear in an array, they should be different.
For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *)
First, if some index and value pair appears inside an array
in a strexp, then the index is less than the size of the array.
For instance, x |->[10 | e1: v1] implies that e1 <= 9.
Second, if two indices appear in an array, they should be different.
For instance, x |->[10 | e1: v1, e2: v2] implies that e1 != e2. *)
(** an atomic heap predicate *)
and hpred =
| Hpointsto of exp * strexp * exp
(** represents [exp|->strexp:typexp] where [typexp]
is an expression representing a type, e.h. [sizeof(t)]. *)
is an expression representing a type, e.h. [sizeof(t)]. *)
| Hlseg of lseg_kind * hpara * exp * exp * exp list
(** higher - order predicate for singly - linked lists.
Should ensure that exp1!= exp2 implies that exp1 is allocated.
This assumption is used in the rearrangement. The last [exp list] parameter
is used to denote the shared links by all the nodes in the list. *)
Should ensure that exp1!= exp2 implies that exp1 is allocated.
This assumption is used in the rearrangement. The last [exp list] parameter
is used to denote the shared links by all the nodes in the list. *)
| Hdllseg of lseg_kind * hpara_dll * exp * exp * exp * exp * exp list
(** higher-order predicate for doubly-linked lists. *)
(** higher-order predicate for doubly-linked lists. *)
(** parameter for the higher-order singly-linked list predicate.
Means "lambda (root,next,svars). Exists evars. body".
Assume that root, next, svars, evars are disjoint sets of
primed identifiers, and include all the free primed identifiers in body.
body should not contain any non - primed identifiers or program
variables (i.e. pvars). *)
Means "lambda (root,next,svars). Exists evars. body".
Assume that root, next, svars, evars are disjoint sets of
primed identifiers, and include all the free primed identifiers in body.
body should not contain any non - primed identifiers or program
variables (i.e. pvars). *)
and hpara =
{ root: Ident.t;
next: Ident.t;
@ -843,8 +843,8 @@ and hpara =
body: hpred list }
(** parameter for the higher-order doubly-linked list predicates.
Assume that all the free identifiers in body_dll should belong to
cell, blink, flink, svars_dll, evars_dll. *)
Assume that all the free identifiers in body_dll should belong to
cell, blink, flink, svars_dll, evars_dll. *)
and hpara_dll =
{ cell: Ident.t; (** address cell *)
blink: Ident.t; (** backward link *)
@ -892,8 +892,8 @@ 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
| _ -> s)
| Some s3, s4 -> s4 ^ "." ^ s2
| _ -> s)
| _ -> s
(** Check if the pvar is an abucted return var or param passed by ref *)
@ -1087,8 +1087,8 @@ let binop_compare o1 o2 = match o1, o2 with
let binop_equal o1 o2 = binop_compare o1 o2 = 0
(** This function returns true if the operation is injective
wrt. each argument: op(e,-) and op(-, e) is injective for all e.
The return value false means "don't know". *)
wrt. each argument: op(e,-) and op(-, e) is injective for all e.
The return value false means "don't know". *)
let binop_injective = function
| PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true
| _ -> false
@ -1099,9 +1099,9 @@ let binop_invertible = function
| _ -> false
(** This function inverts an injective binary operator
with respect to the first argument. It returns an expression [e'] such that
BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible,
the function raises an exception by calling "assert false". *)
with respect to the first argument. It returns an expression [e'] such that
BinOp([binop], [e'], [exp1]) = [exp2]. If the [binop] operation is not invertible,
the function raises an exception by calling "assert false". *)
let binop_invert bop e1 e2 =
let inverted_bop = match bop with
| PlusA -> MinusA
@ -1112,7 +1112,7 @@ let binop_invert bop e1 e2 =
BinOp(inverted_bop, e2, e1)
(** This function returns true if 0 is the right unit of [binop].
The return value false means "don't know". *)
The return value false means "don't know". *)
let binop_is_zero_runit = function
| PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true
| _ -> false
@ -1373,7 +1373,7 @@ and typ_compare t1 t2 =
| Tarray _, _ -> -1
| _, Tarray _ -> 1
| Tenum l1, Tenum l2 ->
(* Here we take as result the first non-zero result when comparing their (constant,value) pair.*)
(* Here we take as result the first non-zero result when comparing their (constant,value) pair.*)
let compare_pair (n1, e1) (n2, e2) =
let n = Mangled.compare n1 n2 in
if n <> 0 then n else const_compare e1 e2 in
@ -1661,10 +1661,10 @@ module TypMap = Map.Make(struct
(** {2 Sets of expressions} *)
module ExpSet = Set.Make
(struct
type t = exp
let compare = exp_compare
end)
(struct
type t = exp
let compare = exp_compare
end)
module ExpMap = Map.Make(struct
type t = exp
@ -1678,10 +1678,10 @@ let elist_to_eset es =
(** {2 Sets of heap predicates} *)
module HpredSet = Set.Make
(struct
type t = hpred
let compare = hpred_compare
end)
(struct
type t = hpred
let compare = hpred_compare
end)
(** {2 Pretty Printing} *)
@ -2015,8 +2015,8 @@ and pp_const pe f = function
| Cint i -> Int.pp f i
| Cfun fn ->
(match pe.pe_kind with
| PP_HTML -> F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn))
| _ -> F.fprintf f "_fun_%s" (Procname.to_string fn))
| PP_HTML -> F.fprintf f "_fun_%s" (Escape.escape_xml (Procname.to_string fn))
| _ -> F.fprintf f "_fun_%s" (Procname.to_string fn))
| Cstr s -> F.fprintf f "\"%s\"" (String.escaped s)
| Cfloat v -> F.fprintf f "%f" v
| Cattribute att -> F.fprintf f "%s" (attribute_to_string pe att)
@ -2030,8 +2030,8 @@ and pp_typ pe f te =
if !Config.print_types then pp_typ_full pe f te else ()
(** Pretty print a type declaration.
pp_base prints the variable for a declaration, or can be skip to print only the type
pp_size prints the expression for the array size *)
pp_base prints the variable for a declaration, or can be skip to print only the type
pp_size prints the expression for the array size *)
and pp_type_decl pe pp_base pp_size f = function
| Tvar tname -> F.fprintf f "%s %a" (typename_to_string tname) pp_base ()
| Tint ik -> F.fprintf f "%s %a" (ikind_to_string ik) pp_base ()
@ -2048,7 +2048,7 @@ and pp_type_decl pe pp_base pp_size f = function
| Tstruct (ftal, sftal, csu, Some name, _, _, _) when false -> (* remove "when false" to print the details of struct *)
F.fprintf f "%s %a {%a} %a" (csu_name csu) Mangled.pp name
(pp_seq (fun f (fld, t, ann) ->
F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld))
F.fprintf f "%a %a" (pp_typ_full pe) t Ident.pp_fieldname fld))
ftal pp_base ()
| Tstruct (ftal, sftal, csu, Some name, _, _, _) ->
F.fprintf f "%s %a %a" (csu_name csu) Mangled.pp name pp_base ()
@ -2072,32 +2072,32 @@ and _pp_exp pe0 pp_t f e0 =
| Some sub -> Obj.obj (sub (Obj.repr e0)) (* apply object substitution to expression *)
| None -> e0 in
(if not (exp_equal e0 e)
then
match e with
| Lvar pvar -> pp_pvar_value pe f pvar
| _ -> assert false
else
let pp_exp = _pp_exp pe pp_t in
let print_binop_stm_output e1 op e2 =
match op with
| Eq | Ne | PlusA | Mult -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1
| Lt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1
| Gt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1
| Le -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1
| Ge -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1
| _ -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 in
begin match e with
| Var id -> (Ident.pp pe) f id
| Const c -> F.fprintf f "%a" (pp_const pe) c
| Cast (typ, e) -> F.fprintf f "(%a)%a" pp_t typ pp_exp e
| UnOp (op, e, _) -> F.fprintf f "%s%a" (str_unop op) pp_exp e
| 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
| 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);
then
match e with
| Lvar pvar -> pp_pvar_value pe f pvar
| _ -> assert false
else
let pp_exp = _pp_exp pe pp_t in
let print_binop_stm_output e1 op e2 =
match op with
| Eq | Ne | PlusA | Mult -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe op) pp_exp e1
| Lt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Gt) pp_exp e1
| Gt -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Lt) pp_exp e1
| Le -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Ge) pp_exp e1
| Ge -> F.fprintf f "(%a %s %a)" pp_exp e2 (str_binop pe Le) pp_exp e1
| _ -> F.fprintf f "(%a %s %a)" pp_exp e1 (str_binop pe op) pp_exp e2 in
begin match e with
| Var id -> (Ident.pp pe) f id
| Const c -> F.fprintf f "%a" (pp_const pe) c
| Cast (typ, e) -> F.fprintf f "(%a)%a" pp_t typ pp_exp e
| UnOp (op, e, _) -> F.fprintf f "%s%a" (str_unop op) pp_exp e
| 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
| 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);
color_post_wrapper changed pe0 f
and pp_exp pe f e =
@ -2209,33 +2209,33 @@ let pp_call_flags f cf =
let rec pp_instr pe0 f instr =
let pe, changed = color_pre_wrapper pe0 f instr in
(match instr with
| Letderef (id, e, t, loc) -> F.fprintf f "%a=*%a:%a %a" (Ident.pp pe) id (pp_exp pe) e (pp_typ pe) t pp_loc loc
| Set (e1, t, e2, loc) -> F.fprintf f "*%a:%a=%a %a" (pp_exp pe) e1 (pp_typ pe) t (pp_exp pe) e2 pp_loc loc
| Prune (cond, loc, true_branch, ik) ->
F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch pp_loc loc
| Call (ret_ids, e, arg_ts, loc, cf) ->
(match ret_ids with
| [] -> ()
| _ -> F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids);
F.fprintf f "%a(%a)%a %a" (pp_exp pe) e (pp_comma_seq (pp_exp_typ pe)) (arg_ts) pp_call_flags cf pp_loc loc
| Nullify (pvar, loc, deallocate) ->
F.fprintf f "NULLIFY(%a,%b); %a" (pp_pvar pe) pvar deallocate pp_loc loc
| Abstract loc ->
F.fprintf f "APPLY_ABSTRACTION; %a" pp_loc loc
| Remove_temps (temps, loc) ->
F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps pp_loc loc
| Stackop (stackop, loc) ->
let s = match stackop with
| Push -> "Push"
| Swap -> "Swap"
| Pop -> "Pop" in
F.fprintf f "STACKOP.%s; %a" s pp_loc 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
F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl pp_loc loc
| Goto_node (e, loc) ->
F.fprintf f "Goto_node %a %a" (pp_exp pe) e pp_loc loc
| Letderef (id, e, t, loc) -> F.fprintf f "%a=*%a:%a %a" (Ident.pp pe) id (pp_exp pe) e (pp_typ pe) t pp_loc loc
| Set (e1, t, e2, loc) -> F.fprintf f "*%a:%a=%a %a" (pp_exp pe) e1 (pp_typ pe) t (pp_exp pe) e2 pp_loc loc
| Prune (cond, loc, true_branch, ik) ->
F.fprintf f "PRUNE(%a, %b); %a" (pp_exp pe) cond true_branch pp_loc loc
| Call (ret_ids, e, arg_ts, loc, cf) ->
(match ret_ids with
| [] -> ()
| _ -> F.fprintf f "%a=" (pp_comma_seq (Ident.pp pe)) ret_ids);
F.fprintf f "%a(%a)%a %a" (pp_exp pe) e (pp_comma_seq (pp_exp_typ pe)) (arg_ts) pp_call_flags cf pp_loc loc
| Nullify (pvar, loc, deallocate) ->
F.fprintf f "NULLIFY(%a,%b); %a" (pp_pvar pe) pvar deallocate pp_loc loc
| Abstract loc ->
F.fprintf f "APPLY_ABSTRACTION; %a" pp_loc loc
| Remove_temps (temps, loc) ->
F.fprintf f "REMOVE_TEMPS(%a); %a" (Ident.pp_list pe) temps pp_loc loc
| Stackop (stackop, loc) ->
let s = match stackop with
| Push -> "Push"
| Swap -> "Swap"
| Pop -> "Pop" in
F.fprintf f "STACKOP.%s; %a" s pp_loc 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
F.fprintf f "DECLARE_LOCALS(%a); %a" (pp_comma_seq pp_pvar_typ) ptl pp_loc loc
| Goto_node (e, loc) ->
F.fprintf f "Goto_node %a %a" (pp_exp pe) e pp_loc loc
);
color_post_wrapper changed pe0 f
@ -2288,8 +2288,8 @@ and exp_iter_types f e =
| UnOp (op, e1, typo) ->
exp_iter_types f e1;
(match typo with
| Some t -> typ_iter_types f t
| None -> ())
| Some t -> typ_iter_types f t
| None -> ())
| BinOp (op, e1, e2) ->
exp_iter_types f e1;
exp_iter_types f e2
@ -2346,26 +2346,26 @@ let pp_atom pe0 f a =
begin match a with
| Aeq (BinOp(op, e1, e2), Const (Cint i)) when Int.isone i ->
(match pe.pe_kind with
| PP_TEXT | PP_HTML ->
F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2))
| PP_LATEX ->
F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2))
| PP_TEXT | PP_HTML ->
F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2))
| PP_LATEX ->
F.fprintf f "%a" (pp_exp pe) (BinOp(op, e1, e2))
)
| Aeq (e1, e2) ->
(match pe.pe_kind with
| PP_TEXT | PP_HTML ->
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)
| PP_TEXT | PP_HTML ->
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)) ->
F.fprintf f "%a(%a)" (pp_exp pe) ea (pp_exp pe) e
| Aneq (e1, e2) ->
(match pe.pe_kind with
| PP_TEXT | PP_HTML ->
F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2
| PP_LATEX ->
F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2)
| PP_TEXT | PP_HTML ->
F.fprintf f "%a != %a" (pp_exp pe) e1 (pp_exp pe) e2
| PP_LATEX ->
F.fprintf f "%a{\\neq}%a" (pp_exp pe) e1 (pp_exp pe) e2)
end;
color_post_wrapper changed pe0 f
@ -2384,9 +2384,9 @@ let rec pp_star_seq pp f = function
(********* START OF MODULE Predicates **********)
(** Module Predicates records the occurrences of predicates as parameters
of (doubly -)linked lists and Epara. Provides unique numbering for predicates and an iterator. *)
of (doubly -)linked lists and Epara. Provides unique numbering for predicates and an iterator. *)
module Predicates : sig
(** predicate environment *)
(** predicate environment *)
type env
(** create an empty predicate environment *)
val empty_env : unit -> env
@ -2397,7 +2397,7 @@ module Predicates : sig
(** return the id of the hpara_dll *)
val get_hpara_dll_id : env -> hpara_dll -> int
(** [iter env f f_dll] iterates [f] and [f_dll] on all the hpara and hpara_dll,
passing the unique id to the functions. The iterator can only be used once. *)
passing the unique id to the functions. The iterator can only be used once. *)
val iter : env -> (int -> hpara -> unit) -> (int -> hpara_dll -> unit) -> unit
(** Process one hpred, updating the predicate environment *)
val process_hpred : env -> hpred -> unit
@ -2418,7 +2418,7 @@ end = struct
end)
(** Map each visited hpara to a unique number and a boolean denoting whether it has been emitted,
also keep a list of hparas still to be emitted. Same for hpara_dll. *)
also keep a list of hparas still to be emitted. Same for hpara_dll. *)
type env =
{
mutable num: int;
@ -2443,16 +2443,16 @@ end = struct
let process_hpara env hpara =
if not (HparaHash.mem env.hash hpara) then
(HparaHash.add env.hash hpara (env.num, false);
env.num <- env.num + 1;
env.todo <- env.todo @ [hpara])
env.num <- env.num + 1;
env.todo <- env.todo @ [hpara])
(** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *)
let process_hpara_dll env hpara_dll =
if not (HparaDllHash.mem env.hash_dll hpara_dll)
then
(HparaDllHash.add env.hash_dll hpara_dll (env.num, false);
env.num <- env.num + 1;
env.todo_dll <- env.todo_dll @ [hpara_dll])
env.num <- env.num + 1;
env.todo_dll <- env.todo_dll @ [hpara_dll])
(** Process a sexp, updating env *)
let rec process_sexp env = function
@ -2484,8 +2484,8 @@ end = struct
}
(** iterator for predicates which are marked as todo in env, unless they have been visited already.
This can in turn extend the todo list for the nested predicates, which are then visited as well.
Can be applied only once, as it destroys the todo list *)
This can in turn extend the todo list for the nested predicates, which are then visited as well.
Can be applied only once, as it destroys the todo list *)
let iter (env: env) f f_dll =
while env.todo != [] || env.todo_dll != [] do
if env.todo != [] then
@ -2683,26 +2683,26 @@ and pp_hpred_env pe0 envo f hpred =
{ pe with pe_obj_sub = None } (* dont use obj sub on the var defining it *)
| _ -> pe in
(match pe'.pe_kind with
| PP_TEXT | PP_HTML ->
F.fprintf f "%a|->%a:%a" (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te
| PP_LATEX ->
F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se)
| PP_TEXT | PP_HTML ->
F.fprintf f "%a|->%a:%a" (pp_exp pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te
| PP_LATEX ->
F.fprintf f "%a\\mapsto %a" (pp_exp pe') e (pp_sexp_env pe' envo) se)
| Hlseg (k, hpara, e1, e2, elist) ->
(match pe.pe_kind with
| PP_TEXT | PP_HTML ->
F.fprintf f "lseg%a(%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara
| PP_LATEX ->
F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara)
| PP_TEXT | PP_HTML ->
F.fprintf f "lseg%a(%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara
| PP_LATEX ->
F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) e1 (pp_exp pe) e2 (pp_comma_seq (pp_exp pe)) elist (pp_hpara_env pe envo) hpara)
| Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) ->
(match pe.pe_kind with
| PP_TEXT | PP_HTML ->
F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll
| PP_LATEX ->
F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll)
| PP_TEXT | PP_HTML ->
F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll
| PP_LATEX ->
F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)"
pp_lseg_kind k (pp_exp pe) iF (pp_exp pe) oB (pp_exp pe) oF (pp_exp pe) iB (pp_comma_seq (pp_exp pe)) elist (pp_hpara_dll_env pe envo) hpara_dll)
end;
color_post_wrapper changed pe0 f
@ -2868,24 +2868,24 @@ let unsome_typ s = function
assert false
(** Turn an expression representing a type into the type it represents
If not a sizeof, return the default type if given, otherwise raise an exception *)
If not a sizeof, return the default type if given, otherwise raise an exception *)
let texp_to_typ default_opt = function
| Sizeof (t, _) -> t
| t ->
unsome_typ "texp_to_typ" default_opt
(** If a struct type with field f, return the type of f.
If not, return the default type if given, otherwise raise an exception *)
If not, return the default type if given, otherwise raise an exception *)
let struct_typ_fld default_opt f =
let def () = unsome_typ "struct_typ_fld" default_opt in
function
| Tstruct (ftal, sftal, _, _, _, _, _) ->
(try (fun (x, y, z) -> y) (list_find (fun (_f, t, ann) -> Ident.fieldname_equal _f f) ftal)
with Not_found -> def ())
with Not_found -> def ())
| _ -> def ()
(** If an array type, return the type of the element.
If not, return the default type if given, otherwise raise an exception *)
If not, return the default type if given, otherwise raise an exception *)
let array_typ_elem default_opt = function
| Tarray (t_el, _) -> t_el
| t ->
@ -2903,7 +2903,7 @@ let rec root_of_lexp lexp = match lexp with
| Sizeof _ -> lexp
(** Checks whether an expression denotes a location by pointer arithmetic.
Currently, catches array - indexing expressions such as a[i] only. *)
Currently, catches array - indexing expressions such as a[i] only. *)
let rec exp_pointer_arith = function
| Lfield (e, _, _) -> exp_pointer_arith e
| Lindex _ -> true
@ -2999,9 +2999,9 @@ and hpred_fpv = function
@ fpvars_in_elist
(** hpara should not contain any program variables.
This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *)
This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *)
and hpara_fpv para =
let fpvars_in_body = list_flatten (list_map hpred_fpv para.body) in
match fpvars_in_body with
@ -3009,9 +3009,9 @@ and hpara_fpv para =
| _ -> assert false
(** hpara_dll should not contain any program variables.
This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *)
This is because it might cause problems when we do interprocedural
analysis. In interprocedural analysis, we should consider the issue
of scopes of program variables. *)
and hpara_dll_fpv para =
let fpvars_in_body = list_flatten (list_map hpred_fpv para.body_dll) in
match fpvars_in_body with
@ -3069,7 +3069,7 @@ let rec remove_duplicates_from_sorted special_equal = function
else x:: (remove_duplicates_from_sorted special_equal (y:: l))
(** Convert a [fav] to a list of identifiers while preserving the order
that the identifiers were added to [fav]. *)
that the identifiers were added to [fav]. *)
let fav_to_list fav =
list_rev !fav
@ -3107,7 +3107,7 @@ let rec ident_sorted_list_subset l1 l2 =
else false
(** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1]
is in [fav2].*)
is in [fav2].*)
let fav_subset_ident fav1 fav2 =
ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2)
@ -3173,16 +3173,16 @@ let hpred_fav =
fav_imperative_to_functional hpred_fav_add
(** This function should be used before adding a new
index to Earray. The [exp] is the newly created
index. This function "cleans" [exp] according to whether it is the footprint or current part of the prop.
The function faults in the re - execution mode, as an internal check of the tool. *)
index to Earray. The [exp] is the newly created
index. This function "cleans" [exp] according to whether it is the footprint or current part of the prop.
The function faults in the re - execution mode, as an internal check of the tool. *)
let array_clean_new_index footprint_part new_idx =
if footprint_part && not !Config.footprint then assert false;
let fav = exp_fav new_idx in
if footprint_part && fav_exists fav (fun id -> not (Ident.is_footprint id)) then
begin
L.d_warning ("Array index " ^ (exp_to_string new_idx) ^
" has non-footprint vars: replaced by fresh footprint var");
" has non-footprint vars: replaced by fresh footprint var");
L.d_ln ();
let id = Ident.create_fresh Ident.kfootprint in
Var id
@ -3288,8 +3288,8 @@ let sub_check_inv sub =
(sub_check_sortedness sub) && not (sub_check_duplicated_ids sub)
(** Create a substitution from a list of pairs.
For all (id1, e1), (id2, e2) in the input list,
if id1 = id2, then e1 = e2. *)
For all (id1, e1), (id2, e2) in the input list,
if id1 = id2, then e1 = e2. *)
let sub_of_list sub =
let sub' = list_sort ident_exp_compare sub in
let sub'' = remove_duplicates_from_sorted ident_exp_equal sub' in
@ -3315,7 +3315,7 @@ let sub_to_list sub =
let sub_empty = sub_of_list []
(** Join two substitutions into one.
For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *)
For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *)
let sub_join sub1 sub2 =
let sub = sorted_list_merge ident_exp_compare sub1 sub2 in
let sub' = remove_duplicates_from_sorted ident_exp_equal sub in
@ -3323,9 +3323,9 @@ let sub_join sub1 sub2 =
sub
(** Compute the common id-exp part of two inputs [subst1] and [subst2].
The first component of the output is this common part.
The second and third components are the remainder of [subst1]
and [subst2], respectively. *)
The first component of the output is this common part.
The second and third components are the remainder of [subst1]
and [subst2], respectively. *)
let sub_symmetric_difference sub1_in sub2_in =
let rec diff sub_common sub1_only sub2_only sub1 sub2 =
match sub1, sub2 with
@ -3353,21 +3353,21 @@ let sub_find filter (sub: subst) =
snd (list_find (fun (i, _) -> filter i) sub)
(** [sub_filter filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter]. *)
identifiers satisfying [filter]. *)
let sub_filter filter (sub: subst) =
list_filter (fun (i, _) -> filter i) sub
(** [sub_filter_pair filter sub] restricts the domain of [sub] to the
identifiers satisfying [filter(id, sub(id))]. *)
identifiers satisfying [filter(id, sub(id))]. *)
let sub_filter_pair = list_filter
(** [sub_range_partition filter sub] partitions [sub] according to
whether range expressions satisfy [filter]. *)
whether range expressions satisfy [filter]. *)
let sub_range_partition filter (sub: subst) =
list_partition (fun (_, e) -> filter e) sub
(** [sub_domain_partition filter sub] partitions [sub] according to
whether domain identifiers satisfy [filter]. *)
whether domain identifiers satisfy [filter]. *)
let sub_domain_partition filter (sub: subst) =
list_partition (fun (i, _) -> filter i) sub
@ -3384,7 +3384,7 @@ let sub_range_map f sub =
sub_of_list (list_map (fun (i, e) -> (i, f e)) sub)
(** [sub_map f g sub] applies the renaming [f] to identifiers in the domain
of [sub] and the substitution [g] to the expressions in the range of [sub]. *)
of [sub] and the substitution [g] to the expressions in the range of [sub]. *)
let sub_map f g sub =
sub_of_list (list_map (fun (i, e) -> (f i, g e)) sub)
@ -3398,7 +3398,7 @@ let extend_sub sub id exp : subst option =
else Some (sorted_list_merge compare sub [(id, exp)])
(** Free auxilary variables in the domain and range of the
substitution. *)
substitution. *)
let sub_fav_add fav (sub: subst) =
list_iter (fun (id, e) -> fav ++ id; exp_fav_add fav e) sub
@ -3765,8 +3765,8 @@ let tenv_fold f tenv =
let pp_tenv f (tenv : tenv) =
TypenameHash.iter
(fun name typ ->
Format.fprintf f "@[<6>NAME: %s@." (typename_to_string name);
Format.fprintf f "@[<6>TYPE: %a@." (pp_typ_full pe_text) typ)
Format.fprintf f "@[<6>NAME: %s@." (typename_to_string name);
Format.fprintf f "@[<6>TYPE: %a@." (pp_typ_full pe_text) typ)
tenv
(** {2 Functions for constructing or destructing entities in this module} *)
@ -3840,9 +3840,9 @@ let sigma_to_sigma_ne sigma : (atom list * hpred list) list =
[([], sigma)]
(** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1],
[e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b],
then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*)
[e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b],
then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*)
let hpara_instantiate para e1 e2 elist =
let subst_for_svars =
let g id e = (id, e) in
@ -3859,9 +3859,9 @@ let hpara_instantiate para e1 e2 elist =
(ids_evars, list_map (hpred_sub subst) para.body)
(** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell],
[blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b],
then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*)
[blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b],
then the result of the instantiation is [b\[cell / x, blink / y, flink / z, elist / xs, _zs'/ zs\]]
for some fresh [_zs'].*)
let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist =
let subst_for_svars =
let g id e = (id, e) in
@ -3882,7 +3882,7 @@ let rec strexp_get_target_exps = function
| Eexp (e, inst) -> [e]
| Estruct (fsel, inst) -> list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) fsel)
| Earray (_, esel, _) ->
(* We ignore size and indices since they are not quite outgoing arrows. *)
(* We ignore size and indices since they are not quite outgoing arrows. *)
list_flatten (list_map (fun (_, se) -> strexp_get_target_exps se) esel)
let global_error =

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

@ -120,15 +120,15 @@ module Jprop = struct
| [] -> acc
| (Prop (_, p) as jp) :: jpl ->
(match f jp with
| Some x ->
do_filter (x:: acc) jpl
| None -> do_filter acc jpl)
| Some x ->
do_filter (x:: acc) jpl
| None -> do_filter acc jpl)
| (Joined (_, p, jp1, jp2) as jp) :: jpl ->
(match f jp with
| Some x ->
do_filter (x:: acc) jpl
| None ->
do_filter acc (jpl @ [jp1; jp2])) in
| Some x ->
do_filter (x:: acc) jpl
| None ->
do_filter acc (jpl @ [jp1; jp2])) in
do_filter [] jpl
let rec map (f : 'a Prop.t -> 'b Prop.t) = function
@ -148,20 +148,20 @@ let visited_str vis =
let lines = ref IntSet.empty in
let do_one (node, ns) =
(* if list_length ns > 1 then
begin
let ss = ref "" in
list_iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns;
L.err "Node %d has lines %s@." node !ss
end; *)
begin
let ss = ref "" in
list_iter (fun n -> ss := !ss ^ " " ^ string_of_int n) ns;
L.err "Node %d has lines %s@." node !ss
end; *)
list_iter (fun n -> lines := IntSet.add n !lines) ns in
Visitedset.iter do_one vis;
IntSet.iter (fun n -> s := !s ^ " " ^ string_of_int n) !lines;
!s
(** A spec consists of:
pre: a joined prop
post: a list of props with path
visited: a list of pairs (node_id, line) for the visited nodes *)
pre: a joined prop
post: a list of props with path
visited: a list of pairs (node_id, line) for the visited nodes *)
type 'a spec = { pre: 'a Jprop.t; posts: ('a Prop.t * Paths.Path.t) list; visited : Visitedset.t }
module NormSpec : sig (* encapsulate type for normalized specs *)
@ -407,10 +407,10 @@ let describe_phase summary =
let get_signature summary =
let s = ref "" in
list_iter (fun (p, typ) ->
let pp_name f () = F.fprintf f "%s" p in
let pp f () = Sil.pp_type_decl pe_text pp_name Sil.pp_exp f typ in
let decl = pp_to_string pp () in
s := if !s = "" then decl else !s ^ ", " ^ decl) summary.formals;
let pp_name f () = F.fprintf f "%s" p in
let pp f () = Sil.pp_type_decl pe_text pp_name Sil.pp_exp f typ in
let decl = pp_to_string pp () in
s := if !s = "" then decl else !s ^ ", " ^ decl) summary.formals;
let pp_procname f () = F.fprintf f "%a" Procname.pp summary.proc_name in
let pp f () = Sil.pp_type_decl pe_text pp_procname Sil.pp_exp f summary.ret_type in
let decl = pp_to_string pp () in
@ -462,8 +462,8 @@ let empty_stats err_log calls cyclomatic in_out_calls_opt =
stats_timeout = false;
stats_calls =
(match in_out_calls_opt with
| Some in_out_calls -> in_out_calls
| None -> { Cg.in_calls = 0; Cg.out_calls = 0 });
| Some in_out_calls -> in_out_calls
| None -> { Cg.in_calls = 0; Cg.out_calls = 0 });
symops = 0;
err_log = err_log;
nodes_visited_fp = IntSet.empty;
@ -570,9 +570,9 @@ let load_summary_to_spec_table proc_name =
| [] -> false
| spec_path :: spec_paths ->
(match load_summary spec_path with
| None -> load_summary_libs spec_paths
| Some summ ->
add summ Spec_lib) in
| None -> load_summary_libs spec_paths
| Some summ ->
add summ Spec_lib) in
let rec load_summary_ziplibs zip_libraries = (* try to load the summary from a list of zip libraries *)
let zip_specs_filename = specs_filename proc_name in
let zip_specs_path =
@ -591,7 +591,7 @@ let load_summary_to_spec_table proc_name =
let default_spec_dir = res_dir_specs_filename proc_name in
match load_summary default_spec_dir with
| None ->
(* search on models, libzips, and libs *)
(* search on models, libzips, and libs *)
if load_summary_models (specs_models_filename proc_name) then true
else if load_summary_ziplibs !Config.zip_libraries then true
else load_summary_libs (specs_library_filenames proc_name)
@ -603,9 +603,9 @@ let rec get_summary_origin proc_name =
try
Some (Procname.Hash.find spec_tbl proc_name)
with Not_found ->
if load_summary_to_spec_table proc_name then
get_summary_origin proc_name
else None
if load_summary_to_spec_table proc_name then
get_summary_origin proc_name
else None
let get_summary proc_name =
match get_summary_origin proc_name with
@ -619,7 +619,7 @@ let get_summary_unsafe proc_name =
| Some summary -> summary
(** Check if the procedure is from a library:
It's not defined in the current proc desc, and there is no spec file for it. *)
It's not defined in the current proc desc, and there is no spec file for it. *)
let proc_is_library proc_name proc_desc =
let defined = Cfg.Procdesc.is_defined proc_desc in
if not defined then
@ -688,7 +688,7 @@ let get_flag proc_name key =
with Not_found -> None
(** Get the iterations associated to the procedure if any, or the default timeout from the
command line *)
command line *)
let get_iterations proc_name =
match get_summary proc_name with
| None ->
@ -735,7 +735,7 @@ let re_initialize_dependency_map dependency_map =
Procname.Map.map (fun dep_proc -> - 1) dependency_map
(** Update the dependency map of [proc_name] with the current
timestamps of the dependents *)
timestamps of the dependents *)
let update_dependency_map proc_name =
match get_summary_origin proc_name with
| None ->
@ -749,12 +749,12 @@ let update_dependency_map proc_name =
set_summary_origin proc_name { summary with dependency_map = current_dependency_map } origin
(** [init_summary loc (proc_name, ret_type, formals, depend_list, loc, nodes,
proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, proc_attributes)]
initializes the summary for [proc_name] given dependent procs in list [depend_list]. *)
proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt, proc_attributes)]
initializes the summary for [proc_name] given dependent procs in list [depend_list]. *)
let init_summary
(proc_name, ret_type, formals, depend_list, loc,
nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt,
proc_attributes) =
nodes, proc_flags, initial_err_log, calls, cyclomatic, in_out_calls_opt,
proc_attributes) =
let dependency_map = mk_initial_dependency_map depend_list in
let summary =
{
@ -790,19 +790,19 @@ let reset_summary call_graph proc_name loc =
Sil.is_generated = false;
} in
init_summary (
proc_name,
Sil.Tvoid,
[],
Procname.Set.elements
dependents,
loc,
[],
proc_flags_empty (),
Errlog.empty (),
[],
0,
Some (Cg.get_calls call_graph proc_name),
proc_attributes
)
proc_name,
Sil.Tvoid,
[],
Procname.Set.elements
dependents,
loc,
[],
proc_flags_empty (),
Errlog.empty (),
[],
0,
Some (Cg.get_calls call_graph proc_name),
proc_attributes
)
(* =============== END of support for spec tables =============== *)

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

@ -51,8 +51,8 @@ type failure_stats = {
mutable node_fail: int; (* number of node failures (i.e. at least one instruction failure) *)
mutable node_ok: int; (* number of node successes (i.e. no instruction failures) *)
mutable first_failure :
(Sil.location * (int * int) * int * Errlog.loc_trace *
(Prop.normal Prop.t) option * exn) option (* exception at the first failure *)
(Sil.location * (int * int) * int * Errlog.loc_trace *
(Prop.normal Prop.t) option * exn) option (* exception at the first failure *)
}
module NodeHash = Cfg.NodeHash
@ -63,9 +63,9 @@ let failure_map : failure_stats NodeHash.t = NodeHash.create 1
let get_failure_stats node =
try NodeHash.find failure_map node
with Not_found ->
let fs = { instr_fail = 0; instr_ok = 0; node_fail = 0; node_ok = 0; first_failure = None } in
NodeHash.add failure_map node fs;
fs
let fs = { instr_fail = 0; instr_ok = 0; node_fail = 0; node_ok = 0; first_failure = None } in
NodeHash.add failure_map node fs;
fs
let add_diverging_states pset =
diverging_states_proc := Paths.PathSet.union pset !diverging_states_proc;
@ -137,8 +137,8 @@ let instrs_normalize instrs =
list_map (Sil.instr_sub subst) instrs
(** Create a function to find duplicate nodes.
A node is a duplicate of another one if they have the same kind and location
and normalized (w.r.t. renaming of let - bound ids) list of instructions. *)
A node is a duplicate of another one if they have the same kind and location
and normalized (w.r.t. renaming of let - bound ids) list of instructions. *)
let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
let module M = (* map from (loc,kind) *)
Map.Make(struct
@ -182,7 +182,7 @@ let mk_find_duplicate_nodes proc_desc : (Cfg.Node.t -> Cfg.NodeSet.t) =
list_iter do_node nodes;
!m
with E.Threshold ->
M.empty in
M.empty in
let find_duplicate_nodes node =
try
@ -238,7 +238,7 @@ let extract_pre p tenv pdesc abstract_fun =
Prop.normalize (Prop.prop_sub sub pre')
(** return the normalized precondition extracted form the last prop seen, if any
the abstraction function is a parameter to get around module dependencies *)
the abstraction function is a parameter to get around module dependencies *)
let get_normalized_pre (abstract_fun : Sil.tenv -> Prop.normal Prop.t -> Prop.normal Prop.t) : Prop.normal Prop.t option =
match get_prop_tenv_pdesc () with
| None -> None

728
infer/src/backend/symExec.ml
View File

File diff suppressed because it is too large Load Diff

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

@ -46,9 +46,9 @@ type valid_res =
vr_incons_res : (Prop.normal Prop.t * Paths.Path.t) list; (** inconsistent result props *) }
(** Result of (bi)-abduction on a single spec.
A result is invalid if no splitting was found, or if combine failed, or if we are in re - execution mode and the sigma
part of the splitting is not empty.
A valid result contains the missing pi ans sigma, as well as the resulting props. *)
A result is invalid if no splitting was found, or if combine failed, or if we are in re - execution mode and the sigma
part of the splitting is not empty.
A valid result contains the missing pi ans sigma, as well as the resulting props. *)
type abduction_res =
| Valid_res of valid_res (** valid result for a function cal *)
| Invalid_res of invalid_res (** reason for invalid result *)
@ -113,14 +113,14 @@ let spec_find_rename trace_call (proc_name : Procname.t) : (int * Prop.exposed S
list_map (fun (x, _) -> Sil.mk_pvar_callee (Mangled.from_string x) proc_name) formals in
list_map f specs, formal_parameters
with Not_found -> begin
L.d_strln ("ERROR: found no entry for procedure " ^ Procname.to_string proc_name ^ ". Give up...");
raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x))
end
L.d_strln ("ERROR: found no entry for procedure " ^ Procname.to_string proc_name ^ ". Give up...");
raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Procname.to_string proc_name), try assert false with Assert_failure x -> x))
end
(** Process a splitting coming straight from a call to the prover:
change the instantiating substitution so that it returns primed vars,
except for vars occurring in the missing part, where it returns
footprint vars. *)
change the instantiating substitution so that it returns primed vars,
except for vars occurring in the missing part, where it returns
footprint vars. *)
let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_fld missing_fld frame_typ missing_typ =
(*
let check_precondition () =
@ -228,11 +228,11 @@ and find_dereference_without_null_check_in_sexp_list = function
| [] -> None
| se:: sel ->
(match find_dereference_without_null_check_in_sexp se with
| None -> find_dereference_without_null_check_in_sexp_list sel
| Some x -> Some x)
| None -> find_dereference_without_null_check_in_sexp_list sel
| Some x -> Some x)
(** Check dereferences implicit in the spec pre.
In case of dereference error, return [Some(deref_error, description)], otherwise [None] *)
In case of dereference error, return [Some(deref_error, description)], otherwise [None] *)
let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
let check_dereference e sexp =
let e_sub = Sil.exp_sub sub e in
@ -253,9 +253,9 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
else None in
if deref_no_null_check_pos != None
then (* only report a dereference null error if we know there was a dereference without null check *)
match deref_no_null_check_pos with
| Some pos -> Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname)))
| None -> assert false
match deref_no_null_check_pos with
| Some pos -> Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname)))
| None -> assert false
else if Sil.exp_equal e_sub Sil.exp_minus_one then Some (Deref_minusone, desc true (Localise.deref_str_dangling None))
else match Prop.get_resource_undef_attribute actual_pre e_sub with
| Some (Sil.Aundef (s, loc, pos)) ->
@ -268,25 +268,25 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
check_dereference (Sil.root_of_lexp lexp) se
| _ -> None in
let deref_err_list = list_fold_left (fun deref_errs hpred -> match check_hpred hpred with
| Some reason -> reason :: deref_errs
| None -> deref_errs
) [] (Prop.get_sigma spec_pre) in
| Some reason -> reason :: deref_errs
| None -> deref_errs
) [] (Prop.get_sigma spec_pre) in
match deref_err_list with
| [] -> None
| deref_err :: _ ->
if !Config.angelic_execution then
(* In angelic mode, prefer to report Deref_null over other kinds of deref errors. this
* makes sure we report a NULL_DEREFERENCE instead of a less interesting PRECONDITION_NOT_MET
* whenever possible *)
* makes sure we report a NULL_DEREFERENCE instead of a less interesting PRECONDITION_NOT_MET
* whenever possible *)
(* TOOD (t4893533): use this trick outside of angelic mode and in other parts of the code *)
Some
(try
list_find
(fun err -> match err with
(try
list_find
(fun err -> match err with
| (Deref_null _, _) -> true
| _ -> false )
deref_err_list
with Not_found -> deref_err)
deref_err_list
with Not_found -> deref_err)
else Some deref_err
let post_process_sigma (sigma: Sil.hpred list) loc : Sil.hpred list =
@ -313,8 +313,8 @@ let check_path_errors_in_post caller_pname post post_path =
list_iter check_attr (Prop.get_all_attributes post)
(** Post process the instantiated post after the function call so that
x.f |-> se becomes x |-> \{ f: se \}.
Also, update any Aresource attributes to refer to the caller *)
x.f |-> se becomes x |-> \{ f: se \}.
Also, update any Aresource attributes to refer to the caller *)
let post_process_post
caller_pname callee_pname loc actual_pre ((post: Prop.exposed Prop.t), post_path) =
let actual_pre_has_freed_attribute e = match Prop.get_resource_undef_attribute actual_pre e with
@ -323,7 +323,7 @@ let post_process_post
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)
when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *)
when not (ra.Sil.ra_kind = Sil.Rrelease && actual_pre_has_freed_attribute e) -> (* unless it was already freed before the call *)
let vpath, _ = Errdesc.vpath_find post e in
let ra' = { ra with Sil.ra_pname = callee_pname; Sil.ra_loc = loc; Sil.ra_vpath = vpath } in
let c = Sil.Const (Sil.Cattribute (Sil.Aresource ra')) in
@ -360,9 +360,9 @@ let rec fsel_star_fld fsel1 fsel2 = match fsel1, fsel2 with
| fsel1,[] -> fsel1
| (f1, se1):: fsel1', (f2, se2):: fsel2' ->
(match Ident.fieldname_compare f1 f2 with
| 0 -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2'
| n when n < 0 -> (f1, se1) :: fsel_star_fld fsel1' fsel2
| _ -> (f2, se2) :: fsel_star_fld fsel1 fsel2')
| 0 -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2'
| n when n < 0 -> (f1, se1) :: fsel_star_fld fsel1' fsel2
| _ -> (f2, se2) :: fsel_star_fld fsel1 fsel2')
and array_content_star se1 se2 =
try sexp_star_fld se1 se2 with
@ -374,11 +374,11 @@ and esel_star_fld esel1 esel2 = match esel1, esel2 with
| esel1,[] -> esel1
| (e1, se1):: esel1', (e2, se2):: esel2' ->
(match Sil.exp_compare e1 e2 with
| 0 -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2'
| n when n < 0 -> (e1, se1) :: esel_star_fld esel1' esel2
| _ ->
let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *)
(e2, se2') :: esel_star_fld esel1 esel2')
| 0 -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2'
| n when n < 0 -> (e1, se1) :: esel_star_fld esel1' esel2
| _ ->
let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *)
(e2, se2') :: esel_star_fld esel1 esel2')
and sexp_star_fld se1 se2 : Sil.strexp =
(* L.d_str "sexp_star_fld "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln (); *)
@ -416,8 +416,8 @@ let texp_star texp1 texp2 =
let hpred_star_fld (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred =
match hpred1, hpred2 with
| Sil.Hpointsto(e1, se1, t1), Sil.Hpointsto(_, se2, t2) ->
(* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2;
L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *)
(* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2;
L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *)
Sil.Hpointsto(e1, sexp_star_fld se1 se2, texp_star t1 t2)
| _ -> assert false
@ -440,10 +440,10 @@ let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpr
in
try star sigma1 sigma2
with exn when exn_not_timeout exn ->
L.d_str "cannot star ";
Prop.d_sigma sigma1; L.d_str " and "; Prop.d_sigma sigma2;
L.d_ln ();
raise (Prop.Cannot_star (try assert false with Assert_failure x -> x))
L.d_str "cannot star ";
Prop.d_sigma sigma1; L.d_str " and "; Prop.d_sigma sigma2;
L.d_ln ();
raise (Prop.Cannot_star (try assert false with Assert_failure x -> x))
let hpred_typing_lhs_compare hpred1 (e2, te2) = match hpred1 with
| Sil.Hpointsto(e1, _, _) -> Sil.exp_compare e1 e2
@ -474,10 +474,10 @@ let sigma_star_typ (sigma1 : Sil.hpred list) (typings2 : (Sil.exp * Sil.exp) lis
end in
try star sigma1 typings2
with exn when exn_not_timeout exn ->
L.d_str "cannot star ";
Prop.d_sigma sigma1; L.d_str " and "; Prover.d_typings typings2;
L.d_ln ();
raise (Prop.Cannot_star (try assert false with Assert_failure x -> x))
L.d_str "cannot star ";
Prop.d_sigma sigma1; L.d_str " and "; Prover.d_typings typings2;
L.d_ln ();
raise (Prop.Cannot_star (try assert false with Assert_failure x -> x))
end
else sigma1
@ -489,7 +489,7 @@ let prop_footprint_add_pi_sigma_starfld_sigma (prop : 'a Prop.t) pi_new sigma_ne
let fav = Prop.sigma_fav [hpred] in
(* TODO (t4893479): make this check less angelic *)
if Sil.fav_exists fav
(fun id -> not (Ident.is_footprint id) && not !Config.angelic_execution)
(fun id -> not (Ident.is_footprint id) && not !Config.angelic_execution)
then begin
L.d_warning "found hpred with non-footprint variable, dropping the spec"; L.d_ln (); Sil.d_hpred hpred; L.d_ln ();
None
@ -519,8 +519,8 @@ let prop_footprint_add_pi_sigma_starfld_sigma (prop : 'a Prop.t) pi_new sigma_ne
(** Check if the attribute change is a mismatch between a kind of allocation and a different kind of deallocation *)
let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with
| Sil.Aresource ({ Sil.ra_kind = Sil.Racquire; Sil.ra_res = Sil.Rmemory mk_old } as ra_old),
Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk_new } as ra_new)
when Sil.mem_kind_compare mk_old mk_new <> 0 ->
Sil.Aresource ({ Sil.ra_kind = Sil.Rrelease; Sil.ra_res = Sil.Rmemory mk_new } as ra_new)
when Sil.mem_kind_compare mk_old mk_new <> 0 ->
let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in
raise (Exceptions.Deallocation_mismatch (desc, try assert false with Assert_failure x -> x))
| _ -> ()
@ -573,7 +573,7 @@ let lookup_global_errors prop =
let rec search_error = function
| [] -> None
| Sil.Hpointsto (Sil.Lvar var, Sil.Eexp (Sil.Const (Sil.Cstr str), _), _) :: tl
when Sil.pvar_equal var Sil.global_error -> Some (Mangled.from_string str)
when Sil.pvar_equal var Sil.global_error -> Some (Mangled.from_string str)
| _ :: tl -> search_error tl in
search_error (Prop.get_sigma prop)
@ -622,22 +622,22 @@ let combine
let posts' =
if !Config.footprint && posts = []
then (* in case of divergence, produce a prop *)
(* with updated footprint and inconsistent current *)
[(Prop.replace_pi [Sil.Aneq (Sil.exp_zero, Sil.exp_zero)] Prop.prop_emp, path_pre)]
(* with updated footprint and inconsistent current *)
[(Prop.replace_pi [Sil.Aneq (Sil.exp_zero, Sil.exp_zero)] Prop.prop_emp, path_pre)]
else
list_map
(fun (p, path_post) ->
(p,
Paths.Path.add_call
(include_subtrace callee_pname)
path_pre
callee_pname
path_post))
(p,
Paths.Path.add_call
(include_subtrace callee_pname)
path_pre
callee_pname
path_post))
posts in
list_map
(fun (p, path) ->
(post_process_post
caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path)))
(post_process_post
caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path)))
posts' in
L.d_increase_indent 1;
L.d_strln "New footprint:"; Prop.d_pi_sigma new_footprint_pi new_footprint_sigma; L.d_ln ();
@ -695,7 +695,7 @@ let combine
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
Prop.conjoin_eq e' (Sil.Var (list_hd ret_ids)) p
| Sil.Hpointsto (e, Sil.Estruct (ftl, _), t)
when list_length ftl = list_length ret_ids ->
when list_length ftl = list_length ret_ids ->
let rec do_ftl_ids p = function
| [], [] -> p
| (f, Sil.Eexp (e', inst')):: ftl', ret_id:: ret_ids' ->
@ -715,15 +715,15 @@ let combine
post_p4 in
let _results = list_map (fun (p, path) -> (compute_result p, path)) instantiated_post in
if list_exists (fun (x, _) -> x = None) _results then (* at least one combine failed *)
None
None
else
let results = list_map (function (Some x, path) -> (x, path) | (None, _) -> assert false) _results in
print_results actual_pre (list_map fst results);
Some results
(** Construct the actual precondition: add to the current state a copy
of the (callee's) formal parameters instantiated with the actual
parameters. *)
of the (callee's) formal parameters instantiated with the actual
parameters. *)
let mk_actual_precondition prop actual_params formal_params =
let formals_actuals =
let rec comb fpars apars = match fpars, apars with
@ -731,7 +731,7 @@ let mk_actual_precondition prop actual_params formal_params =
| [], _ ->
if apars != [] then
(let str = "more actual pars than formal pars in fun call (" ^ string_of_int (list_length actual_params) ^ " vs " ^ string_of_int (list_length formal_params) ^ ")" in
L.d_warning str; L.d_ln ());
L.d_warning str; L.d_ln ());
[]
| _:: _,[] -> raise (Exceptions.Wrong_argument_number (try assert false with Assert_failure x -> x)) in
comb formal_params actual_params in
@ -759,11 +759,11 @@ let rec get_taint_untaint pi =
| Sil.Aneq (e1, e2):: pi' ->
let p = Prop.replace_pi pi Prop.prop_emp in
(match Prop.get_taint_attribute p e1, Prop.get_taint_attribute p e2 with
| Some(Sil.Ataint), _ -> let (t', u') = get_taint_untaint pi' in (e1:: t', u')
| Some(Sil.Auntaint), _ -> let (t', u') = get_taint_untaint pi' in (t', e1:: u')
| _, Some(Sil.Ataint) -> let (t', u') = get_taint_untaint pi' in (e2:: t', u')
| _ , Some(Sil.Auntaint) -> let (t', u') = get_taint_untaint pi' in (t', e2:: u')
| _, _ -> get_taint_untaint pi')
| Some(Sil.Ataint), _ -> let (t', u') = get_taint_untaint pi' in (e1:: t', u')
| Some(Sil.Auntaint), _ -> let (t', u') = get_taint_untaint pi' in (t', e1:: u')
| _, Some(Sil.Ataint) -> let (t', u') = get_taint_untaint pi' in (e2:: t', u')
| _ , Some(Sil.Auntaint) -> let (t', u') = get_taint_untaint pi' in (t', e2:: u')
| _, _ -> get_taint_untaint pi')
| _ :: pi' -> get_taint_untaint pi'
(* perform the taint analysis check *)
@ -783,16 +783,16 @@ let do_taint_check caller_pname actual_pre missing_pi missing_sigma sub1 sub2 =
match intersection_taint_untaint taint2 untaint2 with
| None -> L.d_str "^^^^^^NO TAINT ERROR"
| Some e -> begin
L.d_str "^^^^^ERROR in TAINT ANALYSIS: ";
let e' = match Errdesc.find_pvar_with_exp sub2_augmented_actual_pre e with
| Some (pv, _) -> Sil.Lvar pv
| None -> e in
let err_desc = Errdesc.explain_tainted_value_reaching_sensitive_function e' (State.get_loc ()) in
let exn =
Exceptions.Tainted_value_reaching_sensitive_function
L.d_str "^^^^^ERROR in TAINT ANALYSIS: ";
let e' = match Errdesc.find_pvar_with_exp sub2_augmented_actual_pre e with
| Some (pv, _) -> Sil.Lvar pv
| None -> e in
let err_desc = Errdesc.explain_tainted_value_reaching_sensitive_function e' (State.get_loc ()) in
let exn =
Exceptions.Tainted_value_reaching_sensitive_function
(err_desc, try assert false with Assert_failure x -> x) in
Reporting.log_warning caller_pname exn
end
Reporting.log_warning caller_pname exn
end
let class_cast_exn pname_opt texp1 texp2 exp ml_location =
let desc = Errdesc.explain_class_cast_exception pname_opt texp1 texp2 exp (State.get_node ()) (State.get_loc ()) in
@ -816,30 +816,30 @@ let exe_spec
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in
let posts =
match ret_ids with
| [ret_id] when !Config.idempotent_getters && !Sil.curr_language = Sil.Java ->
(* if we have seen a previous call to the same function, only use specs whose return value
is consistent with constraints on the return value of the previous call w.r.t to nullness.
meant to eliminate false NPE warnings from the common "if (get() != null) get().something()"
pattern *)
let last_call_ret_non_null =
list_exists
(fun (exp, attr) ->
match attr with
| Sil.Aretval pname when Procname.equal callee_pname pname ->
Prover.check_disequal prop exp Sil.exp_zero
| _ -> false)
(Prop.get_all_attributes prop) in
if last_call_ret_non_null then
let returns_null prop =
| [ret_id] when !Config.idempotent_getters && !Sil.curr_language = Sil.Java ->
(* if we have seen a previous call to the same function, only use specs whose return value
is consistent with constraints on the return value of the previous call w.r.t to nullness.
meant to eliminate false NPE warnings from the common "if (get() != null) get().something()"
pattern *)
let last_call_ret_non_null =
list_exists
(function
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (e, _), _) when Sil.pvar_is_return pvar ->
Prover.check_equal (Prop.normalize prop) e Sil.exp_zero
| _ -> false)
(Prop.get_sigma prop) in
list_filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts
else spec.Specs.posts
| _ -> spec.Specs.posts in
(fun (exp, attr) ->
match attr with
| Sil.Aretval pname when Procname.equal callee_pname pname ->
Prover.check_disequal prop exp Sil.exp_zero
| _ -> false)
(Prop.get_all_attributes prop) in
if last_call_ret_non_null then
let returns_null prop =
list_exists
(function
| Sil.Hpointsto (Sil.Lvar pvar, Sil.Eexp (e, _), _) when Sil.pvar_is_return pvar ->
Prover.check_equal (Prop.normalize prop) e Sil.exp_zero
| _ -> false)
(Prop.get_sigma prop) in
list_filter (fun (prop, _) -> not (returns_null prop)) spec.Specs.posts
else spec.Specs.posts
| _ -> spec.Specs.posts in
let actual_pre = mk_actual_precondition prop actual_params formal_params in
let spec_pre = Specs.Jprop.to_prop spec.Specs.pre in
L.d_strln ("EXECUTING SPEC " ^ string_of_int n ^ "/" ^ string_of_int nspecs);
@ -862,19 +862,19 @@ let exe_spec
(split, norm_missing_pi, norm_missing_sigma) in
let report_valid_res split norm_missing_pi norm_missing_sigma =
match combine
cfg ret_ids posts
actual_pre path_pre split
caller_pdesc callee_pname loc with
cfg ret_ids posts
actual_pre path_pre split
caller_pdesc callee_pname loc with
| None -> Invalid_res Cannot_combine
| Some results ->
let inconsistent_results, consistent_results =
list_partition (fun (p, _) -> Prover.check_inconsistency p) results in
let incons_pre_missing = inconsistent_actualpre_missing actual_pre (Some split) in
Valid_res { incons_pre_missing = incons_pre_missing;
vr_pi = norm_missing_pi;
vr_sigma = norm_missing_sigma;
vr_cons_res = consistent_results;
vr_incons_res = inconsistent_results } in
vr_pi = norm_missing_pi;
vr_sigma = norm_missing_sigma;
vr_cons_res = consistent_results;
vr_incons_res = inconsistent_results } in
begin
list_iter log_check_exn checks;
if (!Config.taint_analysis && !Config.developer_mode) then
@ -889,8 +889,8 @@ let exe_spec
| [] -> None
| (_, p):: l ->
(match join_paths l with
| None -> Some p
| Some p' -> Some (Paths.Path.join p p')) in
| None -> Some p
| Some p' -> Some (Paths.Path.join p p')) in
let pjoin = join_paths posts in (* join the paths from the posts *)
Invalid_res (Dereference_error (deref_error, desc, pjoin))
| None ->
@ -925,7 +925,7 @@ let remove_constant_string_class prop =
Prop.normalize prop'
(** existentially quantify the path identifier generated by the prover to keep track of expansions of lhs paths
and remove pointsto's whose lhs is a constant string *)
and remove pointsto's whose lhs is a constant string *)
let quantify_path_idents_remove_constant_strings (prop: Prop.normal Prop.t) : Prop.normal Prop.t =
let fav = Prop.prop_fav prop in
Sil.fav_filter_ident fav Ident.is_path;
@ -943,7 +943,7 @@ let prop_pure_to_footprint (p: 'a Prop.t) : Prop.normal Prop.t =
if new_footprint_atoms == []
then p
else (** add pure fact to footprint *)
Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p)
Prop.normalize (Prop.replace_pi_footprint (Prop.get_pi_footprint p @ new_footprint_atoms) p)
(** check whether 0|->- occurs in sigma *)
let sigma_has_null_pointer sigma =
@ -976,62 +976,62 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
if !Config.footprint then
begin
if valid_res_cons_pre_missing == [] then (* no valid results where actual pre and missing are consistent *)
begin
if deref_errors <> [] then (* dereference error detected *)
let extend_path path_opt path_pos_opt = match path_opt with
| None -> ()
| Some path_post ->
let old_path, _ = State.get_path () in
let new_path = Paths.Path.add_call (include_subtrace callee_pname) old_path callee_pname path_post in
State.set_path new_path path_pos_opt in
match list_hd deref_errors with
| Dereference_error (Deref_minusone, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Dangling_pointer_dereference (Some Sil.DAminusone, desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_null pos, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
if Localise.is_parameter_not_null_checked_desc desc then
raise (Exceptions.Parameter_not_null_checked (desc, try assert false with Assert_failure x -> x))
else if Localise.is_field_not_null_checked_desc desc then
raise (Exceptions.Field_not_null_checked (desc, try assert false with Assert_failure x -> x))
else raise (Exceptions.Null_dereference (desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_freed ra, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Use_after_free (desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_undef (s, loc, pos), desc, path_opt) ->
begin
if deref_errors <> [] then (* dereference error detected *)
let extend_path path_opt path_pos_opt = match path_opt with
| None -> ()
| Some path_post ->
let old_path, _ = State.get_path () in
let new_path = Paths.Path.add_call (include_subtrace callee_pname) old_path callee_pname path_post in
State.set_path new_path path_pos_opt in
match list_hd deref_errors with
| Dereference_error (Deref_minusone, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Dangling_pointer_dereference (Some Sil.DAminusone, desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_null pos, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
if Localise.is_parameter_not_null_checked_desc desc then
raise (Exceptions.Parameter_not_null_checked (desc, try assert false with Assert_failure x -> x))
else if Localise.is_field_not_null_checked_desc desc then
raise (Exceptions.Field_not_null_checked (desc, try assert false with Assert_failure x -> x))
else raise (Exceptions.Null_dereference (desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_freed ra, desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt None;
raise (Exceptions.Use_after_free (desc, try assert false with Assert_failure x -> x))
| Dereference_error (Deref_undef (s, loc, pos), desc, path_opt) ->
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
raise (Exceptions.Skip_pointer_dereference (desc, try assert false with Assert_failure x -> x))
| Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty ->
trace_call Specs.CallStats.CR_not_met;
assert false
else (* no dereference error detected *)
let desc =
if list_exists (function Cannot_combine -> true | _ -> false) invalid_res then
call_desc (Some Localise.Pnm_dangling)
else if list_exists (function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn check callee_pname loc (try assert false with Assert_failure x -> x) in
raise exn
| _ -> false) invalid_res then
call_desc (Some Localise.Pnm_bounds)
else call_desc None in
trace_call Specs.CallStats.CR_not_met;
extend_path path_opt (Some pos);
raise (Exceptions.Skip_pointer_dereference (desc, try assert false with Assert_failure x -> x))
| Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty ->
trace_call Specs.CallStats.CR_not_met;
assert false
else (* no dereference error detected *)
let desc =
if list_exists (function Cannot_combine -> true | _ -> false) invalid_res then
call_desc (Some Localise.Pnm_dangling)
else if list_exists (function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn check callee_pname loc (try assert false with Assert_failure x -> x) in
raise exn
| _ -> false) invalid_res then
call_desc (Some Localise.Pnm_bounds)
else call_desc None in
trace_call Specs.CallStats.CR_not_met;
raise (Exceptions.Precondition_not_met (desc, try assert false with Assert_failure x -> x))
end
raise (Exceptions.Precondition_not_met (desc, try assert false with Assert_failure x -> x))
end
else (* combine the valid results, and store diverging states *)
let process_valid_res vr =
let save_diverging_states () =
if not vr.incons_pre_missing && vr.vr_cons_res = [] then (* no consistent results on one spec: divergence *)
let incons_res = list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in
State.add_diverging_states (Paths.PathSet.from_renamed_list incons_res) in
save_diverging_states ();
vr.vr_cons_res in
list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) (list_flatten (list_map process_valid_res valid_res))
let process_valid_res vr =
let save_diverging_states () =
if not vr.incons_pre_missing && vr.vr_cons_res = [] then (* no consistent results on one spec: divergence *)
let incons_res = list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) vr.vr_incons_res in
State.add_diverging_states (Paths.PathSet.from_renamed_list incons_res) in
save_diverging_states ();
vr.vr_cons_res in
list_map (fun (p, path) -> (prop_pure_to_footprint p, path)) (list_flatten (list_map process_valid_res valid_res))
end
else if valid_res_no_miss_pi != [] then
list_flatten (list_map (fun vr -> vr.vr_cons_res) valid_res_no_miss_pi)
@ -1060,20 +1060,20 @@ let exe_call_postprocess tenv ret_ids trace_call callee_pname loc initial_prop r
!Config.idempotent_getters && !Sil.curr_language = Sil.Java && is_likely_getter callee_pname in
match ret_ids with
| [ret_id] when should_add_ret_attr ()->
(* add attribute to remember what function call a return id came from *)
let ret_var = Sil.Var ret_id in
let mark_id_as_retval (p, path) =
(* check if the retval already has an important resource that should not be overwritten *)
let has_important_resource_attr =
match Prop.get_resource_undef_attribute p ret_var with
| Some (Sil.Aresource ({ Sil.ra_res = Sil.Rfile; })) -> true
| _ -> false in
if has_important_resource_attr then p, path
else
let check_attr_change att_old att_new = () in
let att_retval = Sil.Aretval callee_pname in
Prop.add_or_replace_exp_attribute check_attr_change p ret_var att_retval, path in
list_map mark_id_as_retval res
(* add attribute to remember what function call a return id came from *)
let ret_var = Sil.Var ret_id in
let mark_id_as_retval (p, path) =
(* check if the retval already has an important resource that should not be overwritten *)
let has_important_resource_attr =
match Prop.get_resource_undef_attribute p ret_var with
| Some (Sil.Aresource ({ Sil.ra_res = Sil.Rfile; })) -> true
| _ -> false in
if has_important_resource_attr then p, path
else
let check_attr_change att_old att_new = () in
let att_retval = Sil.Aretval callee_pname in
Prop.add_or_replace_exp_attribute check_attr_change p ret_var att_retval, path in
list_map mark_id_as_retval res
| _ -> res
(** Execute the function call and return the list of results with return value *)

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

@ -29,7 +29,7 @@ sig
type context
type field_context
val collect_items : Exe_env.t -> Cfg.cfg -> Sil.tenv -> t -> map ->
context -> field_context -> context * field_context * map * ret_t list
context -> field_context -> context * field_context * map * ret_t list
val to_t : ret_t -> t
val save_items_to_set : bool
val t_to_string : t -> string
@ -44,7 +44,7 @@ end
(* updating the map, add nodes for which the map changed back to TODO. 4. *)
(* Until the set is empty. *)
module Control_flow =
functor (TM : TODO_MAP) ->
functor (TM : TODO_MAP) ->
struct
let set_to_string set =
@ -112,8 +112,8 @@ struct
| [] -> ""
| [s, typ] ->
(match string_typ_to_string (s, typ) with
| Some s -> s
| None -> "")
| Some s -> s
| None -> "")
| (s, typ):: rest ->
match string_typ_to_string (s, typ) with
| Some s -> s^", "^(type_signature_to_string rest)
@ -203,9 +203,9 @@ struct
let print_stack stack =
let aux (typ, var_kind, level) =
print_endline (
(string_of_int level)^":"^
(Sil.typ_to_string typ)^"-"^
(var_kind_to_string var_kind)) in
(string_of_int level)^":"^
(Sil.typ_to_string typ)^"-"^
(var_kind_to_string var_kind)) in
Stack.iter aux stack
let print_map_value map_value =
@ -247,11 +247,11 @@ struct
let new_map_value = { map_value with type_stack = stack } in
Map.add var new_map_value context
with Not_found ->
let var_kind = typ_to_var_kind new_typ in
let stack = Stack.create () in
let _ = Stack.push (new_typ, var_kind, curr_level) stack in
let map_value = { var_level = curr_level; type_stack = stack } in
Map.add var map_value context
let var_kind = typ_to_var_kind new_typ in
let stack = Stack.create () in
let _ = Stack.push (new_typ, var_kind, curr_level) stack in
let map_value = { var_level = curr_level; type_stack = stack } in
Map.add var map_value context
(* Adds a type to a path starting from a variable. It replaces the top *)
(* of the stack if the level if the same as the current level, or it *)
@ -297,10 +297,10 @@ struct
with Not_found -> assert false in
match Stack.top map_value.type_stack with
| (typ, var_kind, level) ->
(* print_string ((key_to_string pvar)^"->"); print_endline ("typ is *)
(* "^(Sil.typ_to_string typ)); print_endline (var_kind_to_string *)
(* var_kind); print_string "the path is "; print_endline *)
(* (Utils.list_to_string Ident.fieldname_to_string path); *)
(* print_string ((key_to_string pvar)^"->"); print_endline ("typ is *)
(* "^(Sil.typ_to_string typ)); print_endline (var_kind_to_string *)
(* var_kind); print_string "the path is "; print_endline *)
(* (Utils.list_to_string Ident.fieldname_to_string path); *)
get_type_var_kind tenv typ path var_kind
end
@ -317,8 +317,8 @@ let rec super tenv t =
| Sil.Tptr (dom_type, p) ->
let super_dom_type = super tenv dom_type in
(match super_dom_type with
| None -> None
| Some super -> Some (Sil.Tptr (super, p)))
| None -> None
| Some super -> Some (Sil.Tptr (super, p)))
| _ -> None
let rec lub tenv t1 t2 =
@ -444,20 +444,20 @@ struct
match exp with
| Sil.Var id ->
(match get_id_exptyp id id_context with
| Exp exp -> aux exp
| Typ typ -> typ)
| Exp exp -> aux exp
| Typ typ -> typ)
| Sil.UnOp (unop, exp, typ) -> aux exp
| Sil.BinOp (binop, exp1, exp2) -> aux exp1
| Sil.Const const -> get_const_type const
| Sil.Cast (typ, exp) -> typ
| Sil.Lfield (e, fld, typ) ->
(try Field_context.Map.find fld field_context
with Not_found -> retrieve_type tenv fld typ)
with Not_found -> retrieve_type tenv fld typ)
| Sil.Lindex (Sil.Var id, i) ->
(match get_id_exptyp id id_context with
| Exp (Sil.Lvar pvar) ->
Context_map.get_type_content tenv pvar [] context
| _ -> assert false)
| Exp (Sil.Lvar pvar) ->
Context_map.get_type_content tenv pvar [] context
| _ -> assert false)
| Sil.Sizeof (typ, sub) -> assert false
| Sil.Lvar pvar ->
Context_map.get_type pvar context
@ -488,8 +488,8 @@ struct
let pred =
try list_find (fun p -> not (Set.mem p set)) preds
with Not_found ->
try list_hd preds
with Failure "hd" -> Set.min_elt set in
try list_hd preds
with Failure "hd" -> Set.min_elt set in
(aux pred) in
if (Set.mem old_node set) then backtrack ()
else
@ -500,8 +500,8 @@ struct
node in
match el with
| Some old_node ->
(* print_endline "choosing an element when old_element is "; *)
(* print_endline (t_to_string old_node); *)
(* print_endline "choosing an element when old_element is "; *)
(* print_endline (t_to_string old_node); *)
aux old_node
| None -> choose_start_node ()
@ -532,23 +532,23 @@ struct
let exp_typ = get_type tenv exp id_context context field_context in
let context, field_context =
(match exp1 with
| Sil.Lvar pvar ->
(* print_endline ("trying to add variable "^(Context_map.key_to_string *)
(* pvar) ); print_endline ("with type "^(Sil.typ_to_string exp_typ)); *)
(* print_endline "Context"; Context_map.print_map context; *)
Context_map.add_type pvar exp_typ 0 context, field_context
| Sil.Lfield (e, fld, typ) ->
context, Field_context.add_type tenv fld exp_typ field_context
| Sil.Lindex (Sil.Var id, _) ->
(match get_id_exptyp id id_context with
| Exp (Sil.Lvar pvar) ->
Context_map.add_type_content pvar [] exp_typ 0 context, field_context
| _ -> assert false)
| _ -> assert false) in
| Sil.Lvar pvar ->
(* print_endline ("trying to add variable "^(Context_map.key_to_string *)
(* pvar) ); print_endline ("with type "^(Sil.typ_to_string exp_typ)); *)
(* print_endline "Context"; Context_map.print_map context; *)
Context_map.add_type pvar exp_typ 0 context, field_context
| Sil.Lfield (e, fld, typ) ->
context, Field_context.add_type tenv fld exp_typ field_context
| Sil.Lindex (Sil.Var id, _) ->
(match get_id_exptyp id id_context with
| Exp (Sil.Lvar pvar) ->
Context_map.add_type_content pvar [] exp_typ 0 context, field_context
| _ -> assert false)
| _ -> assert false) in
id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), actual_params, loc, call_flags)
when not (SymExec.function_is_builtin callee_pname) ->
(* TODO: constraint for virtual calls *)
when not (SymExec.function_is_builtin callee_pname) ->
(* TODO: constraint for virtual calls *)
let cfg =
if (Procname.Set.mem callee_pname !defined_methods) then
Exe_env.get_cfg exe_env callee_pname
@ -573,22 +573,22 @@ struct
id_context, context, field_context, map', list
else id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), [(exp, class_type)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__new ->
when Procname.equal callee_pname SymExec.ModelBuiltins.__new ->
let id_context = set_ids ret_ids class_type id_context in
id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname),
[(array_size, array_type)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__new_array ->
[(array_size, array_type)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__new_array ->
let id_context = set_ids ret_ids array_type id_context in
id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname),
[(sil_ex, type_of_ex); (Sil.Sizeof (typ, _), Sil.Tvoid)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__cast ->
[(sil_ex, type_of_ex); (Sil.Sizeof (typ, _), Sil.Tvoid)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__cast ->
let id_context = set_ids ret_ids typ id_context in
id_context, context, field_context, map, list
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname),
[(sil_ex, type_of_ex); (_, Sil.Tvoid)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__instanceof ->
[(sil_ex, type_of_ex); (_, Sil.Tvoid)], loc, call_flags)
when Procname.equal callee_pname SymExec.ModelBuiltins.__instanceof ->
let id_context = set_ids ret_ids (Sil.Tint Sil.IBool) id_context in
id_context, context, field_context, map, list
| _ -> id_context, context, field_context, map, list in
@ -710,8 +710,8 @@ let arg_desc =
let options_to_keep = ["-results_dir"] in
let filter arg_desc =
list_filter (fun desc ->
let (option_name, _, _, _) = desc in
list_mem string_equal option_name options_to_keep)
let (option_name, _, _, _) = desc in
list_mem string_equal option_name options_to_keep)
arg_desc in
let desc = (filter Utils.base_arg_desc) in
Utils.Arg2.create_options_desc false "Parsing Options" desc in
@ -771,7 +771,7 @@ let load_cg_files _exe_env (source_dirs : DB.source_dir list) =
match Exe_env.add_cg _exe_env source_dir with
| None -> ()
| Some cg ->
(*L.err "loaded %s@." (DB.source_dir_to_string source_dir) *) () in
(*L.err "loaded %s@." (DB.source_dir_to_string source_dir) *) () in
list_iter (fun source_dir -> load_cg_file _exe_env source_dir) source_dirs;
let exe_env = Exe_env.freeze _exe_env in
exe_env

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

@ -96,8 +96,8 @@ let list_split =
| [] -> (acc1, acc2)
| (x, y):: l -> split (x:: acc1) (y:: acc2) l in
fun l ->
let acc1, acc2 = split [] [] l in
list_rev acc1, list_rev acc2
let acc1, acc2 = split [] [] l in
list_rev acc1, list_rev acc2
(** Like List.mem but without builtin equality *)
let list_mem equal x l = list_exists (equal x) l
@ -309,7 +309,7 @@ let pe_extend_colormap pe (x: Obj.t) (c: color) =
{ pe with pe_cmap_norm = colormap }
(** Set the object substitution, which is supposed to preserve the type.
Currently only used for a map from (identifier) expressions to the program var containing them *)
Currently only used for a map from (identifier) expressions to the program var containing them *)
let pe_set_obj_sub pe (sub: 'a -> 'a) =
let new_obj_sub x =
let x' = Obj.repr (sub (Obj.obj x)) in
@ -351,10 +351,10 @@ let rec _pp_semicolon_seq oneline pe pp f =
| [x] -> F.fprintf f "%a" pp x
| x:: l ->
(match pe.pe_kind with
| PP_TEXT | PP_HTML ->
F.fprintf f "%a ; %a%a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l
| PP_LATEX ->
F.fprintf f "%a ;\\\\%a %a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l)
| PP_TEXT | PP_HTML ->
F.fprintf f "%a ; %a%a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l
| PP_LATEX ->
F.fprintf f "%a ;\\\\%a %a" pp x pp_sep () (_pp_semicolon_seq oneline pe pp) l)
(** Print a ;-separated sequence with newlines. *)
let pp_semicolon_seq pe = _pp_semicolon_seq false pe
@ -368,12 +368,12 @@ let rec pp_or_seq pe pp f = function
| [x] -> F.fprintf f "%a" pp x
| x:: l ->
(match pe.pe_kind with
| PP_TEXT ->
F.fprintf f "%a || %a" pp x (pp_semicolon_seq pe pp) l
| PP_HTML ->
F.fprintf f "%a &or; %a" pp x (pp_semicolon_seq pe pp) l
| PP_LATEX ->
F.fprintf f "%a \\vee %a" pp x (pp_semicolon_seq pe pp) l)
| PP_TEXT ->
F.fprintf f "%a || %a" pp x (pp_semicolon_seq pe pp) l
| PP_HTML ->
F.fprintf f "%a &or; %a" pp x (pp_semicolon_seq pe pp) l
| PP_LATEX ->
F.fprintf f "%a \\vee %a" pp x (pp_semicolon_seq pe pp) l)
(** Produce a string from a 1-argument pretty printer function *)
let pp_to_string pp x =
@ -634,19 +634,19 @@ let copy_file fname_from fname_to =
None
module FileLOC = (** count lines of code of files and keep processed results in a cache *)
struct
let include_loc_hash = Hashtbl.create 1
let reset () = Hashtbl.clear include_loc_hash
let file_get_loc fname =
try Hashtbl.find include_loc_hash fname with Not_found ->
let loc = match read_file fname with
| None -> 0
| Some l -> list_length l in
Hashtbl.add include_loc_hash fname loc;
loc
end
struct
let include_loc_hash = Hashtbl.create 1
let reset () = Hashtbl.clear include_loc_hash
let file_get_loc fname =
try Hashtbl.find include_loc_hash fname with Not_found ->
let loc = match read_file fname with
| None -> 0
| Some l -> list_length l in
Hashtbl.add include_loc_hash fname loc;
loc
end
(** type for files used for printing *)
type outfile =
@ -661,8 +661,8 @@ let create_outfile fname =
let fmt = F.formatter_of_out_channel out_c in
Some { fname = fname; out_c = out_c; fmt = fmt }
with Sys_error _ ->
F.fprintf F.err_formatter "error: cannot create file %s@." fname;
None
F.fprintf F.err_formatter "error: cannot create file %s@." fname;
None
(** operate on an outfile reference if it is not None *)
let do_outf outf_ref f =
@ -769,63 +769,63 @@ let filename_to_relative root fname =
let base_arg_desc =
[
"-results_dir",
Arg.String (fun s -> Config.results_dir := s),
Some "dir",
"set the project results directory (default dir=" ^ Config.default_results_dir ^ ")";
"-coverage",
Arg.Unit (fun () -> Config.worklist_mode:= 2),
None,
"analysis mode to maximize coverage (can take longer)";
"-lib",
Arg.String (fun s -> Config.specs_library := filename_to_absolute s :: !Config.specs_library),
Some "dir",
"add dir to the list of directories to be searched for spec files";
"-models",
Arg.String (fun s -> Config.add_models (filename_to_absolute s)),
Some "zip file",
"add a zip file containing the models";
"-ziplib",
Arg.String (fun s -> Config.add_zip_library (filename_to_absolute s)),
Some "zip file",
"add a zip file containing library spec files";
"-project_root",
Arg.String (fun s -> Config.project_root := Some (filename_to_absolute s)),
Some "dir",
"root directory of the project";
"-infer_cache",
Arg.String (fun s -> Config.JarCache.infer_cache := Some (filename_to_absolute s)),
Some "dir",
"Select a directory to contain the infer cache";
"-results_dir",
Arg.String (fun s -> Config.results_dir := s),
Some "dir",
"set the project results directory (default dir=" ^ Config.default_results_dir ^ ")";
"-coverage",
Arg.Unit (fun () -> Config.worklist_mode:= 2),
None,
"analysis mode to maximize coverage (can take longer)";
"-lib",
Arg.String (fun s -> Config.specs_library := filename_to_absolute s :: !Config.specs_library),
Some "dir",
"add dir to the list of directories to be searched for spec files";
"-models",
Arg.String (fun s -> Config.add_models (filename_to_absolute s)),
Some "zip file",
"add a zip file containing the models";
"-ziplib",
Arg.String (fun s -> Config.add_zip_library (filename_to_absolute s)),
Some "zip file",
"add a zip file containing library spec files";
"-project_root",
Arg.String (fun s -> Config.project_root := Some (filename_to_absolute s)),
Some "dir",
"root directory of the project";
"-infer_cache",
Arg.String (fun s -> Config.JarCache.infer_cache := Some (filename_to_absolute s)),
Some "dir",
"Select a directory to contain the infer cache";
]
let reserved_arg_desc =
[
"-absstruct", Arg.Set_int Config.abs_struct, Some "n", "abstraction level for fields of structs (default n = 1)";
"-absval", Arg.Set_int Config.abs_val, Some "n", "abstraction level for expressions (default n = 2)";
"-arraylevel", Arg.Set_int Config.array_level, Some "n", "the level of treating the array indexing and pointer arithmetic (default n = 0)";
"-developer_mode", Arg.Set Config.developer_mode, None, "reserved";
"-dotty", Arg.Set Config.write_dotty, None, "produce dotty files in the results directory";
"-exit_node_bias", Arg.Unit (fun () -> Config.worklist_mode:= 1), None, "nodes nearest the exit node are analyzed first";
"-html", Arg.Set Config.write_html, None, "produce hmtl output in the results directory";
"-join_cond", Arg.Set_int Config.join_cond, Some "n", "set the strength of the final information-loss check used by the join (default n=1)";
"-leak", Arg.Set Config.allowleak, None, "forget leaks during abstraction";
"-max_procs", Arg.Set_int Config.max_num_proc, Some "n", "set the maximum number of processes to be used for parallel execution (default n=0)";
"-monitor_prop_size", Arg.Set Config.monitor_prop_size, None, "monitor size of props";
"-nelseg", Arg.Set Config.nelseg, None, "use only nonempty lsegs";
"-noliveness", Arg.Clear Config.liveness, None, "turn the dead program variable elimination off";
"-noprintdiff", Arg.Clear Config.print_using_diff, None, "turn off highlighting diff w.r.t. previous prop in printing";
"-notest", Arg.Clear Config.test, None, "turn test mode off";
"-num_cores", Arg.Set_int Config.num_cores, Some "n", "set the number of cores used in parallel by the analysis (default n=1)";
"-only_footprint", Arg.Set Config.only_footprint, None, "skip the re-execution phase";
"-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps";
"-set_pp_margin", Arg.Int (fun i -> F.set_margin i), Some "n", "set right margin for the pretty printing functions";
"-slice_fun", Arg.Set_string Config.slice_fun, None, "analyze only functions recursively called by function given as argument";
"-spec_abs_level", Arg.Set_int Config.spec_abs_level, Some "n", "set the level of abstracting the postconditions of discovered specs (default n=1)";
"-trace_error", Arg.Set Config.trace_error, None, "turn on tracing of error explanation";
"-trace_join", Arg.Set Config.trace_join, None, "turn on tracing of join";
"-trace_rearrange", Arg.Set Config.trace_rearrange, None, "turn on tracing of rearrangement";
"-visits_bias", Arg.Unit (fun () -> Config.worklist_mode:= 2), None, "nodes visited fewer times are analyzed first";
"-absstruct", Arg.Set_int Config.abs_struct, Some "n", "abstraction level for fields of structs (default n = 1)";
"-absval", Arg.Set_int Config.abs_val, Some "n", "abstraction level for expressions (default n = 2)";
"-arraylevel", Arg.Set_int Config.array_level, Some "n", "the level of treating the array indexing and pointer arithmetic (default n = 0)";
"-developer_mode", Arg.Set Config.developer_mode, None, "reserved";
"-dotty", Arg.Set Config.write_dotty, None, "produce dotty files in the results directory";
"-exit_node_bias", Arg.Unit (fun () -> Config.worklist_mode:= 1), None, "nodes nearest the exit node are analyzed first";
"-html", Arg.Set Config.write_html, None, "produce hmtl output in the results directory";
"-join_cond", Arg.Set_int Config.join_cond, Some "n", "set the strength of the final information-loss check used by the join (default n=1)";
"-leak", Arg.Set Config.allowleak, None, "forget leaks during abstraction";
"-max_procs", Arg.Set_int Config.max_num_proc, Some "n", "set the maximum number of processes to be used for parallel execution (default n=0)";
"-monitor_prop_size", Arg.Set Config.monitor_prop_size, None, "monitor size of props";
"-nelseg", Arg.Set Config.nelseg, None, "use only nonempty lsegs";
"-noliveness", Arg.Clear Config.liveness, None, "turn the dead program variable elimination off";
"-noprintdiff", Arg.Clear Config.print_using_diff, None, "turn off highlighting diff w.r.t. previous prop in printing";
"-notest", Arg.Clear Config.test, None, "turn test mode off";
"-num_cores", Arg.Set_int Config.num_cores, Some "n", "set the number of cores used in parallel by the analysis (default n=1)";
"-only_footprint", Arg.Set Config.only_footprint, None, "skip the re-execution phase";
"-print_types", Arg.Set Config.print_types, None, "print types in symbolic heaps";
"-set_pp_margin", Arg.Int (fun i -> F.set_margin i), Some "n", "set right margin for the pretty printing functions";
"-slice_fun", Arg.Set_string Config.slice_fun, None, "analyze only functions recursively called by function given as argument";
"-spec_abs_level", Arg.Set_int Config.spec_abs_level, Some "n", "set the level of abstracting the postconditions of discovered specs (default n=1)";
"-trace_error", Arg.Set Config.trace_error, None, "turn on tracing of error explanation";
"-trace_join", Arg.Set Config.trace_join, None, "turn on tracing of join";
"-trace_rearrange", Arg.Set Config.trace_rearrange, None, "turn on tracing of rearrangement";
"-visits_bias", Arg.Unit (fun () -> Config.worklist_mode:= 2), None, "nodes visited fewer times are analyzed first";
]
(**************** START MODULE Arg2 -- modified from Arg in the ocaml distribution ***************)
@ -864,7 +864,7 @@ module Arg2 = struct
let print_spec buf (key, spec, doc) =
match spec with
| Arg.Symbol (l, _) -> bprintf buf " %s %s%s\n" key (make_symlist "{" "|" "}" l)
doc
doc
| _ ->
let sep = if String.length doc != 0 && String.get doc 0 = '=' then "" else " " in
bprintf buf " %s%s%s\n" key sep doc
@ -875,11 +875,11 @@ module Arg2 = struct
let add1 =
try ignore (assoc3 "-help" speclist); []
with Not_found ->
["-help", Arg.Unit help_action, " Display this list of options"]
["-help", Arg.Unit help_action, " Display this list of options"]
and add2 =
try ignore (assoc3 "--help" speclist); []
with Not_found ->
["--help", Arg.Unit help_action, " Display this list of options"]
["--help", Arg.Unit help_action, " Display this list of options"]
in
speclist @ (add1 @ add2)
@ -926,72 +926,72 @@ module Arg2 = struct
with Not_found -> stop (Unknown s)
in
begin try
let rec treat_action = function
| Arg.Unit f -> f ();
| Arg.Bool f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (bool_of_string arg)
with Invalid_argument "bool_of_string" ->
raise (Stop (Wrong (s, arg, "a boolean")))
end;
incr current;
| Arg.Set r -> r := true;
| Arg.Clear r -> r := false;
| Arg.String f when !current + 1 < l ->
f argv.(!current + 1);
incr current;
| Arg.Symbol (symb, f) when !current + 1 < l ->
let arg = argv.(!current + 1) in
if list_mem string_equal arg symb then begin
f argv.(!current + 1);
let rec treat_action = function
| Arg.Unit f -> f ();
| Arg.Bool f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (bool_of_string arg)
with Invalid_argument "bool_of_string" ->
raise (Stop (Wrong (s, arg, "a boolean")))
end;
incr current;
end else begin
raise (Stop (Wrong (s, arg, "one of: "
^ (make_symlist "" " " "" symb))))
end
| Arg.Set_string r when !current + 1 < l ->
r := argv.(!current + 1);
incr current;
| Arg.Int f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Set_int r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Float f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Set_float r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Tuple specs ->
list_iter treat_action specs;
| Arg.Rest f ->
while !current < l - 1 do
| Arg.Set r -> r := true;
| Arg.Clear r -> r := false;
| Arg.String f when !current + 1 < l ->
f argv.(!current + 1);
incr current;
done;
| _ -> raise (Stop (Missing s))
in
treat_action action
with Bad m -> stop (Message m);
| Stop e -> stop e;
| Arg.Symbol (symb, f) when !current + 1 < l ->
let arg = argv.(!current + 1) in
if list_mem string_equal arg symb then begin
f argv.(!current + 1);
incr current;
end else begin
raise (Stop (Wrong (s, arg, "one of: "
^ (make_symlist "" " " "" symb))))
end
| Arg.Set_string r when !current + 1 < l ->
r := argv.(!current + 1);
incr current;
| Arg.Int f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Set_int r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (int_of_string arg)
with Failure "int_of_string" ->
raise (Stop (Wrong (s, arg, "an integer")))
end;
incr current;
| Arg.Float f when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try f (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Set_float r when !current + 1 < l ->
let arg = argv.(!current + 1) in
begin try r := (float_of_string arg);
with Failure "float_of_string" ->
raise (Stop (Wrong (s, arg, "a float")))
end;
incr current;
| Arg.Tuple specs ->
list_iter treat_action specs;
| Arg.Rest f ->
while !current < l - 1 do
f argv.(!current + 1);
incr current;
done;
| _ -> raise (Stop (Missing s))
in
treat_action action
with Bad m -> stop (Message m);
| Stop e -> stop e;
end;
incr current;
end else begin
@ -1117,8 +1117,8 @@ let join_strings sep = function
let next compare =
fun x y n ->
if n <> 0 then n
else compare x y
if n <> 0 then n
else compare x y
let directory_fold f init path =
@ -1130,7 +1130,7 @@ let directory_fold f init path =
else
(f accu full_path, dirs)
with Sys_error _ ->
(accu, dirs) in
(accu, dirs) in
let rec loop accu dirs =
match dirs with
| [] -> accu
@ -1153,7 +1153,7 @@ let directory_iter f path =
let () = f full_path in
dirs
with Sys_error _ ->
dirs in
dirs in
let rec loop dirs =
match dirs with
| [] -> ()

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

@ -40,9 +40,9 @@ let get_field_type_and_annotation fn = function
| Sil.Tptr (Sil.Tstruct (ftal, sftal, _, _, _, _, _), _)
| Sil.Tstruct (ftal, sftal, _, _, _, _, _) ->
(try
let (_, t, a) = list_find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in
Some (t, a)
with Not_found -> None)
let (_, t, a) = list_find (fun (f, t, a) -> Sil.fld_equal f fn) (ftal @ sftal) in
Some (t, a)
with Not_found -> None)
| _ -> None
let ia_iter f =
@ -140,7 +140,7 @@ let ia_is ann ia = match ann with
type get_method_annotation = Procname.t -> Cfg.Procdesc.t -> Sil.method_annotation
(** Get a method signature with annotations from a proc_name and proc_desc,
or search in the .specs file if it is not defined in the proc_desc. *)
or search in the .specs file if it is not defined in the proc_desc. *)
let get_annotated_signature get_method_annotation proc_desc proc_name : annotated_signature =
let method_annotation = get_method_annotation proc_name proc_desc in
let formals = Cfg.Procdesc.get_formals proc_desc in
@ -157,8 +157,8 @@ let get_annotated_signature get_method_annotation proc_desc proc_name : annotate
annotated_signature
(** Check if the annotated signature is for a wrapper of an anonymous inner class method.
These wrappers have the same name as the original method, every type is Object, and the parameters
are called x0, x1, x2. *)
These wrappers have the same name as the original method, every type is Object, and the parameters
are called x0, x1, x2. *)
let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
let check_ret (ia, t) =
Sil.item_annotation_is_empty ia && PatternMatch.type_is_object t in
@ -188,10 +188,10 @@ let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
(** Check if the given parameter has a Nullable annotation in the given signature *)
let param_is_nullable pvar ann_sig =
let pvar_str = Mangled.to_string (Sil.pvar_get_name pvar) in
list_exists
(fun (param_str, annot, _) -> param_str = pvar_str && ia_is_nullable annot)
ann_sig.params
let pvar_str = Mangled.to_string (Sil.pvar_get_name pvar) in
list_exists
(fun (param_str, annot, _) -> param_str = pvar_str && ia_is_nullable annot)
ann_sig.params
(** Pretty print a method signature with annotations. *)
let pp_annotated_signature proc_name fmt annotated_signature =

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

@ -23,7 +23,7 @@ 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)
when Sil.exp_is_null_literal rhs && IdSet.mem lhs this_ids ->
when Sil.exp_is_null_literal rhs && IdSet.mem lhs this_ids ->
(FldSet.add fld nullified_flds, this_ids)
| Sil.Letderef (id, rhs, _, _) when Sil.exp_is_this rhs ->
(nullified_flds, IdSet.add id this_ids)
@ -44,12 +44,12 @@ let android_lifecycle_typs = ref []
let get_or_create_lifecycle_typs tenv = match !android_lifecycle_typs with
| [] ->
let lifecycle_typs = list_fold_left (fun typs (pkg, clazz, methods) ->
let qualified_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt
let qualified_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt
qualified_name methods tenv with
| Some (framework_typ, _) -> framework_typ :: typs
| None -> typs
) [] AndroidFramework.get_lifecycles in
| Some (framework_typ, _) -> framework_typ :: typs
| None -> typs
) [] AndroidFramework.get_lifecycles in
android_lifecycle_typs := lifecycle_typs;
lifecycle_typs
| typs -> typs
@ -64,21 +64,21 @@ let done_checking num_methods =
!num_methods_checked = num_methods
(** ask Eradicate to check each of the procs in [registered_callback_procs] (and their transitive
* callees) in a context where each of the fields in [fields_nullifed] is marked as @Nullable *)
* callees) in a context where each of the fields in [fields_nullifed] is marked as @Nullable *)
let do_eradicate_check all_procs get_procdesc idenv tenv =
(* tell Eradicate to treat each of the fields nullified in on_destroy as nullable *)
FldSet.iter (fun fld -> Models.Inference.field_add_nullable_annotation fld) !fields_nullified;
Procname.Set.iter
(fun proc_name ->
match get_procdesc proc_name with
| Some proc_desc ->
do_eradicate_check all_procs get_procdesc idenv tenv proc_name proc_desc
| None -> ())
match get_procdesc proc_name with
| Some proc_desc ->
do_eradicate_check all_procs get_procdesc idenv tenv proc_name proc_desc
| None -> ())
!registered_callback_procs
(** if [procname] belongs to an Android lifecycle type, save the set of callbacks registered in
* [procname]. in addition, if [procname] is a special "destroy" /"cleanup" method, save the set of
* fields that are nullified *)
* [procname]. in addition, if [procname] is a special "destroy" /"cleanup" method, save the set of
* fields that are nullified *)
let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc =
match Sil.get_typ (Mangled.from_string (Procname.java_get_class proc_name)) None tenv with
| Some (Sil.Tstruct(_, _, csu, Some class_name, _, methods, _) as typ) ->
@ -93,15 +93,15 @@ let callback_checker_main all_procs get_procdesc idenv tenv proc_name proc_desc
(* find the callbacks registered by this procedure and update the list *)
let registered_callback_procs' = list_fold_left
(fun callback_procs callback_typ ->
match callback_typ with
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) ->
list_fold_left
(fun callback_procs callback_proc ->
if Procname.is_constructor callback_proc then callback_procs
else Procname.Set.add callback_proc callback_procs)
callback_procs
methods
| typ -> callback_procs)
match callback_typ with
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _), _) ->
list_fold_left
(fun callback_procs callback_proc ->
if Procname.is_constructor callback_proc then callback_procs
else Procname.Set.add callback_proc callback_procs)
callback_procs
methods
| typ -> callback_procs)
!registered_callback_procs
registered_callback_typs in
registered_callback_procs := registered_callback_procs';

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

@ -18,7 +18,7 @@ let verbose = ref true
(** Convenience functions for chechers to print information *)
module PP = struct
(** Print a range of lines of the source file in [loc], including [nbefore] lines before loc
and [nafter] lines after [loc] *)
and [nafter] lines after [loc] *)
let pp_loc_range linereader nbefore nafter fmt loc =
let printline n = match Printer.LineReader.from_loc linereader { loc with Sil.line = n } with
| Some s -> F.fprintf fmt "%s%s@\n" (if n = loc.Sil.line then "-->" else " ") s
@ -56,7 +56,7 @@ module ST = struct
let store_summary proc_name =
Option.may
(fun summary ->
try Specs.store_summary proc_name summary with Sys_error s -> L.err "%s@." s)
try Specs.store_summary proc_name summary with Sys_error s -> L.err "%s@." s)
(Specs.get_summary proc_name)
let report_error
@ -77,10 +77,10 @@ module ST = struct
let exn = exception_kind kind localized_description in
(* Errors can be suppressed with annotations. An error of kind CHECKER_ERROR_NAME can be
suppressed with the following annotations:
- @android.annotation.SuppressLint("checker-error-name")
- @some.PrefixErrorName
where the kind matching is case - insensitive and ignores '-' and '_' characters. *)
suppressed with the following annotations:
- @android.annotation.SuppressLint("checker-error-name")
- @some.PrefixErrorName
where the kind matching is case - insensitive and ignores '-' and '_' characters. *)
let suppressed =
let annotation_matches a =
let normalize str =
@ -106,19 +106,19 @@ module ST = struct
let is_field_suppressed =
match field_name, PatternMatch.get_this_type proc_desc with
| Some field_name, Some t -> begin
match (Annotations.get_field_type_and_annotation field_name t) with
| Some (_, ia) -> Annotations.ia_has_annotation_with ia annotation_matches
| None -> false
end
match (Annotations.get_field_type_and_annotation field_name t) with
| Some (_, ia) -> Annotations.ia_has_annotation_with ia annotation_matches
| None -> false
end
| _ -> false in
let is_class_suppressed =
match (PatternMatch.get_this_type proc_desc) with
| Some t -> begin
match (PatternMatch.type_get_annotation t) with
| Some ia -> Annotations.ia_has_annotation_with ia annotation_matches
| None -> false
end
match (PatternMatch.type_get_annotation t) with
| Some ia -> Annotations.ia_has_annotation_with ia annotation_matches
| None -> false
end
| None -> false in
is_method_suppressed || is_field_suppressed || is_class_suppressed in
@ -213,8 +213,8 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name
let class_name = Procname.java_get_class proc_name in
let method_name = Procname.java_get_method proc_name in
(try
class_name = "android.os.Parcel" && (String.sub method_name 0 5 = "write" || String.sub method_name 0 4 = "read")
with Invalid_argument _ -> false)
class_name = "android.os.Parcel" && (String.sub method_name 0 5 = "write" || String.sub method_name 0 4 = "read")
with Invalid_argument _ -> false)
| _ -> assert false in
let is_inverse rc wc =
@ -256,9 +256,9 @@ let callback_check_write_to_parcel all_procs get_proc_desc idenv tenv proc_name
match parcel_constructors this_type with
| x :: xs ->
(match get_proc_desc x with
| Some x_proc_desc ->
check x x_proc_desc proc_name proc_desc
| None -> raise Not_found)
| Some x_proc_desc ->
check x x_proc_desc proc_name 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@."
end
@ -270,15 +270,15 @@ let callback_monitor_nullcheck all_procs get_proc_desc idenv tenv proc_name proc
let verbose = ref false in
let class_formal_names = lazy (
let formals = Cfg.Procdesc.get_formals proc_desc in
let class_formals =
let is_class_type = function
| "this", Sil.Tptr _ -> false (* no need to null check 'this' *)
| _, Sil.Tstruct _ -> true
| _, Sil.Tptr (Sil.Tstruct _, _) -> true
| _ -> false in
list_filter is_class_type formals in
list_map (fun (s, _) -> Mangled.from_string s) class_formals) in
let formals = Cfg.Procdesc.get_formals proc_desc in
let class_formals =
let is_class_type = function
| "this", Sil.Tptr _ -> false (* no need to null check 'this' *)
| _, Sil.Tstruct _ -> true
| _, Sil.Tptr (Sil.Tstruct _, _) -> true
| _ -> false in
list_filter is_class_type formals in
list_map (fun (s, _) -> Mangled.from_string s) class_formals) in
let equal_formal_param exp formal_name = match exp with
| Sil.Lvar pvar ->
let name = Sil.pvar_get_name pvar in
@ -363,40 +363,40 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name p
try
ST.pname_find proc_name' ret_const_key
with Not_found ->
match get_proc_desc proc_name' with
Some proc_desc' ->
let is_return_instr = function
| Sil.Set (Sil.Lvar p, _, _, _)
match get_proc_desc proc_name' with
Some proc_desc' ->
let is_return_instr = function
| Sil.Set (Sil.Lvar p, _, _, _)
when Sil.pvar_equal p (Cfg.Procdesc.get_ret_var proc_desc') -> true
| _ -> false in
(match reverse_find_instr is_return_instr (Cfg.Procdesc.get_exit_node proc_desc') with
| Some (Sil.Set (_, _, Sil.Const (Sil.Cclass n), _)) -> Ident.name_to_string n
| _ -> "<" ^ (Procname.to_string proc_name') ^ ">")
| None -> "?" in
| _ -> false in
(match reverse_find_instr is_return_instr (Cfg.Procdesc.get_exit_node proc_desc') with
| Some (Sil.Set (_, _, Sil.Const (Sil.Cclass n), _)) -> Ident.name_to_string n
| _ -> "<" ^ (Procname.to_string proc_name') ^ ">")
| 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) -> (try
let find_const exp typ =
let expanded = Idenv.expand_expr idenv exp in
match expanded with
| Sil.Const (Sil.Cclass n) -> Ident.name_to_string n
| Sil.Lvar p -> (
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
| _ -> 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
| _ -> "?")
| _ -> "?")
| _ -> "?" in
let arg_name (exp, typ) = find_const exp typ in
Some (list_map arg_name args)
with _ -> None)
let find_const exp typ =
let expanded = Idenv.expand_expr idenv exp in
match expanded with
| Sil.Const (Sil.Cclass n) -> Ident.name_to_string n
| Sil.Lvar p -> (
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
| _ -> 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
| _ -> "?")
| _ -> "?")
| _ -> "?" in
let arg_name (exp, typ) = find_const exp typ in
Some (list_map arg_name args)
with _ -> None)
| _ -> None in
let process_result instr result =
@ -406,22 +406,22 @@ let callback_find_deserialization all_procs get_proc_desc idenv tenv proc_name p
);
match result with
| str when (Str.string_match (Str.regexp "<\\(.*\\)>") str 0) -> (
let missing_proc_name = Str.matched_group 1 str in
L.stdout "Deserialization of %s requires 2nd phase: " str;
L.stdout "missing: %s@." missing_proc_name)
let missing_proc_name = Str.matched_group 1 str in
L.stdout "Deserialization of %s requires 2nd phase: " str;
L.stdout "missing: %s@." missing_proc_name)
| "?" -> L.stdout "Unable to resolve deserialization\n\n@."
| _ -> L.stdout "Deserialization of %s\n\n@." result in
let do_instr node instr =
match PatternMatch.get_java_method_call_formal_signature instr with
| Some (_, "readValue", _, _) -> (
match get_actual_arguments node instr with
| Some [_; cl] -> process_result instr cl
| _ -> process_result instr "?")
match get_actual_arguments node instr with
| Some [_; cl] -> process_result instr cl
| _ -> process_result instr "?")
| Some (_, "readValueAs", _, _) -> (
match get_actual_arguments node instr with
| Some [cl] -> process_result instr cl
| _ -> process_result instr "?")
match get_actual_arguments node instr with
| Some [cl] -> process_result instr cl
| _ -> process_result instr "?")
| _ -> () in
let store_return () =
@ -478,7 +478,7 @@ let callback_check_field_access all_procs get_proc_desc idenv tenv proc_name pro
let callback_print_c_method_calls all_procs get_proc_desc idenv tenv proc_name proc_desc =
let do_instr node = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (e, t):: args, loc, cf)
when Procname.is_c_method pn ->
when Procname.is_c_method pn ->
let receiver = match Errdesc.exp_rv_dexp node e with
| Some de -> Sil.dexp_to_string de
| None -> "?" in

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

@ -47,9 +47,9 @@ module Err = struct
} in
[(Specs.spec_normalize spec)] in
let new_summ = { old_summ with
Specs.loc = Cfg.Procdesc.get_loc proc_desc;
Specs.nodes = nodes;
Specs.payload = Specs.PrePosts specs } in
Specs.loc = Cfg.Procdesc.get_loc proc_desc;
Specs.nodes = nodes;
Specs.payload = Specs.PrePosts specs } in
Specs.add_summary proc_name new_summ
let add_error_to_spec proc_name s node loc =
@ -84,8 +84,8 @@ module Match = struct
let value' = Hashtbl.find env id in
value_equal value value'
with Not_found ->
Hashtbl.add env id value;
true
Hashtbl.add env id value;
true
let pp_env fmt env =
let pp_item id value =
F.fprintf fmt "%s=%a " id pp_value value in

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

@ -41,8 +41,8 @@ module ConstantFlow = Dataflow.MakeDF(struct
Format.fprintf fmt "]@."
(* Item - wise equality where values are equal iff
- both are None
- both are a constant and equal wrt. Sil.const_equal *)
- both are None
- both are a constant and equal wrt. Sil.const_equal *)
let equal m n = ConstantMap.equal (opt_equal Sil.const_equal) m n
let join = ConstantMap.merge merge_values
@ -71,32 +71,32 @@ module ConstantFlow = Dataflow.MakeDF(struct
(* Handle propagation of string with StringBuilder. Does not handle null case *)
| Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var sb, _):: [], _, _)
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "<init>" -> (* StringBuilder.<init> *)
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "<init>" -> (* StringBuilder.<init> *)
update (Sil.Var sb) (Some (Sil.Cstr "")) constants
| Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: [], _, _)
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "toString" -> (* StringBuilder.toString *)
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "toString" -> (* StringBuilder.toString *)
update (Sil.Var i) (ConstantMap.find (Sil.Var i1) constants) constants
| Sil.Call (i:: [], Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], _, _)
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "append" -> (* StringBuilder.append *)
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "append" -> (* StringBuilder.append *)
(match
ConstantMap.find (Sil.Var i1) constants,
ConstantMap.find (Sil.Var i2) constants with
| Some (Sil.Cstr s1), Some (Sil.Cstr s2) ->
begin
let s = s1 ^ s2 in
let u =
if String.length s < string_widening_limit then
Some (Sil.Cstr s)
else
None in
update (Sil.Var i) u constants
end
| _ -> constants)
ConstantMap.find (Sil.Var i1) constants,
ConstantMap.find (Sil.Var i2) constants with
| Some (Sil.Cstr s1), Some (Sil.Cstr s2) ->
begin
let s = s1 ^ s2 in
let u =
if String.length s < string_widening_limit then
Some (Sil.Cstr s)
else
None in
update (Sil.Var i) u constants
end
| _ -> constants)
| _ -> constants
with Not_found -> constants in

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

@ -49,10 +49,10 @@ let node_throws node (proc_throws : Procname.t -> throws) : throws =
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 ->
(* assignment to return variable is an artifact of a throw instruction *)
(* assignment to return variable is an artifact of a throw instruction *)
Throws
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pn), args, loc, _)
when SymExec.function_is_builtin callee_pn ->
when SymExec.function_is_builtin callee_pn ->
if Procname.equal callee_pn SymExec.ModelBuiltins.__cast
then DontKnow
else DoesNotThrow

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

@ -32,9 +32,9 @@ type parameters = TypeState.parameters
module type CallBackT =
sig
val callback :
TypeCheck.checks -> Procname.t list -> TypeCheck.get_proc_desc ->
Idenv.t -> Sil.tenv -> Procname.t ->
Cfg.Procdesc.t -> unit
TypeCheck.checks -> Procname.t list -> TypeCheck.get_proc_desc ->
Idenv.t -> Sil.tenv -> Procname.t ->
Cfg.Procdesc.t -> unit
end (* CallBackT *)
(** Extension to the type checker. *)
@ -47,7 +47,7 @@ end
(** Create a module with the toplevel callback. *)
module MkCallback
(Extension : ExtensionT)
: CallBackT =
: CallBackT =
struct
(** Update the summary with stats from the checker. *)
let update_summary proc_name proc_desc final_typestate_opt =
@ -126,10 +126,10 @@ struct
find_canonical_duplicate annotated_signature typestate node linereader in
if trace then
list_iter (fun typestate_succ ->
L.stdout
"Typestate After Node %a@\n%a@."
Cfg.Node.pp node
(TypeState.pp Extension.ext) typestate_succ)
L.stdout
"Typestate After Node %a@\n%a@."
Cfg.Node.pp node
(TypeState.pp Extension.ext) typestate_succ)
typestates_succ;
typestates_succ, typestates_exn
let proc_throws pn = DontKnow
@ -190,7 +190,7 @@ struct
!res in
(** Get the initializers recursively called by computing a fixpoint.
Start from the initializers of the current class and the current procedure. *)
Start from the initializers of the current class and the current procedure. *)
let initializers_recursive : init list =
let initializers_base_case = initializers_current_class in
@ -227,8 +227,8 @@ struct
let pname_and_pdescs_with f =
list_map
(fun n -> match get_proc_desc n with
| Some d -> [(n, d)]
| None -> [])
| Some d -> [(n, d)]
| None -> [])
all_procs
|> list_flatten
|> list_filter f
@ -243,8 +243,8 @@ struct
let initializers_current_class =
pname_and_pdescs_with
(fun (pname, pdesc) ->
is_initializer pdesc pname &&
Procname.java_get_class pname = Procname.java_get_class curr_pname) in
is_initializer pdesc pname &&
Procname.java_get_class pname = Procname.java_get_class curr_pname) in
final_typestates ((curr_pname, curr_pdesc):: initializers_current_class)
end
@ -254,8 +254,8 @@ struct
let constructors_current_class =
pname_and_pdescs_with
(fun (n, d) ->
Procname.is_constructor n &&
Procname.java_get_class n = Procname.java_get_class curr_pname) in
Procname.is_constructor n &&
Procname.java_get_class n = Procname.java_get_class curr_pname) in
final_typestates constructors_current_class
end
@ -265,8 +265,8 @@ struct
let do_typestate typestate =
let start_node = Cfg.Procdesc.get_start_node curr_pdesc in
if not calls_this && (* if 'this(...)' is called, no need to check initialization *)
check_field_initialization &&
checks.TypeCheck.eradicate
check_field_initialization &&
checks.TypeCheck.eradicate
then begin
EradicateChecks.check_constructor_initialization
find_canonical_duplicate
@ -305,7 +305,7 @@ struct
let filter_special_cases () =
if Procname.java_is_access_method proc_name ||
(Specs.proc_get_attributes proc_name proc_desc).Sil.is_bridge_method
(Specs.proc_get_attributes proc_name proc_desc).Sil.is_bridge_method
then None
else
begin
@ -313,11 +313,11 @@ struct
if (Specs.proc_get_attributes proc_name proc_desc).Sil.is_abstract then
begin
if Models.infer_library_return &&
EradicateChecks.classify_procedure proc_name proc_desc = "L" then
EradicateChecks.classify_procedure proc_name proc_desc = "L" then
(let ret_is_nullable = (* get the existing annotation *)
let ia, _ = annotated_signature.Annotations.ret in
Annotations.ia_is_nullable ia in
EradicateChecks.pp_inferred_return_annotation ret_is_nullable proc_name);
let ia, _ = annotated_signature.Annotations.ret in
Annotations.ia_is_nullable ia in
EradicateChecks.pp_inferred_return_annotation ret_is_nullable proc_name);
Some annotated_signature
end
else
@ -342,7 +342,7 @@ end (* MkCallback *)
(** Given an extension to the typestate with a check, call the check on each instruction. *)
module Build
(Extension : ExtensionT)
: CallBackT =
: CallBackT =
struct
module Callback = MkCallback(Extension)
let callback = Callback.callback

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

@ -42,7 +42,7 @@ let get_field_annotation fn typ =
(* TODO (t4968422) eliminate not !Config.eradicate check by marking fields as nullified *)
(* outside of Eradicate in some other way *)
if (Models.Inference.enabled || not !Config.eradicate)
&& Models.Inference.field_is_marked fn
&& Models.Inference.field_is_marked fn
then Annotations.mk_ia Annotations.Nullable ia
else ia in
Some (t, ia')
@ -138,7 +138,7 @@ let check_condition case_zero find_canonical_duplicate get_proc_desc curr_pname
| _ -> false in
let do_instr = function
| Sil.Call (_, Sil.Const (Sil.Cfun pn), [_; (Sil.Sizeof(t, _), _)], _, _) when
Procname.equal pn SymExec.ModelBuiltins.__instanceof && typ_is_throwable t ->
Procname.equal pn SymExec.ModelBuiltins.__instanceof && typ_is_throwable t ->
throwable_found := true
| _ -> () in
let do_node n =
@ -264,10 +264,10 @@ let check_constructor_initialization
| None -> unknown in
list_exists
(function pname, typestate ->
let pvar = Sil.mk_pvar
(Mangled.from_string (Ident.fieldname_to_string fn))
pname in
filter_range_opt (TypeState.lookup_pvar pvar typestate))
let pvar = Sil.mk_pvar
(Mangled.from_string (Ident.fieldname_to_string fn))
pname in
filter_range_opt (TypeState.lookup_pvar pvar typestate))
list in
let may_be_assigned_in_final_typestate =
@ -299,7 +299,7 @@ let check_constructor_initialization
(* Check if field is missing annotation. *)
if not (nullable_annotated || nonnull_annotated) &&
not may_be_assigned_in_final_typestate then
not may_be_assigned_in_final_typestate then
report_error
find_canonical_duplicate
start_node
@ -310,8 +310,8 @@ let check_constructor_initialization
(* Check if field is over-annotated. *)
if activate_field_over_annotated &&
nullable_annotated &&
not (may_be_nullable_in_final_typestate ()) then
nullable_annotated &&
not (may_be_nullable_in_final_typestate ()) then
report_error
find_canonical_duplicate
start_node
@ -410,7 +410,7 @@ let check_call_receiver
find_canonical_duplicate
node
(TypeErr.Call_receiver_annotation_inconsistent
(ann, descr, callee_pname, origin_descr))
(ann, descr, callee_pname, origin_descr))
(Some instr_ref)
loc curr_pname
end
@ -484,7 +484,7 @@ let check_call_parameters
check (list_rev sig_params) (list_rev call_params)
(** Checks if the annotations are consistent with the inherited class or with the
implemented interfaces *)
implemented interfaces *)
let check_overridden_annotations
find_canonical_duplicate get_proc_desc tenv proc_name proc_desc annotated_signature =
@ -512,12 +512,12 @@ let check_overridden_annotations
let _, overriden_ia, overriden_type = overriden_param in
let () =
if not (Annotations.ia_is_nullable current_ia)
&& Annotations.ia_is_nullable overriden_ia then
&& Annotations.ia_is_nullable overriden_ia then
report_error
find_canonical_duplicate
start_node
(TypeErr.Inconsistent_subclass_parameter_annotation
(current_name, pos, proc_name, overriden_proc_name))
(current_name, pos, proc_name, overriden_proc_name))
None
loc proc_name in
(pos + 1) in
@ -549,8 +549,8 @@ let check_overridden_annotations
not (Procname.is_constructor pname) in
list_iter
(fun pname ->
if is_override pname
then check pname)
if is_override pname
then check pname)
methods
| _ -> () in

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

@ -8,7 +8,7 @@
*)
(** Environment for temporary identifiers used in instructions.
Lazy implementation: only created when actually used. *)
Lazy implementation: only created when actually used. *)
type t = (Sil.exp Ident.IdentHash.t) Lazy.t * Cfg.cfg
@ -41,8 +41,8 @@ let lookup (_map, _) id =
let expand_expr idenv e = match e with
| Sil.Var id ->
(match lookup idenv id with
| Some e' -> e'
| None -> e)
| Some e' -> e'
| None -> e)
| _ -> e
let expand_expr_temps idenv node _exp =
@ -50,9 +50,9 @@ let expand_expr_temps idenv node _exp =
match exp with
| Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar ->
(match Errdesc.find_program_variable_assignment node pvar with
| None -> exp
| Some (_, id) ->
expand_expr idenv (Sil.Var id))
| None -> exp
| Some (_, id) ->
expand_expr idenv (Sil.Var id))
| _ -> exp
(** Return true if the expression is a temporary variable introduced by the front-end. *)

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

@ -18,14 +18,14 @@ let check_immutable_cast curr_pname curr_pdesc typ_expected typ_found_opt loc :
begin
let casts =
[
"java.util.List", "com.google.common.collect.ImmutableList";
"java.util.Map", "com.google.common.collect.ImmutableMap";
"java.util.Set", "com.google.common.collect.ImmutableSet"
"java.util.List", "com.google.common.collect.ImmutableList";
"java.util.Map", "com.google.common.collect.ImmutableMap";
"java.util.Set", "com.google.common.collect.ImmutableSet"
] in
let in_casts expected given =
list_exists (fun (x, y) -> Mangled.from_string x = expected && Mangled.from_string y = given) casts in
match PatternMatch.type_get_class_name typ_expected,
PatternMatch.type_get_class_name typ_found with
PatternMatch.type_get_class_name typ_found with
| Some name_expected, Some name_given ->
if in_casts name_expected name_given then
begin

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

@ -121,69 +121,69 @@ let check_not_null_parameter_list, check_not_null_list =
let x = if check_not_null_strict then o else n in
let list =
[
1, (o, [x; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object";
1, (o, [x; n; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object";
1, (o, [x]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object):java.lang.Object";
1, (o, [x; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object";
1, (o, [x; n; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object";
1, (o, [x]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object):java.lang.Object";
1, (o, [x]), "org.junit.Assert.assertNotNull(java.lang.Object):void";
2, (o, [n; x]), "org.junit.Assert.assertNotNull(java.lang.String,java.lang.Object):void";
1, (o, [n]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object):java.lang.Object";
1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object,java.lang.String):java.lang.Object";
1, (o, [n]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object):java.lang.Object";
1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object";
1, (o, [x; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object";
1, (o, [x; n; n]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object";
1, (o, [x]), "com.facebook.common.internal.Preconditions.checkNotNull(java.lang.Object):java.lang.Object";
1, (o, [x; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.Object):java.lang.Object";
1, (o, [x; n; n]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object,java.lang.String,java.lang.Object[]):java.lang.Object";
1, (o, [x]), "com.google.common.base.Preconditions.checkNotNull(java.lang.Object):java.lang.Object";
1, (o, [x]), "org.junit.Assert.assertNotNull(java.lang.Object):void";
2, (o, [n; x]), "org.junit.Assert.assertNotNull(java.lang.String,java.lang.Object):void";
1, (o, [n]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object):java.lang.Object";
1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assertNotNull(java.lang.Object,java.lang.String):java.lang.Object";
1, (o, [n]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object):java.lang.Object";
1, (o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeNotNull(java.lang.Object,java.lang.String):java.lang.Object";
] in
list_map (fun (x, y, z) -> (x, z)) list, list_map (fun (x, y, z) -> (y, z)) list
let check_state_list =
[
(o, [n]), "Preconditions.checkState(boolean):void";
(o, [n]), "com.facebook.common.internal.Preconditions.checkState(boolean):void";
(o, [n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.google.common.base.Preconditions.checkState(boolean):void";
(o, [n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean):void";
(o, [n; o]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean,java.lang.String):void";
(o, [n]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean):void";
(o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean,java.lang.String):void";
(o, [n]), "Preconditions.checkState(boolean):void";
(o, [n]), "com.facebook.common.internal.Preconditions.checkState(boolean):void";
(o, [n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.google.common.base.Preconditions.checkState(boolean):void";
(o, [n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.google.common.base.Preconditions.checkState(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean):void";
(o, [n; o]), "com.facebook.infer.annotation.Assertions.assertCondition(boolean,java.lang.String):void";
(o, [n]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean):void";
(o, [n; o]), "com.facebook.infer.annotation.Assertions.assumeCondition(boolean,java.lang.String):void";
]
let check_argument_list =
[
(o, [n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean):void";
(o, [n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.google.common.base.Preconditions.checkArgument(boolean):void";
(o, [n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean):void";
(o, [n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void";
(o, [n]), "com.google.common.base.Preconditions.checkArgument(boolean):void";
(o, [n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.Object):void";
(o, [n; n; n]), "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void";
]
let optional_get_list : ((_ * bool list) * _) list =
[
(o, []), "Optional.get():java.lang.Object";
(o, []), "com.google.common.base.Optional.get():java.lang.Object";
(o, []), "Optional.get():java.lang.Object";
(o, []), "com.google.common.base.Optional.get():java.lang.Object";
]
let optional_isPresent_list : ((_ * bool list) * _) list =
[
(o, []), "Optional.isPresent():boolean";
(o, []), "com.google.common.base.Optional.isPresent():boolean";
(o, []), "Optional.isPresent():boolean";
(o, []), "com.google.common.base.Optional.isPresent():boolean";
]
(** Models for Map.containsKey *)
let containsKey_list =
[
n1, "com.google.common.collect.ImmutableMap.containsKey(java.lang.Object):boolean";
n1, "java.util.Map.containsKey(java.lang.Object):boolean";
n1, "com.google.common.collect.ImmutableMap.containsKey(java.lang.Object):boolean";
n1, "java.util.Map.containsKey(java.lang.Object):boolean";
]
(** Models for @Strict annotations *)
let annotated_list_strict =
[
(n, [o]), "android.content.Context.getSystemService(java.lang.String):java.lang.Object";
(n, [o]), "android.content.Context.getSystemService(java.lang.String):java.lang.Object";
]
(** Models for @Nullable annotations *)
@ -191,53 +191,53 @@ let annotated_list_nullable =
check_not_null_list @ check_state_list @ check_argument_list @
annotated_list_strict @
[
n1, "android.os.Parcel.writeList(java.util.List):void";
n2, "android.os.Parcel.writeParcelable(android.os.Parcelable,int):void";
n1, "android.os.Parcel.writeString(java.lang.String):void";
(o, [o; o; n; n; n]), "com.android.sdklib.build.ApkBuilder.<init>(java.io.File,java.io.File,java.io.File,java.lang.String,java.io.PrintStream)";
(o, [n]), "com.android.manifmerger.ManifestMerger.xmlFileAndLine(org.w3c.dom.Node):com.android.manifmerger.IMergerLog$FileAndLine";
on, "com.android.util.CommandLineParser$Mode.process(com.android.util.CommandLineParser$Arg,java.lang.String):java.lang.Object";
on, "com.google.common.base.Objects$ToStringHelper.add(java.lang.String,java.lang.Object):com.google.common.base.Objects$ToStringHelper";
n2, "com.google.common.base.Objects.equal(java.lang.Object,java.lang.Object):boolean";
n1, "com.google.common.base.Optional.fromNullable(java.lang.Object):com.google.common.base.Optional";
(n, []), "com.google.common.base.Optional.orNull():java.lang.Object";
n1, "com.google.common.base.Strings.nullToEmpty(java.lang.String):java.lang.String";
cg, "com.google.common.collect.ImmutableMap.get(java.lang.Object):java.lang.Object"; (* container get *)
o1, "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder";
o1, "com.google.common.collect.ImmutableList$Builder.addAll(java.lang.Iterable):com.google.common.collect.ImmutableList$Builder";
o1, "com.google.common.collect.ImmutableSortedSet$Builder.add(java.lang.Object):com.google.common.collect.ImmutableSortedSet$Builder";
on, "com.google.common.collect.Iterables.getFirst(java.lang.Iterable,java.lang.Object):java.lang.Object";
o1, "com.google.common.util.concurrent.SettableFuture.setException(java.lang.Throwable):boolean";
o1, "java.io.File.<init>(java.lang.String)";
n1, "java.io.PrintStream.print(java.lang.String):void";
o1, "java.lang.Class.isAssignableFrom(java.lang.Class):boolean";
n1, "java.lang.Integer.equals(java.lang.Object):boolean";
n2, "java.lang.RuntimeException.<init>(java.lang.String,java.lang.Throwable)";
n1, "java.lang.String.equals(java.lang.Object):boolean";
n1, "java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder";
on, "java.net.URLClassLoader.newInstance(java.net.URL[],java.lang.ClassLoader):java.net.URLClassLoader";
n1, "java.util.AbstractList.equals(java.lang.Object):boolean";
ca, "java.util.ArrayList.add(java.lang.Object):boolean"; (* container add *)
ca, "java.util.List.add(java.lang.Object):boolean"; (* container add *)
cg, "java.util.Map.get(java.lang.Object):java.lang.Object"; (* container get *)
cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object"; (* container put *)
n3, "javax.tools.JavaCompiler.getStandardFileManager(javax.tools.DiagnosticListener,java.util.Locale,java.nio.charset.Charset):javax.tools.StandardJavaFileManager";
(n, [o; n; n]), "org.w3c.dom.Document.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object";
(n, [o; n; n]), "org.w3c.dom.Node.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object";
(* References *)
ng, "java.lang.ref.Reference.get():java.lang.Object";
ng, "java.lang.ref.PhantomReference.get():java.lang.Object";
ng, "java.lang.ref.SoftReference.get():java.lang.Object";
ng, "java.lang.ref.WeakReference.get():java.lang.Object";
ng, "java.util.concurrent.atomic.AtomicReference.get():java.lang.Object";
n1, "android.os.Parcel.writeList(java.util.List):void";
n2, "android.os.Parcel.writeParcelable(android.os.Parcelable,int):void";
n1, "android.os.Parcel.writeString(java.lang.String):void";
(o, [o; o; n; n; n]), "com.android.sdklib.build.ApkBuilder.<init>(java.io.File,java.io.File,java.io.File,java.lang.String,java.io.PrintStream)";
(o, [n]), "com.android.manifmerger.ManifestMerger.xmlFileAndLine(org.w3c.dom.Node):com.android.manifmerger.IMergerLog$FileAndLine";
on, "com.android.util.CommandLineParser$Mode.process(com.android.util.CommandLineParser$Arg,java.lang.String):java.lang.Object";
on, "com.google.common.base.Objects$ToStringHelper.add(java.lang.String,java.lang.Object):com.google.common.base.Objects$ToStringHelper";
n2, "com.google.common.base.Objects.equal(java.lang.Object,java.lang.Object):boolean";
n1, "com.google.common.base.Optional.fromNullable(java.lang.Object):com.google.common.base.Optional";
(n, []), "com.google.common.base.Optional.orNull():java.lang.Object";
n1, "com.google.common.base.Strings.nullToEmpty(java.lang.String):java.lang.String";
cg, "com.google.common.collect.ImmutableMap.get(java.lang.Object):java.lang.Object"; (* container get *)
o1, "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder";
o1, "com.google.common.collect.ImmutableList$Builder.addAll(java.lang.Iterable):com.google.common.collect.ImmutableList$Builder";
o1, "com.google.common.collect.ImmutableSortedSet$Builder.add(java.lang.Object):com.google.common.collect.ImmutableSortedSet$Builder";
on, "com.google.common.collect.Iterables.getFirst(java.lang.Iterable,java.lang.Object):java.lang.Object";
o1, "com.google.common.util.concurrent.SettableFuture.setException(java.lang.Throwable):boolean";
o1, "java.io.File.<init>(java.lang.String)";
n1, "java.io.PrintStream.print(java.lang.String):void";
o1, "java.lang.Class.isAssignableFrom(java.lang.Class):boolean";
n1, "java.lang.Integer.equals(java.lang.Object):boolean";
n2, "java.lang.RuntimeException.<init>(java.lang.String,java.lang.Throwable)";
n1, "java.lang.String.equals(java.lang.Object):boolean";
n1, "java.lang.StringBuilder.append(java.lang.String):java.lang.StringBuilder";
on, "java.net.URLClassLoader.newInstance(java.net.URL[],java.lang.ClassLoader):java.net.URLClassLoader";
n1, "java.util.AbstractList.equals(java.lang.Object):boolean";
ca, "java.util.ArrayList.add(java.lang.Object):boolean"; (* container add *)
ca, "java.util.List.add(java.lang.Object):boolean"; (* container add *)
cg, "java.util.Map.get(java.lang.Object):java.lang.Object"; (* container get *)
cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object"; (* container put *)
n3, "javax.tools.JavaCompiler.getStandardFileManager(javax.tools.DiagnosticListener,java.util.Locale,java.nio.charset.Charset):javax.tools.StandardJavaFileManager";
(n, [o; n; n]), "org.w3c.dom.Document.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object";
(n, [o; n; n]), "org.w3c.dom.Node.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object";
(* References *)
ng, "java.lang.ref.Reference.get():java.lang.Object";
ng, "java.lang.ref.PhantomReference.get():java.lang.Object";
ng, "java.lang.ref.SoftReference.get():java.lang.Object";
ng, "java.lang.ref.WeakReference.get():java.lang.Object";
ng, "java.util.concurrent.atomic.AtomicReference.get():java.lang.Object";
]
(** Models for @Present annotations *)
let annotated_list_present =
[
(n, [o]), "Optional.of(java.lang.Object):Optional";
(n, [o]), "com.google.common.base.Optional.of(java.lang.Object):com.google.common.base.Optional";
(n, [o]), "Optional.of(java.lang.Object):Optional";
(n, [o]), "com.google.common.base.Optional.of(java.lang.Object):com.google.common.base.Optional";
]
let mk_table list =
@ -304,7 +304,7 @@ let get_annotated_signature callee_pdesc callee_pname =
let mark = Hashtbl.find annotated_table_nullable proc_id in
Annotations.annotated_signature_mark callee_pname Annotations.Nullable ann_sig mark
with Not_found ->
ann_sig
ann_sig
else ann_sig in
let lookup_models_present ann_sig =
if use_models then
@ -312,11 +312,11 @@ let get_annotated_signature callee_pdesc callee_pname =
let mark = Hashtbl.find annotated_table_present proc_id in
Annotations.annotated_signature_mark callee_pname Annotations.Present ann_sig mark
with Not_found ->
ann_sig
ann_sig
else ann_sig in
let lookup_models_strict ann_sig =
if use_models
&& Hashtbl.mem annotated_table_strict proc_id
&& Hashtbl.mem annotated_table_strict proc_id
then
Annotations.annotated_signature_mark_return_strict callee_pname ann_sig
else

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

@ -21,9 +21,9 @@ let type_is_object = function
let java_proc_name_with_class_method pn class_with_path method_name =
(try
Procname.java_get_class pn = class_with_path &&
Procname.java_get_method pn = method_name
with _ -> false)
Procname.java_get_class pn = class_with_path &&
Procname.java_get_method pn = method_name
with _ -> false)
let is_direct_subtype_of this_type super_type_name =
match this_type with
@ -135,12 +135,12 @@ let get_field_type_name
match typ with
| Sil.Tstruct (fields, _, _, _, _, _, _)
| Sil.Tptr (Sil.Tstruct (fields, _, _, _, _, _, _), _) -> (
try
let _, ft, _ = list_find
(function | (fn, _, _) -> Ident.fieldname_equal fn fieldname)
fields in
Some (get_type_name ft)
with Not_found -> None)
try
let _, ft, _ = list_find
(function | (fn, _, _) -> Ident.fieldname_equal fn fieldname)
fields in
Some (get_type_name ft)
with Not_found -> None)
| _ -> None
let java_get_const_type_name
@ -158,9 +158,9 @@ let get_vararg_type_names
let rec initializes_array instrs =
match instrs with
| Sil.Call ([t1], Sil.Const (Sil.Cfun pn), _, _, _)::
Sil.Set (Sil.Lvar iv, _, Sil.Var t2, _):: is ->
Sil.Set (Sil.Lvar iv, _, Sil.Var t2, _):: is ->
(Sil.pvar_equal ivar iv && Ident.equal t1 t2 &&
Procname.equal pn (Procname.from_string_c_fun "__new_array"))
Procname.equal pn (Procname.from_string_c_fun "__new_array"))
|| initializes_array is
| i:: is -> initializes_array is
| _ -> false in
@ -170,24 +170,24 @@ let get_vararg_type_names
let rec nvar_type_name nvar instrs =
match instrs with
| Sil.Letderef (nv, Sil.Lfield (_, id, t), _, _):: _
when Ident.equal nv nvar -> get_field_type_name t id
when Ident.equal nv nvar -> get_field_type_name t id
| Sil.Letderef (nv, e, t, _):: _
when Ident.equal nv nvar ->
when Ident.equal nv nvar ->
Some (get_type_name t)
| i:: is -> nvar_type_name nvar is
| _ -> None in
let rec added_nvar array_nvar instrs =
match instrs with
| Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Var nvar, _):: _
when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node)
when Ident.equal iv array_nvar -> nvar_type_name nvar (Cfg.Node.get_instrs node)
| Sil.Set (Sil.Lindex (Sil.Var iv, _), _, Sil.Const c, _):: _
when Ident.equal iv array_nvar -> Some (java_get_const_type_name c)
when Ident.equal iv array_nvar -> Some (java_get_const_type_name c)
| i:: is -> added_nvar array_nvar is
| _ -> None in
let rec array_nvar instrs =
match instrs with
| Sil.Letderef (nv, Sil.Lvar iv, _, _):: _
when Sil.pvar_equal iv ivar ->
when Sil.pvar_equal iv ivar ->
added_nvar nv instrs
| i:: is -> array_nvar is
| _ -> None in
@ -200,8 +200,8 @@ let get_vararg_type_names
else
match (Cfg.Node.get_preds node) with
| [n] -> (match (added_type_name node) with
| Some name -> name:: type_names n
| None -> type_names n)
| Some name -> name:: type_names n
| None -> type_names n)
| _ -> raise Not_found in
list_rev (type_names call_node)
@ -232,15 +232,15 @@ let get_java_field_access_signature = function
| _ -> None
(** Returns the formal signature (class name, method name,
argument type names and return type name) *)
argument type names and return type name) *)
let get_java_method_call_formal_signature = function
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun pn), (te, tt):: args, loc, cf) ->
(try
let arg_names = list_map (function | e, t -> get_type_name t) args in
let 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)
with _ -> None)
let arg_names = list_map (function | e, t -> get_type_name t) args in
let rt_name = Procname.java_get_return_type pn in
let m_name = Procname.java_get_method pn in
Some (get_type_name tt, m_name, arg_names, rt_name)
with _ -> None)
| _ -> None
@ -256,14 +256,14 @@ let initializer_classes = list_map Mangled.from_string [
"android.app.Application";
"android.app.Fragment";
"android.support.v4.app.Fragment";
]
]
let initializer_methods = [
"onActivityCreated";
"onAttach";
"onCreate";
"onCreateView";
]
]
(** Check if the type has in its supertypes from the initializer_classes list. *)
let type_has_initializer
@ -291,8 +291,8 @@ let java_get_vararg_values node pvar idenv pdesc =
let values = ref [] in
let do_instr = function
| Sil.Set (Sil.Lindex (array_exp, _), _, content_exp, _)
when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv array_exp) ->
(* Each vararg argument is an assigment to a pvar denoting an array of objects. *)
when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv array_exp) ->
(* Each vararg argument is an assigment to a pvar denoting an array of objects. *)
values := content_exp :: !values
| _ -> () in
let do_node n =

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

@ -30,22 +30,22 @@ let printf_signature_to_string
let printf_like_functions =
ref
[
{ unique_id = "java.io.PrintStream.printf(java.lang.String,java.lang.Object[]):java.io.PrintStream";
format_pos = 1;
fixed_pos = [];
vararg_pos = Some 2 };
{ unique_id = "java.io.PrintStream.printf(java.lang.Locale,java.lang.String,java.lang.Object[]):java.io.PrintStream";
format_pos = 2;
fixed_pos = [];
vararg_pos = Some 3 };
{ unique_id = "java.lang.String(java.lang.String,java.lang.Object[]):java.lang.String";
format_pos = 1;
fixed_pos = [];
vararg_pos = Some 2 };
{ unique_id = "java.lang.String(java.lang.Locale,java.lang.String,java.lang.Object[]):java.lang.String";
format_pos = 2;
fixed_pos = [];
vararg_pos = Some 3 };
{ unique_id = "java.io.PrintStream.printf(java.lang.String,java.lang.Object[]):java.io.PrintStream";
format_pos = 1;
fixed_pos = [];
vararg_pos = Some 2 };
{ unique_id = "java.io.PrintStream.printf(java.lang.Locale,java.lang.String,java.lang.Object[]):java.io.PrintStream";
format_pos = 2;
fixed_pos = [];
vararg_pos = Some 3 };
{ unique_id = "java.lang.String(java.lang.String,java.lang.Object[]):java.lang.String";
format_pos = 1;
fixed_pos = [];
vararg_pos = Some 2 };
{ unique_id = "java.lang.String(java.lang.Locale,java.lang.String,java.lang.Object[]):java.lang.String";
format_pos = 2;
fixed_pos = [];
vararg_pos = Some 3 };
]
let add_printf_like_function plf =
@ -169,18 +169,18 @@ let callback_printf_args
let rec array_ivar instrs nvar =
match instrs, nvar with
| Sil.Letderef (id, Sil.Lvar iv, _, _):: _, Sil.Var nid
when Ident.equal id nid -> iv
when Ident.equal id nid -> iv
| i:: is, _ -> array_ivar is nvar
| _ -> 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, _):: _
match instrs with
| Sil.Letderef (id, Sil.Lvar iv, t, _):: _
when Ident.equal id nid -> PatternMatch.get_type_name t
| i:: is -> fixed_nvar_type_name is nvar
| _ -> raise Not_found)
| i:: 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
@ -189,39 +189,39 @@ let callback_printf_args
(instr: Sil.instr): unit =
match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun pn), args, cl, _) -> (
match printf_like_function pn with
| Some printf -> (
try
let fmt, fixed_nvars, array_nvar = format_arguments printf args in
let instrs = Cfg.Node.get_instrs node in
let fixed_nvar_type_names = list_map (fixed_nvar_type_name instrs) fixed_nvars in
let vararg_ivar_type_names = match array_nvar with
| Some nvar -> (
let ivar = array_ivar instrs nvar in
PatternMatch.get_vararg_type_names node ivar)
| None -> [] in
match fmt with
| Some fmt ->
check_type_names
cl
(printf.format_pos + 1)
pn
(format_string_type_names fmt 0)
(fixed_nvar_type_names@ vararg_ivar_type_names)
| None ->
Checkers.ST.report_error
proc_name
proc_desc
printf_args_name
cl
"Format string must be string literal"
with e ->
L.stderr
"%s Exception when analyzing %s: %s@."
printf_args_name
(Procname.to_string proc_name)
(Printexc.to_string e))
| None -> ())
match printf_like_function pn with
| Some printf -> (
try
let fmt, fixed_nvars, array_nvar = format_arguments printf args in
let instrs = Cfg.Node.get_instrs node in
let fixed_nvar_type_names = list_map (fixed_nvar_type_name instrs) fixed_nvars in
let vararg_ivar_type_names = match array_nvar with
| Some nvar -> (
let ivar = array_ivar instrs nvar in
PatternMatch.get_vararg_type_names node ivar)
| None -> [] in
match fmt with
| Some fmt ->
check_type_names
cl
(printf.format_pos + 1)
pn
(format_string_type_names fmt 0)
(fixed_nvar_type_names@ vararg_ivar_type_names)
| None ->
Checkers.ST.report_error
proc_name
proc_desc
printf_args_name
cl
"Format string must be string literal"
with e ->
L.stderr
"%s Exception when analyzing %s: %s@."
printf_args_name
(Procname.to_string proc_name)
(Printexc.to_string e))
| None -> ())
| _ -> () in
Cfg.Procdesc.iter_instrs do_instr proc_desc

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

@ -20,28 +20,28 @@ let active_procedure_checkers () =
let java_checkers =
let l =
[
CallbackChecker.callback_checker_main, false;
Checkers.callback_check_access, false;
Checkers.callback_monitor_nullcheck, false;
Checkers.callback_test_state , false;
Checkers.callback_checkVisibleForTesting, false;
Checkers.callback_check_write_to_parcel, false;
Checkers.callback_find_deserialization, false;
Dataflow.callback_test_dataflow, false;
SqlChecker.callback_sql, false;
Eradicate.callback_eradicate, !Config.eradicate;
CodeQuery.code_query_callback, !CodeQuery.query <> None;
Checkers.callback_check_field_access, false;
ImmutableChecker.callback_check_immutable_cast, checkers_enabled;
RepeatedCallsChecker.callback_check_repeated_calls, checkers_enabled;
PrintfArgs.callback_printf_args, checkers_enabled;
CallbackChecker.callback_checker_main, false;
Checkers.callback_check_access, false;
Checkers.callback_monitor_nullcheck, false;
Checkers.callback_test_state , false;
Checkers.callback_checkVisibleForTesting, false;
Checkers.callback_check_write_to_parcel, false;
Checkers.callback_find_deserialization, false;
Dataflow.callback_test_dataflow, false;
SqlChecker.callback_sql, false;
Eradicate.callback_eradicate, !Config.eradicate;
CodeQuery.code_query_callback, !CodeQuery.query <> None;
Checkers.callback_check_field_access, false;
ImmutableChecker.callback_check_immutable_cast, checkers_enabled;
RepeatedCallsChecker.callback_check_repeated_calls, checkers_enabled;
PrintfArgs.callback_printf_args, checkers_enabled;
] in
list_map (fun (x, y) -> (x, y, Some Sil.Java)) l in
let c_cpp_checkers =
let l =
[
Checkers.callback_print_c_method_calls, false;
CheckDeadCode.callback_check_dead_code, checkers_enabled;
Checkers.callback_print_c_method_calls, false;
CheckDeadCode.callback_check_dead_code, checkers_enabled;
] in
list_map (fun (x, y) -> (x, y, Some Sil.C_CPP)) l in

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

@ -25,7 +25,7 @@ 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) ->
(* ignore return ids and call flags *)
(* ignore return ids and call flags *)
let n = Sil.exp_compare e1 e2 in
if n <> 0 then n else let n = list_compare Sil.exp_typ_compare etl1 etl2 in
if n <> 0 then n else Sil.call_flags_compare cf1 cf2
@ -61,8 +61,8 @@ struct
| SomePath (** Check if some path exists *)
(** Check if the procedure performs an allocation operation.
If [paths] is AllPaths, check if an allocation happens on all paths.
If [paths] is SomePath, check if a path with an allocation exists. *)
If [paths] is AllPaths, check if an allocation happens on all paths.
If [paths] is SomePath, check if a path with an allocation exists. *)
let proc_performs_allocation pdesc paths : Sil.location option =
let node_allocates node : Sil.location option =
@ -113,14 +113,14 @@ struct
let arguments_not_temp args =
let filter_arg (e, t) = match e with
| Sil.Lvar pvar ->
(* same temporary variable does not imply same value *)
(* same temporary variable does not imply same value *)
not (Errdesc.pvar_is_frontend_tmp pvar)
| _ -> true in
list_for_all filter_arg args in
match instr with
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _, loc, call_flags)
when ret_ids <> [] && arguments_not_temp normalized_etl ->
when ret_ids <> [] && arguments_not_temp normalized_etl ->
let instr_normalized_args = Sil.Call (
ret_ids,
Sil.Const (Sil.Cfun callee_pname),

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

@ -23,14 +23,14 @@ let callback_sql all_procs get_proc_desc idenv tenv proc_name proc_desc =
"insert into.*";
"update .* set.*";
"delete .* from.*";
] in
] in
list_map Str.regexp_case_fold _sql_start in
(* Check for SQL string concatenations *)
let do_instr const_map node = function
| Sil.Call (_, Sil.Const (Sil.Cfun pn), (Sil.Var i1, _):: (Sil.Var i2, _):: [], l, _)
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "append" ->
when Procname.java_get_class pn = "java.lang.StringBuilder"
&& Procname.java_get_method pn = "append" ->
let rvar1 = Sil.Var i1 in
let rvar2 = Sil.Var i2 in
begin

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

@ -22,8 +22,8 @@ let debug = Config.from_env_variable "ERADICATE_DEBUG"
(** Module to treat selected complex expressions as constants. *)
module ComplexExpressions = struct
(** What complex expressions are considered constant, each case includes the previous ones.
Boolean checks (e.g. null check) and assignments on expressions considered constant are
retained across the control flow assuming there are no modifications in between. *)
Boolean checks (e.g. null check) and assignments on expressions considered constant are
retained across the control flow assuming there are no modifications in between. *)
type expressions_constant =
| FL_NO (* none *)
| FL_PARAMETER_STATIC (* parameter.field and static fields *)
@ -82,7 +82,7 @@ module ComplexExpressions = struct
dexp_to_string de
| Sil.Dfcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual })
| Sil.Dretcall (fun_dexp, args, loc, { Sil.cf_virtual = isvirtual })
when functions_idempotent () ->
when functions_idempotent () ->
let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in
let pp_args fmt des = (pp_comma_seq) pp_arg fmt des in
let pp fmt () =
@ -140,12 +140,12 @@ let rec typecheck_expr
typestate e tr_default loc : TypeState.range = match e with
| Sil.Lvar pvar ->
(match TypeState.lookup_pvar pvar typestate with
| Some tr -> TypeState.range_add_locs tr [loc]
| None -> tr_default)
| Some tr -> TypeState.range_add_locs tr [loc]
| None -> tr_default)
| Sil.Var id ->
(match TypeState.lookup_id id typestate with
| Some tr -> TypeState.range_add_locs tr [loc]
| None -> tr_default)
| Some tr -> TypeState.range_add_locs tr [loc]
| None -> tr_default)
| Sil.Const (Sil.Cint i) when Sil.Int.iszero i ->
let (typ, _, locs) = tr_default in
if PatternMatch.type_is_class typ
@ -223,8 +223,8 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
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'. *)
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 name_is_temporary name =
let prefix = "$T" in
@ -254,7 +254,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> exp in
(** Convert a complex expressions into a pvar.
When [is_assigment] is true, update the relevant annotations for the pvar. *)
When [is_assigment] is true, update the relevant annotations for the pvar. *)
let convert_complex_exp_to_pvar node' is_assignment _exp typestate loc =
let exp =
handle_field_access_via_temporary
@ -269,21 +269,21 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| Some _ when not is_assignment -> typestate
| _ ->
(match EradicateChecks.get_field_annotation fn typ with
| Some (t, ia) ->
let range =
(
t,
TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (fn, loc)),
[loc]
) in
TypeState.add_pvar pvar range typestate
| None -> typestate) in
| Some (t, ia) ->
let range =
(
t,
TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (fn, loc)),
[loc]
) in
TypeState.add_pvar pvar range typestate
| None -> typestate) in
(* Convert a function call to a pvar. *)
let handle_function_call call_node id =
match Errdesc.find_normal_variable_funcall call_node id with
| Some (Sil.Const (Sil.Cfun pn), _, _, _)
when not (ComplexExpressions.procname_used_in_condition pn) ->
when not (ComplexExpressions.procname_used_in_condition pn) ->
begin
match ComplexExpressions.exp_to_string node' exp with
| None -> default
@ -299,12 +299,12 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
match exp with
| Sil.Var id when
ComplexExpressions.functions_idempotent () &&
Errdesc.find_normal_variable_funcall node' id <> None ->
ComplexExpressions.functions_idempotent () &&
Errdesc.find_normal_variable_funcall node' id <> None ->
handle_function_call node' id
| Sil.Lvar pvar when
ComplexExpressions.functions_idempotent () &&
Errdesc.pvar_is_frontend_tmp pvar ->
ComplexExpressions.functions_idempotent () &&
Errdesc.pvar_is_frontend_tmp pvar ->
let frontend_variable_assignment =
Errdesc.find_program_variable_assignment node pvar in
begin
@ -339,13 +339,13 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
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' ->
(** handle double dereference when accessing a field from an outer class *)
(** handle double dereference when accessing a field from an outer class *)
let fld_name = Ident.fieldname_to_string fn' ^ "_" ^ Ident.fieldname_to_string fn in
let 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.Lvar _ | Sil.Lfield _ when ComplexExpressions.all_nested_fields () ->
(** treat var.field1. ... .fieldn as a constant *)
(** treat var.field1. ... .fieldn as a constant *)
begin
match ComplexExpressions.exp_to_string node' exp with
| Some exp_str ->
@ -395,7 +395,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(* Drop parameters from the signature which we do not check in a call. *)
let drop_unchecked_signature_params pdesc pname annotated_signature =
if Procname.is_constructor pname &&
(Cfg.Procdesc.get_attributes pdesc).Sil.is_synthetic_method then
(Cfg.Procdesc.get_attributes pdesc).Sil.is_synthetic_method then
list_drop_last 1 annotated_signature.Annotations.params
else
annotated_signature.Annotations.params in
@ -417,7 +417,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| None ->
typestate'
| Some (node', id) ->
(* handle the case where pvar is a frontend-generated program variable *)
(* handle the case where pvar is a frontend-generated program variable *)
let exp = Idenv.expand_expr idenv (Sil.Var id) in
begin
match convert_complex_exp_to_pvar node' false exp typestate' loc with
@ -452,7 +452,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(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 ->
(* skip assignment to return variable where it is an artifact of a throw instruction *)
(* skip assignment to return variable where it is an artifact of a throw instruction *)
typestate
| Sil.Set (e1, typ, e2, loc) ->
typecheck_expr_for_errors typestate e1 loc;
@ -481,14 +481,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
check_field_assign ();
typestate2
| Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(_, typ)], loc, _)
when Procname.equal pn SymExec.ModelBuiltins.__new ||
Procname.equal pn SymExec.ModelBuiltins.__new_array ->
when Procname.equal pn SymExec.ModelBuiltins.__new ||
Procname.equal pn SymExec.ModelBuiltins.__new_array ->
TypeState.add_id
id
(typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.New, [loc])
typestate (* new never returns null *)
| Sil.Call ([id], Sil.Const (Sil.Cfun pn), (e, typ):: _, loc, _)
when Procname.equal pn SymExec.ModelBuiltins.__cast ->
when Procname.equal pn SymExec.ModelBuiltins.__cast ->
typecheck_expr_for_errors typestate e loc;
let e', typestate' =
convert_complex_exp_to_pvar node false e typestate loc in
@ -497,7 +497,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
(typecheck_expr_simple typestate' e' typ TypeOrigin.ONone loc)
typestate'
| Sil.Call ([id], Sil.Const (Sil.Cfun pn), [(array_exp, t)], loc, _)
when Procname.equal pn SymExec.ModelBuiltins.__get_array_size ->
when Procname.equal pn SymExec.ModelBuiltins.__get_array_size ->
let (_, ta, _) = typecheck_expr
find_canonical_duplicate
calls_this
@ -531,7 +531,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| Sil.Call (_, Sil.Const (Sil.Cfun pn), _, _, _) when SymExec.function_is_builtin pn ->
typestate (* skip othe builtins *)
| Sil.Call (ret_ids, Sil.Const (Sil.Cfun callee_pname), _etl, loc, cflags)
when get_proc_desc callee_pname <> None ->
when get_proc_desc callee_pname <> None ->
let callee_pdesc = match get_proc_desc callee_pname with
| Some callee_pdesc -> callee_pdesc
| None -> assert false in
@ -589,7 +589,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
find_canonical_duplicate
node
(TypeErr.Condition_redundant
(true, EradicateChecks.explain_expr node cond, false))
(true, EradicateChecks.explain_expr node cond, false))
(Some instr_ref)
loc curr_pname
end;
@ -640,7 +640,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
let do_instr = function
| Sil.Prune (Sil.BinOp (Sil.Eq, _cond_e, Sil.Const (Sil.Cint i)), _, _, _)
| Sil.Prune (Sil.BinOp (Sil.Eq, Sil.Const (Sil.Cint i), _cond_e), _, _, _)
when Sil.Int.iszero i ->
when Sil.Int.iszero i ->
let cond_e = Idenv.expand_expr_temps idenv cond_node _cond_e in
begin
match convert_complex_exp_to_pvar cond_node false cond_e typestate' loc with
@ -657,13 +657,13 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> () in
match call_params with
| ((_, Sil.Lvar pvar), typ):: _ ->
(* temporary variable for the value of the boolean condition *)
(* temporary variable for the value of the boolean condition *)
begin
let curr_node = TypeErr.InstrRef.get_node instr_ref in
let branch = false in
match Errdesc.find_boolean_assignment curr_node pvar branch with
(* In foo(cond1 && cond2), the node that sets the result to false
has all the negated conditions as parents. *)
has all the negated conditions as parents. *)
| Some boolean_assignment_node ->
list_iter handle_negated_condition (Cfg.Node.get_preds boolean_assignment_node);
!res_typestate
@ -675,7 +675,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)
when ComplexExpressions.procname_optional_isPresent pn ->
when ComplexExpressions.procname_optional_isPresent pn ->
handle_optional_isPresent node' e
| _ -> () in
()
@ -740,7 +740,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
typestate2
else
if Procname.java_get_method callee_pname = "checkNotNull"
&& Procname.java_is_vararg callee_pname
&& Procname.java_is_vararg callee_pname
then
let last_parameter = list_length call_params in
do_preconditions_check_not_null
@ -748,7 +748,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
true (* is_vararg *)
typestate2
else if Models.is_check_state callee_pname ||
Models.is_check_argument callee_pname then
Models.is_check_argument callee_pname then
do_preconditions_check_state typestate2
else typestate2
end
@ -765,7 +765,7 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
begin
match Errdesc.find_normal_variable_funcall node' id with
| Some (Sil.Const (Sil.Cfun pn), e1:: _, loc, call_flags) when
filter_callee pn ->
filter_callee pn ->
Some e1
| _ -> None
end
@ -889,14 +889,14 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
| _ -> typestate in
(** Handle assigment fron a temp pvar in a condition.
This recognizes the handling of temp variables in ((x = ...) != null) *)
This recognizes the handling of temp variables in ((x = ...) != null) *)
let handle_assignment_in_condition pvar =
match Cfg.Node.get_preds node with
| [prev_node] ->
let found = ref None in
let do_instr i = match i with
| Sil.Set (e, _, e', _)
when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv e') ->
when Sil.exp_equal (Sil.Lvar pvar) (Idenv.expand_expr idenv e') ->
found := Some e
| _ -> () in
list_iter do_instr (Cfg.Node.get_instrs prev_node);
@ -918,11 +918,11 @@ let typecheck_instr ext calls_this checks (node: Cfg.Node.t) idenv get_proc_desc
else _node, c'
| Sil.Lvar pvar when Errdesc.pvar_is_frontend_tmp pvar ->
(match handle_assignment_in_condition pvar with
| None ->
(match Errdesc.find_program_variable_assignment _node pvar with
| Some (node', id) -> node', Sil.Var id
| None -> _node, _cond)
| Some e2 -> _node, e2)
| None ->
(match Errdesc.find_program_variable_assignment _node pvar with
| Some (node', id) -> node', Sil.Var id
| None -> _node, _cond)
| Some e2 -> _node, e2)
| c -> _node, c in
let node', ncond = normalize_cond node cond in
@ -943,7 +943,7 @@ let typecheck_node
let typestates_exn = ref [] in
let handle_exceptions typestate instr = match instr with
| Sil.Call (_, Sil.Const (Sil.Cfun callee_pname), _, _, _) ->
(* check if the call might throw an exception *)
(* check if the call might throw an exception *)
let exceptions =
match get_proc_desc callee_pname with
| Some callee_pdesc ->
@ -952,9 +952,9 @@ let typecheck_node
if exceptions <> [] then
typestates_exn := typestate :: !typestates_exn
| Sil.Set (Sil.Lvar pv, _, _, _) when
Sil.pvar_is_return pv &&
Cfg.Node.get_kind node = Cfg.Node.throw_kind ->
(* throw instruction *)
Sil.pvar_is_return pv &&
Cfg.Node.get_kind node = Cfg.Node.throw_kind ->
(* throw instruction *)
typestates_exn := typestate :: !typestates_exn
| _ -> () in

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

@ -70,7 +70,7 @@ type err_instance =
| Field_over_annotated of Ident.fieldname * Procname.t
| Null_field_access of string option * Ident.fieldname * origin_descr * bool
| Call_receiver_annotation_inconsistent
of Annotations.annotation * string option * Procname.t * origin_descr
of Annotations.annotation * string option * Procname.t * origin_descr
| Parameter_annotation_inconsistent of parameter_not_nullable
| Return_annotation_inconsistent of Annotations.annotation * Procname.t * origin_descr
| Return_over_annotated of Procname.t
@ -110,14 +110,14 @@ module H = Hashtbl.Make(struct
| 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 (ann2, so2, pn2, od2) ->
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 (ann2, s2, n2, pn2, cl2, od2) ->
ann1 = ann2 &&
string_equal s1 s2 &&
int_equal n1 n2 &&
@ -126,18 +126,18 @@ module H = Hashtbl.Make(struct
| Parameter_annotation_inconsistent _, _
| _, Parameter_annotation_inconsistent _ -> false
| Return_annotation_inconsistent (ann1, pn1, od1),
Return_annotation_inconsistent (ann2, pn2, od2) ->
Return_annotation_inconsistent (ann2, pn2, od2) ->
ann1 = ann2 && Procname.equal pn1 pn2
| Return_annotation_inconsistent _, _
| _, Return_annotation_inconsistent _ -> false
| Return_over_annotated pn1, Return_over_annotated pn2 ->
Procname.equal pn1 pn2
| Inconsistent_subclass_return_annotation (pn1, spn1),
Inconsistent_subclass_return_annotation (pn2, spn2) ->
Inconsistent_subclass_return_annotation (pn2, spn2) ->
if Procname.equal pn1 pn2 then true
else Procname.equal spn1 spn2
| Inconsistent_subclass_parameter_annotation (param_name_1, pos_1, pn_1, overriden_pn_1),
Inconsistent_subclass_parameter_annotation (param_name_2, pos_2, pn_2, overriden_pn_2) ->
Inconsistent_subclass_parameter_annotation (param_name_2, pos_2, pn_2, overriden_pn_2) ->
string_equal param_name_1 param_name_2 &&
int_equal pos_1 pos_2 &&
Procname.equal pn_1 pn_2 &&
@ -201,8 +201,8 @@ let err_tbl : err_state H.t =
let reset () = H.reset err_tbl
(** Get the forall status of an err_instance.
The forall status indicates that the error should be printed only if it
occurs on every path. *)
The forall status indicates that the error should be printed only if it
occurs on every path. *)
let get_forall = function
| Condition_redundant _ -> true
| Field_not_initialized _ -> false
@ -219,7 +219,7 @@ let get_forall = function
(** Reset the always field of the forall erros in the node, so if they are not set again
we know that they don't fire on every path. *)
we know that they don't fire on every path. *)
let node_reset_forall node =
let iter (err_instance, instr_ref_opt) err_state =
match instr_ref_opt, get_forall err_instance with
@ -255,10 +255,10 @@ module Strict = struct
let this_type_get_strict signature =
match signature.Annotations.params with
| ("this", _, this_type):: _ -> begin
match PatternMatch.type_get_annotation this_type with
| Some ia -> Annotations.ia_get_strict ia
| None -> None
end
match PatternMatch.type_get_annotation this_type with
| Some ia -> Annotations.ia_get_strict ia
| None -> None
end
| _ -> None
let signature_get_strict signature =
@ -283,7 +283,7 @@ module Strict = struct
| Null_field_access (_, _, origin_descr, _) ->
origin_descr_get_strict origin_descr
| Parameter_annotation_inconsistent (Annotations.Nullable, _, _, _, _, origin_descr)
when report_on_method_arguments ->
when report_on_method_arguments ->
origin_descr_get_strict origin_descr
| _ -> None
end (* Strict *)
@ -434,12 +434,12 @@ let report_error_now
s
origin_desc
| Annotations.Present -> "ERADICATE_PARAMETER_VALUE_ABSENT",
P.sprintf
"`%s` needs a present value in parameter %d but argument `%s` can be absent. %s"
(Procname.to_simplified_string pn)
n
s
origin_desc in
P.sprintf
"`%s` needs a present value in parameter %d but argument `%s` can be absent. %s"
(Procname.to_simplified_string pn)
n
s
origin_desc in
true,
kind_s,
description,
@ -518,7 +518,7 @@ let report_error_now
(** Report an error unless is has been reported already, or unless it's a forall error
since it requires waiting until the end of the analysis and be printed by flush. *)
since it requires waiting until the end of the analysis and be printed by flush. *)
let report_error st_report_error find_canonical_duplicate node
err_instance instr_ref_opt loc proc_name =
let should_report_now =

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

@ -83,8 +83,8 @@ let get_description origin =
| Some ann ->
let str = "@Strict" in
(match ann.Sil.parameters with
| par1 :: _ -> Printf.sprintf "%s(%s) " str par1
| [] -> Printf.sprintf "%s " str)
| par1 :: _ -> Printf.sprintf "%s(%s) " str par1
| [] -> Printf.sprintf "%s " str)
| None -> "" in
let description = Printf.sprintf
"call to %s%s %s"

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

@ -24,8 +24,8 @@ 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 -> Cfg.Node.t
-> 'a -> Sil.instr -> parameters -> 'a;
join : 'a -> 'a -> 'a; (** join two extensions *)
pp : Format.formatter -> 'a -> unit (** pretty print an extension *)
}
@ -99,23 +99,23 @@ let map_join m1 m2 =
try
let range1 = M.find exp2 m1 in
(match range_join range1 range2 with
| None -> ()
| Some range' -> tjoined := M.add exp2 range' !tjoined)
| None -> ()
| Some range' -> tjoined := M.add exp2 range' !tjoined)
with Not_found ->
let (t2, ta2, locs2) = range2 in
let range2' =
let ta2' = TypeAnnotation.with_origin ta2 TypeOrigin.Undef in
(t2, ta2', locs2) in
tjoined := M.add exp2 range2' !tjoined in
let (t2, ta2, locs2) = range2 in
let range2' =
let ta2' = TypeAnnotation.with_origin ta2 TypeOrigin.Undef in
(t2, ta2', locs2) in
tjoined := M.add exp2 range2' !tjoined in
let missing_rhs exp1 range1 = (* handle elements missing in the rhs *)
try
ignore (M.find exp1 m2)
with Not_found ->
let (t1, ta1, locs1) = range1 in
let range1' =
let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in
(t1, ta1', locs1) in
tjoined := M.add exp1 range1' !tjoined in
let (t1, ta1, locs1) = range1 in
let range1' =
let ta1' = TypeAnnotation.with_origin ta1 TypeOrigin.Undef in
(t1, ta1', locs1) in
tjoined := M.add exp1 range1' !tjoined in
if m1 == m2 then m1
else
try

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

@ -373,7 +373,7 @@ let translate_dispatch_function block_name stmt_info stmt_list ei n =
let cast_info = { cei_cast_kind = `BitCast; cei_base_path =[]} in
let block_def = ImplicitCastExpr(stmt_info,[block_expr], bei, cast_info) in
let decl_info = { empty_decl_info
with di_pointer = stmt_info.si_pointer; di_source_range = stmt_info.si_source_range } in
with di_pointer = stmt_info.si_pointer; di_source_range = stmt_info.si_source_range } in
let var_decl_info = { empty_var_decl with vdi_init_expr = Some block_def } in
let block_var_decl = VarDecl(decl_info, block_name_info, ei.ei_qual_type, var_decl_info) in
let decl_stmt = DeclStmt(stmt_info,[], [block_var_decl]) in
@ -495,8 +495,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
| ParmVarDecl(di, name, qt, _) ->
let qt_fun = create_void_unsigned_long_type () in
let parameter = UnaryExprOrTypeTraitExpr((fresh_stmt_info stmt_info), [],
make_expr_info (create_unsigned_long_type ()),
{ Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in
make_expr_info (create_unsigned_long_type ()),
{ Clang_ast_t.uttei_kind = `SizeOf; Clang_ast_t.uttei_qual_type = Some (create_BOOL_type ()) }) in
let malloc = create_call (fresh_stmt_info stmt_info) di.di_pointer CFrontend_config.malloc qt_fun [parameter] in
let init_exp = create_implicit_cast_expr (fresh_stmt_info stmt_info) [malloc] qt `BitCast in
make_DeclStmt (fresh_stmt_info stmt_info) di qt name (Some init_exp)
@ -551,8 +551,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let ei_idx = get_ei_from_cast decl_ref_expr_idx in
let ove_idx = build_OpaqueValueExpr (fresh_stmt_info stmt_info) decl_ref_expr_idx ei_idx in
let objc_sre = ObjCSubscriptRefExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx],
make_expr_info (pseudo_object_qt ()),
{ osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in
make_expr_info (pseudo_object_qt ()),
{ osrei_kind =`ArraySubscript; osrei_getter = None; osrei_setter = None; }) in
let obj_c_message_expr_info = { omei_selector = CFrontend_config.object_at_indexed_subscript_m; omei_receiver_kind =`Instance } in
let ome = ObjCMessageExpr((fresh_stmt_info stmt_info), [ove_array; ove_idx], poe_ei, obj_c_message_expr_info) in
let pseudo_obj_expr = PseudoObjectExpr((fresh_stmt_info stmt_info), [objc_sre; ove_array; ove_idx; ome], poe_ei) in
@ -625,8 +625,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let if_stop = build_if_stop stop_cast in
let free_stop = free_stop pstop in
[ objects_decl; block_decl; decl_stop; assign_stop;
ForStmt(stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr;
CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op
ForStmt(stmt_info, [idx_decl_stmt; dummy_stmt (); guard; incr;
CompoundStmt(stmt_info, [obj_assignment; call_block; if_stop])]); free_stop], op
| _ -> assert false in
match stmt_list with
@ -636,8 +636,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei =
let translated_stmt, op = translate bdi.Clang_ast_t.bdi_parameters s block_decl bei.Clang_ast_t.ei_qual_type in
CompoundStmt(stmt_info, translated_stmt), vars_to_register@op@bv
| _ -> (* When it is not the method we expect with only one parameter, we don't translate *)
Printing.log_out "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info);
CompoundStmt(stmt_info, stmt_list), []
Printing.log_out "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info);
CompoundStmt(stmt_info, stmt_list), []
(* We translate the logical negation of an integer with a conditional*)
(* !x <=> x?0:1 *)

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

@ -28,24 +28,24 @@ let assignment_arc_mode context e1 typ e2 loc rhs_owning_method is_e1_decl =
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 ->
(* for __strong e1 = e2 the semantics is*)
(* retain(e2); tmp=e1; e1=e2; release(tmp); *)
(* for __strong e1 = e2 the semantics is*)
(* retain(e2); tmp=e1; e1=e2; release(tmp); *)
let retain = mk_call retain_pname e2 typ in
let id = Ident.create_fresh Ident.knormal in
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 ->
(* for A __strong *e1 = e2 the semantics is*)
(* retain(e2); e1=e2; *)
(* 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) ->
(e1, [assign],[])
| Sil.Tptr (t, Sil.Pk_objc_autoreleasing) ->
(* for __autoreleasing e1 = e2 the semantics is*)
(* retain(e2); autorelease(e2); e1=e2; *)
(* for __autoreleasing e1 = e2 the semantics is*)
(* retain(e2); autorelease(e2); e1=e2; *)
let retain = mk_call retain_pname e2 typ in
let autorelease = mk_call autorelease_pname e2 typ in
(e1, [retain; autorelease; assign], [])
@ -167,7 +167,7 @@ let unary_operation_instruction uoi e typ loc =
| `Plus -> ([], e, [])
| `LNot -> ([], un_exp (Sil.LNot), [])
| `Deref ->
(* Actual dereferencing is handled by implicit cast from rvalue to lvalue *)
(* Actual dereferencing is handled by implicit cast from rvalue to lvalue *)
([], e, [])
| `AddrOf -> ([], e, [])
| `Real | `Imag | `Extension ->

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

@ -8,8 +8,8 @@
*)
(** Module to preprocess location information in the AST.
The original location information is incremental, each location is a delta
w.r.t. the previous one. This module processes the AST and makes locations explicit. *)
The original location information is incremental, each location is a delta
w.r.t. the previous one. This module processes the AST and makes locations explicit. *)
open Utils
open Clang_ast_j
@ -140,7 +140,7 @@ let pp_ast_decl fmt ast_decl =
(** Compose incremental location information and make locations explicit. *)
module LocComposer : sig
(** Status of the composer. *)
(** Status of the composer. *)
type status
(** Create a new composer with the initial status. *)
@ -150,9 +150,9 @@ module LocComposer : sig
val compose : status -> source_range -> source_range
(** Set the current file if specified in the source_range.
The composer will not descend into file included from the current one.
For locations in included files, it will return instead the last known
location of the current file. *)
The composer will not descend into file included from the current one.
For locations in included files, it will return instead the last known
location of the current file. *)
val set_current_file : status -> source_range -> unit
end = struct
type status =
@ -271,9 +271,9 @@ and decl_process_locs loc_composer decl =
(** Process locations in the AST by making them explicit.
Each toplevel declaration determines the current file,
and once diving into the details of the declaration, location
information about other (include) files is ignored. *)
Each toplevel declaration determines the current file,
and once diving into the details of the declaration, location
information about other (include) files is ignored. *)
let ast_decl_process_locs loc_composer ast_decl =
let toplevel_decl_process_locs decl =

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

@ -103,9 +103,9 @@ struct
let print_stack var_name stack =
Stack.iter
(fun (var_name, typ, level) ->
Printing.log_out "var item %s:" (Mangled.to_string var_name);
Printing.log_out "%s" (Sil.typ_to_string typ);
Printing.log_out "- %s @." (string_of_int level)) stack in
Printing.log_out "var item %s:" (Mangled.to_string var_name);
Printing.log_out "%s" (Sil.typ_to_string typ);
Printing.log_out "- %s @." (string_of_int level)) stack in
Printing.log_out "LOCAL VARS:@\n";
StringMap.iter print_stack context.local_vars_stack
@ -125,9 +125,9 @@ struct
try
StringMap.find pointer context.local_vars_pointer
with Not_found ->
(Printing.log_err " ...Variable for pointer %s not found!!\n%!" pointer);
print_pointer_vars context;
assert false
(Printing.log_err " ...Variable for pointer %s not found!!\n%!" pointer);
print_pointer_vars context;
assert false
let lookup_var_locals context procname var_name =
let stack = lookup_var_map context var_name in
@ -141,37 +141,37 @@ struct
try
Some (fst (lookup_var_locals context procname var_name))
with Stack.Empty ->
try
Some (fst (lookup_var_globals context procname var_name))
with Not_found ->
if is_captured_var context var_name then
try (* if it's a captured variable we need to look at the parameters list*)
Some (fst (lookup_var_formals context procname var_name))
with Not_found ->
Printing.log_err "Variable %s not found!!\n%!" var_name;
print_locals context;
None
else None
try
Some (fst (lookup_var_globals context procname var_name))
with Not_found ->
if is_captured_var context var_name then
try (* if it's a captured variable we need to look at the parameters list*)
Some (fst (lookup_var_formals context procname var_name))
with Not_found ->
Printing.log_err "Variable %s not found!!\n%!" var_name;
print_locals context;
None
else None
else if (kind = `ParmVar) then
try
Some (fst (lookup_var_formals context procname var_name))
with Not_found ->
let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in
Printing.log_err "Warning: Parameter %s not found!!\n%!" var_name;
Printing.log_err "Formals of procdesc %s" (Procname.to_string procname);
Printing.log_err " are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc));
Printing.print_failure_info pointer;
assert false
let list_to_string = list_to_string (fun (a, typ) -> a^":"^(Sil.typ_to_string typ)) in
Printing.log_err "Warning: Parameter %s not found!!\n%!" var_name;
Printing.log_err "Formals of procdesc %s" (Procname.to_string procname);
Printing.log_err " are %s\n%!" (list_to_string (Cfg.Procdesc.get_formals context.procdesc));
Printing.print_failure_info pointer;
assert false
else if (kind = `Function || kind = `ImplicitParam) then (
(* ImplicitParam are 'self' and '_cmd'. These are never defined but they can be referred to in the code. *)
Printing.log_err "Creating a variable for '%s' \n%!" var_name;
Some (Sil.mk_pvar (Mangled.from_string var_name) procname))
else if (kind = `EnumConstant) then
(Printing.print_failure_info pointer;
assert false)
assert false)
else (Printing.log_err "WARNING: In lookup_var kind %s not handled. Giving up!\n%!" (Clang_ast_j.string_of_decl_kind kind);
Printing.print_failure_info pointer;
assert false)
Printing.print_failure_info pointer;
assert false)
let get_variable_name name =
Mangled.mangled name ((string_of_int(Block.depth ())))
@ -201,8 +201,8 @@ struct
let (top_var, top_typ, top_level) = Stack.top stack in
if top_level == (Block.depth ()) then
(ignore (Stack.pop stack);
context.local_vars_stack <-
StringMap.add var_name stack context.local_vars_stack)
context.local_vars_stack <-
StringMap.add var_name stack context.local_vars_stack)
else ()
with Stack.Empty -> () in
StringMap.iter remove_top context.local_vars_stack
@ -256,7 +256,7 @@ let curr_class_to_string curr_class =
match curr_class with
| ContextCls (name, superclass, protocols) ->
("class " ^ name ^ ", superclass: " ^ (Option.default "" superclass) ^
", protocols: " ^ (Utils.list_to_string (fun x -> x) protocols))
", protocols: " ^ (Utils.list_to_string (fun x -> x) protocols))
| ContextCategory (name, cls) -> ("category " ^ name ^ " of class " ^ cls)
| ContextProtocol name -> ("protocol " ^ name)
| ContextNoCls -> "no class"
@ -297,8 +297,8 @@ let create_curr_class tenv class_name =
match Sil.tenv_lookup tenv class_tn_name with
| Some Sil.Tstruct(intf_fields, _, _, _, superclasses, methods, annotation) ->
(let superclasses_names = list_map (fun (_, name) -> Mangled.to_string name) superclasses in
match superclasses_names with
| superclass:: protocols ->
ContextCls (class_name, Some superclass, protocols)
| [] -> ContextCls (class_name, None, []))
match superclasses_names with
| superclass:: protocols ->
ContextCls (class_name, Some superclass, protocols)
| [] -> ContextCls (class_name, None, []))
| _ -> assert false

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

@ -30,16 +30,16 @@ let create_empty_procdesc () =
Sil.is_generated = false;
} in
create {
cfg = Cfg.Node.create_cfg ();
name = procname;
is_defined = false;
ret_type = Sil.Tvoid;
formals = [];
locals = [];
captured = [];
loc = Sil.loc_none;
proc_attributes = proc_attributes;
}
cfg = Cfg.Node.create_cfg ();
name = procname;
is_defined = false;
ret_type = Sil.Tvoid;
formals = [];
locals = [];
captured = [];
loc = Sil.loc_none;
proc_attributes = proc_attributes;
}
(* We will use global_procdesc for storing global variables. *)
(* Globals will be stored as locals in global_procdesc and they are added*)
@ -52,19 +52,19 @@ let rec get_enum_constants context decl_list v =
| EnumConstantDecl(decl_info, name_info, qual_type, enum_constant_decl_info) :: decl_list' ->
let name = name_info.Clang_ast_t.ni_name in
(match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with
| None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v));
(Mangled.from_string name, Sil.Cint (Sil.Int.of_int v))
:: get_enum_constants context decl_list' (v + 1)
| Some stmt ->
let e = CGen_trans.CTransImpl.expression_trans context stmt
"WARNING: Expression in Enumeration constant not found\n" in
let const = (match Prop.exp_normalize_prop Prop.prop_emp e with
| Sil.Const c -> c
| _ -> (* This is a hack to avoid failing in some strange definition of Enum *)
Sil.Cint Sil.Int.zero) in
Printing.log_out " ...Defining Enum Constant ('%s', " name;
Printing.log_out "'%s')\n" (Sil.exp_to_string (Sil.Const const));
(Mangled.from_string name, const) :: get_enum_constants context decl_list' v)
| None -> Printing.log_out "%s" (" ...Defining Enum Constant ("^name^", "^(string_of_int v));
(Mangled.from_string name, Sil.Cint (Sil.Int.of_int v))
:: get_enum_constants context decl_list' (v + 1)
| Some stmt ->
let e = CGen_trans.CTransImpl.expression_trans context stmt
"WARNING: Expression in Enumeration constant not found\n" in
let const = (match Prop.exp_normalize_prop Prop.prop_emp e with
| Sil.Const c -> c
| _ -> (* This is a hack to avoid failing in some strange definition of Enum *)
Sil.Cint Sil.Int.zero) in
Printing.log_out " ...Defining Enum Constant ('%s', " name;
Printing.log_out "'%s')\n" (Sil.exp_to_string (Sil.Const const));
(Mangled.from_string name, const) :: get_enum_constants context decl_list' v)
| _ -> assert false
let enum_decl name tenv cfg cg namespace decl_list opt_type =

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

@ -32,8 +32,8 @@ let fields_superclass tenv interface_decl_info =
match interface_decl_info.Clang_ast_t.otdi_super with
| Some dr ->
(match dr.Clang_ast_t.dr_name with
| Some sc -> get_fields_super_classes tenv (CTypes.mk_classname sc.Clang_ast_t.ni_name)
| _ -> [])
| Some sc -> get_fields_super_classes tenv (CTypes.mk_classname sc.Clang_ast_t.ni_name)
| _ -> [])
| _ -> []
let get_field_www name_field fl =
@ -70,12 +70,12 @@ let ivar_property curr_class ivar =
match ObjcProperty_decl.Property.find_property_name_from_ivar curr_class ivar with
| Some pname' ->
(Printing.log_out "Found property name from ivar: '%s'" pname';
try
let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in
atts
with Not_found ->
Printing.log_out "Didn't find property for pname '%s'" pname';
[])
try
let _, atts, _, _, _, _ = ObjcProperty_decl.Property.find_property curr_class pname' in
atts
with Not_found ->
Printing.log_out "Didn't find property for pname '%s'" pname';
[])
| None -> Printing.log_out "No property found for ivar '%s'@." ivar;
[]
@ -102,7 +102,7 @@ let rec get_fields tenv curr_class decl_list =
Printing.log_out " ...Resulting sil field: (%s) with attributes:@." ((Ident.fieldname_to_string fname) ^":"^(Sil.typ_to_string typ));
list_iter (fun (ia', _) ->
list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia;
list_iter (fun a -> Printing.log_out " '%s'@." a) ia'.Sil.parameters) ia;
(fname, typ, ia):: fields
| ObjCPropertyImplDecl(decl_info, property_impl_decl_info):: decl_list' ->

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

@ -76,7 +76,7 @@ let rec translate_one_declaration tenv cg cfg namespace dec =
CMethod_declImpl.process_methods tenv cg cfg curr_class namespace decl_list
| EnumDecl(decl_info, name_info, opt_type, decl_list, decl_context_info, enum_decl_info)
when should_translate_enum ->
when should_translate_enum ->
let name = name_info.Clang_ast_t.ni_name in
CEnum_decl.enum_decl name tenv cfg cg namespace decl_list opt_type
@ -155,5 +155,5 @@ let do_source_file source_file ast =
if !CFrontend_config.stats_mode then Cfg.check_cfg_connectedness cfg;
if !CFrontend_config.stats_mode || !CFrontend_config.debug_mode || !CFrontend_config.testing_mode then
(Dotty.print_icfg_dotty cfg [];
Cg.save_call_graph_dotty None Specs.get_specs call_graph)
Cg.save_call_graph_dotty None Specs.get_specs call_graph)

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

@ -34,59 +34,59 @@ struct
let print_tenv tenv =
Sil.tenv_iter (fun typname typ ->
match typname with
| Sil.TN_csu (Sil.Class, _) | Sil.TN_csu (Sil.Protocol, _) ->
(match typ with (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline (
(Sil.typename_to_string typname)^"\n"^
"---> superclass and protocols "^(list_to_string (fun (csu, x) ->
let nsu = Sil.TN_csu (csu, x) in
"\t"^(Sil.typename_to_string nsu)^"\n") super_classes)^
"---> methods "^(list_to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^
"\t---> static fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") static_fields)^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") fields
)
)
)
| _ -> ())
| _ -> ()
match typname with
| Sil.TN_csu (Sil.Class, _) | Sil.TN_csu (Sil.Protocol, _) ->
(match typ with (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline (
(Sil.typename_to_string typname)^"\n"^
"---> superclass and protocols "^(list_to_string (fun (csu, x) ->
let nsu = Sil.TN_csu (csu, x) in
"\t"^(Sil.typename_to_string nsu)^"\n") super_classes)^
"---> methods "^(list_to_string (fun x ->"\t"^(Procname.to_string x)^"\n") methods)^" "^
"\t---> static fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") static_fields)^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
"\t "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") fields
)
)
)
| _ -> ())
| _ -> ()
) tenv
let print_tenv_struct_unions tenv =
Sil.tenv_iter (fun typname typ ->
match typname with
| Sil.TN_csu (Sil.Struct, _) | Sil.TN_csu (Sil.Union, _) ->
(match typ with
| (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline (
(Sil.typename_to_string typname)^"\n"^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
match typ with
| Sil.Tvar tname -> "tvar"^(Sil.typename_to_string tname)
| Sil.Tstruct (_, _, _, _, _, _, _) | _ ->
"\t struct "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") fields
)
)
)
| _ -> ())
| Sil.TN_typedef typname ->
print_endline ((Mangled.to_string typname)^"-->"^(Sil.typ_to_string typ))
| _ -> ()
match typname with
| Sil.TN_csu (Sil.Struct, _) | Sil.TN_csu (Sil.Union, _) ->
(match typ with
| (Sil.Tstruct (fields, static_fields, _, cls, super_classes, methods, iann)) ->
(print_endline (
(Sil.typename_to_string typname)^"\n"^
"\t---> fields "^(list_to_string (fun (fieldname, typ, _) ->
match typ with
| Sil.Tvar tname -> "tvar"^(Sil.typename_to_string tname)
| Sil.Tstruct (_, _, _, _, _, _, _) | _ ->
"\t struct "^(Ident.fieldname_to_string fieldname)^" "^
(Sil.typ_to_string typ)^"\n") fields
)
)
)
| _ -> ())
| Sil.TN_typedef typname ->
print_endline ((Mangled.to_string typname)^"-->"^(Sil.typ_to_string typ))
| _ -> ()
) tenv
let print_procedures cfg =
let procs = Cfg.get_all_procs cfg in
print_endline
(list_to_string (fun pdesc ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
"name> "^
(Procname.to_string pname) ^
" defined? " ^ (string_of_bool (Cfg.Procdesc.is_defined pdesc)) ^ "\n")
let pname = Cfg.Procdesc.get_proc_name pdesc in
"name> "^
(Procname.to_string pname) ^
" defined? " ^ (string_of_bool (Cfg.Procdesc.is_defined pdesc)) ^ "\n")
procs)
let print_failure_info pointer =
@ -133,8 +133,8 @@ struct
match stmt with
| OpaqueValueExpr(_, lstmt, _, opaque_value_expr_info) ->
(match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with
| Some stmt -> lstmt@[stmt]
| _ -> lstmt)
| Some stmt -> lstmt@[stmt]
| _ -> 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) ->
@ -152,8 +152,8 @@ struct
match property_impl_decl_info.Clang_ast_t.opidi_property_decl with
| Some decl_ref ->
(match decl_ref.Clang_ast_t.dr_name with
| Some n -> n.Clang_ast_t.ni_name
| _ -> no_property_name)
| Some n -> n.Clang_ast_t.ni_name
| _ -> no_property_name)
| None -> no_property_name
let generated_ivar_name property_name =

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

@ -54,4 +54,4 @@ let print_map () =
(Sil.pp_typ_full Utils.pe_text) value._type in
if !CFrontend_config.debug_mode then
(L.out "GLOBAL VARS:@.";
MangledMap.iter print_item !varMap)
MangledMap.iter print_item !varMap)

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

@ -26,15 +26,15 @@ let init_curr_source_file source_file =
let source_file_from_path path =
if Filename.is_relative path then
(Logging.out
"ERROR: Path %s is relative. Please pass an absolute path in the -c argument.@."
path;
exit 1);
"ERROR: Path %s is relative. Please pass an absolute path in the -c argument.@."
path;
exit 1);
match !Config.project_root with
| Some root ->
(try
DB.rel_source_file_from_abs_path root path
with DB.Path_not_prefix_root ->
DB.source_file_from_string path)
DB.rel_source_file_from_abs_path root path
with DB.Path_not_prefix_root ->
DB.source_file_from_string path)
| None -> DB.source_file_from_string path
let choose_sloc sloc1 sloc2 prefer_first =
@ -57,10 +57,10 @@ let choose_sloc_to_update_curr_file sloc1 sloc2 =
let update_curr_file di =
match di.Clang_ast_t.di_source_range with (loc_start, loc_end) ->
let loc = choose_sloc_to_update_curr_file loc_start loc_end in
(match loc.Clang_ast_t.sl_file with
| Some f -> curr_file := source_file_from_path f
| None -> ())
let loc = choose_sloc_to_update_curr_file loc_start loc_end in
(match loc.Clang_ast_t.sl_file with
| Some f -> curr_file := source_file_from_path f
| None -> ())
let clang_to_sil_location clang_loc parent_line_number procdesc_opt =
let line = match clang_loc.Clang_ast_t.sl_line with
@ -91,42 +91,42 @@ let clang_to_sil_location clang_loc parent_line_number procdesc_opt =
let should_translate_lib source_range =
if !CFrontend_config.no_translate_libs then
match source_range with (loc_start, loc_end) ->
let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in
let loc = clang_to_sil_location loc_start (-1) None in
DB.source_file_equal loc.Sil.file !DB.current_source
let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in
let loc = clang_to_sil_location loc_start (-1) None in
DB.source_file_equal loc.Sil.file !DB.current_source
else true
let should_translate_enum source_range =
if !CFrontend_config.testing_mode then
match source_range with (loc_start, loc_end) ->
let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in
let loc = clang_to_sil_location loc_start (-1) None in
DB.source_file_equal loc.Sil.file !DB.current_source
let loc_start = choose_sloc_to_update_curr_file loc_start loc_end in
let loc = clang_to_sil_location loc_start (-1) None in
DB.source_file_equal loc.Sil.file !DB.current_source
else true
let get_sil_location_from_range source_range prefer_first =
match source_range with (sloc1, sloc2) ->
let sloc = choose_sloc sloc1 sloc2 prefer_first in
clang_to_sil_location sloc (-1) None
let sloc = choose_sloc sloc1 sloc2 prefer_first in
clang_to_sil_location sloc (-1) None
let get_sil_location stmt_info parent_line_number context =
match stmt_info.Clang_ast_t.si_source_range with (sloc1, sloc2) ->
let sloc = choose_sloc sloc1 sloc2 true in
clang_to_sil_location sloc parent_line_number (Some (CContext.get_procdesc context))
let sloc = choose_sloc sloc1 sloc2 true in
clang_to_sil_location sloc parent_line_number (Some (CContext.get_procdesc context))
let get_line stmt_info line_number =
match stmt_info.Clang_ast_t.si_source_range with
| (sloc1, sloc2) ->
let sloc = choose_sloc sloc1 sloc2 true in
(match sloc.Clang_ast_t.sl_line with
| Some l -> l
| None -> line_number)
| Some l -> l
| None -> line_number)
let check_source_file source_file =
let extensions_allowed = [".m"; ".mm"; ".c"; ".cc"; ".cpp"; ".h"] in
let allowed = list_exists (fun ext -> Filename.check_suffix source_file ext) extensions_allowed in
if not allowed then
(Printing.log_stats "%s"
("\nThe source file "^source_file^
" should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n");
assert false)
("\nThe source file "^source_file^
" should end with "^(Utils.list_to_string (fun x -> x) extensions_allowed)^"\n\n");
assert false)

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

@ -8,8 +8,8 @@
*)
(* Take as input an ast file and a C or ObjectiveC file such that the ast file
corresponds to the compilation of the C file with clang.
Parse the ast file into a data structure and translates it into a cfg. *)
corresponds to the compilation of the C file with clang.
Parse the ast file into a data structure and translates it into a cfg. *)
module L = Logging
@ -26,55 +26,55 @@ let arg_desc =
let desc =
(filter Utils.base_arg_desc) @
[
"-c",
Arg.String (fun cfile -> source_file := Some cfile),
Some "cfile",
"C File to translate";
"-x",
Arg.String (fun lang -> CFrontend_config.lang_from_string lang),
Some "cfile",
"Language (c, objective-c, c++, objc-++)";
"-ast",
Arg.String (fun file -> ast_file := Some file),
Some "file",
"AST file for the translation";
"-dotty_cfg_libs",
Arg.Unit (fun _ -> Config.dotty_cfg_libs := true),
None,
"Prints the cfg of the code coming from the libraries";
"-no_headers",
Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := true),
None,
"Do not translate code in header files (default)";
"-headers",
Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := false),
None,
"Translate code in header files";
"-testing_mode",
Arg.Unit (fun _ -> CFrontend_config.testing_mode := true),
None,
"Mode for testing, where no libraries are translated, including enums defined in the libraries";
"-debug",
Arg.Unit (fun _ -> CFrontend_config.debug_mode := true),
None,
"Enables debug mode";
"-stats",
Arg.Unit (fun _ -> CFrontend_config.stats_mode := true),
None,
"Enables stats mode";
"-project_root",
Arg.String (fun s ->
"-c",
Arg.String (fun cfile -> source_file := Some cfile),
Some "cfile",
"C File to translate";
"-x",
Arg.String (fun lang -> CFrontend_config.lang_from_string lang),
Some "cfile",
"Language (c, objective-c, c++, objc-++)";
"-ast",
Arg.String (fun file -> ast_file := Some file),
Some "file",
"AST file for the translation";
"-dotty_cfg_libs",
Arg.Unit (fun _ -> Config.dotty_cfg_libs := true),
None,
"Prints the cfg of the code coming from the libraries";
"-no_headers",
Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := true),
None,
"Do not translate code in header files (default)";
"-headers",
Arg.Unit (fun _ -> CFrontend_config.no_translate_libs := false),
None,
"Translate code in header files";
"-testing_mode",
Arg.Unit (fun _ -> CFrontend_config.testing_mode := true),
None,
"Mode for testing, where no libraries are translated, including enums defined in the libraries";
"-debug",
Arg.Unit (fun _ -> CFrontend_config.debug_mode := true),
None,
"Enables debug mode";
"-stats",
Arg.Unit (fun _ -> CFrontend_config.stats_mode := true),
None,
"Enables stats mode";
"-project_root",
Arg.String (fun s ->
Config.project_root := Some (Utils.filename_to_absolute s)),
Some "dir",
"Toot directory of the project";
"-fobjc-arc",
Arg.Unit (fun s -> Config.arc_mode := true),
None,
"Translate with Objective-C Automatic Reference Counting (ARC)";
"-models_mode",
Arg.Unit (fun _ -> CFrontend_config.models_mode := true),
None,
"Mode for computing the models";
Some "dir",
"Toot directory of the project";
"-fobjc-arc",
Arg.Unit (fun s -> Config.arc_mode := true),
None,
"Translate with Objective-C Automatic Reference Counting (ARC)";
"-models_mode",
Arg.Unit (fun _ -> CFrontend_config.models_mode := true),
None,
"Mode for computing the models";
] in
Utils.Arg2.create_options_desc false "Parsing Options" desc in
base_arg
@ -123,7 +123,7 @@ let _ =
Config.print_types:= true;
if Option.is_none !source_file then
(Printing.log_err "Incorrect command line arguments\n";
print_usage_exit ())
print_usage_exit ())
else
match !source_file with
| Some path -> do_run path !ast_file

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

@ -18,13 +18,13 @@ module L = Logging
module type CMethod_decl = sig
val process_methods : Sil.tenv -> Cg.t -> Cfg.cfg -> CContext.curr_class -> string option ->
Clang_ast_t.decl list -> unit
Clang_ast_t.decl list -> unit
val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info ->
string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit
string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit
val create_function_signature : Clang_ast_t.decl_info -> Clang_ast_t.function_decl_info -> string ->
Clang_ast_t.qual_type -> bool -> Procname.t option -> Clang_ast_t.stmt option * CMethod_signature.method_signature
Clang_ast_t.qual_type -> bool -> Procname.t option -> Clang_ast_t.stmt option * CMethod_signature.method_signature
val process_getter_setter : CContext.t -> Procname.t -> bool
end
@ -92,8 +92,8 @@ struct
let ms = build_method_signature di procname
(Func_decl_info (fdecl_info, CTypes.get_type qt)) is_instance is_anonym_block false in
(match method_body_to_translate di ms fdecl_info.Clang_ast_t.fdi_body with
| Some body -> Some body, ms
| None -> None, ms)
| Some body -> Some body, ms
| None -> None, ms)
let model_exists procname =
Specs.summary_exists_in_models procname && not !CFrontend_config.models_mode
@ -104,12 +104,12 @@ struct
| decl:: rest ->
let rest_assume_calls = add_assume_not_null_calls rest attributes in
(match decl with
| ParmVarDecl(decl_info, name_info, qtype, var_decl_info)
when CFrontend_utils.Ast_utils.is_type_nonnull qtype attributes ->
let name = name_info.Clang_ast_t.ni_name in
let assume_call = Ast_expressions.create_assume_not_null_call decl_info name qtype in
assume_call:: rest_assume_calls
| _ -> rest_assume_calls)
| ParmVarDecl(decl_info, name_info, qtype, var_decl_info)
when CFrontend_utils.Ast_utils.is_type_nonnull qtype attributes ->
let name = name_info.Clang_ast_t.ni_name in
let assume_call = Ast_expressions.create_assume_not_null_call decl_info name qtype in
assume_call:: rest_assume_calls
| _ -> rest_assume_calls)
(* Translates the method/function's body into nodes of the cfg. *)
let add_method tenv cg cfg class_decl_opt procname namespace instrs is_objc_method is_instance
@ -118,34 +118,34 @@ struct
"\n\n>>---------- ADDING METHOD: '%s' ---------<<\n@." (Procname.to_string procname);
try
(match Cfg.Procdesc.find_from_name cfg procname with
| Some procdesc ->
if (Cfg.Procdesc.is_defined procdesc && not (model_exists procname)) then
(let context =
CContext.create_context tenv cg cfg procdesc namespace class_decl_opt
is_objc_method captured_vars is_instance in
CVar_decl.get_fun_locals context instrs;
let local_vars = list_map (fun (n, t, _) -> n, t) context.CContext.local_vars in
let start_node = Cfg.Procdesc.get_start_node procdesc in
let exit_node = Cfg.Procdesc.get_exit_node procdesc in
Cfg.Procdesc.append_locals procdesc local_vars;
Cfg.Node.add_locals_ret_declaration start_node local_vars;
Printing.log_out
"\n\n>>---------- Start translating body of function: '%s' ---------<<\n@."
(Procname.to_string procname);
let nonnull_assume_calls = add_assume_not_null_calls param_decls in
let instrs' = instrs@nonnull_assume_calls attributes in
let meth_body_nodes = T.instructions_trans context instrs' exit_node in
if (not is_anonym_block) then CContext.LocalVars.reset_block ();
Cfg.Node.set_succs_exn start_node meth_body_nodes [];
Cg.add_node (CContext.get_cg context) (Cfg.Procdesc.get_proc_name procdesc))
| None -> ())
| Some procdesc ->
if (Cfg.Procdesc.is_defined procdesc && not (model_exists procname)) then
(let context =
CContext.create_context tenv cg cfg procdesc namespace class_decl_opt
is_objc_method captured_vars is_instance in
CVar_decl.get_fun_locals context instrs;
let local_vars = list_map (fun (n, t, _) -> n, t) context.CContext.local_vars in
let start_node = Cfg.Procdesc.get_start_node procdesc in
let exit_node = Cfg.Procdesc.get_exit_node procdesc in
Cfg.Procdesc.append_locals procdesc local_vars;
Cfg.Node.add_locals_ret_declaration start_node local_vars;
Printing.log_out
"\n\n>>---------- Start translating body of function: '%s' ---------<<\n@."
(Procname.to_string procname);
let nonnull_assume_calls = add_assume_not_null_calls param_decls in
let instrs' = instrs@nonnull_assume_calls attributes in
let meth_body_nodes = T.instructions_trans context instrs' exit_node in
if (not is_anonym_block) then CContext.LocalVars.reset_block ();
Cfg.Node.set_succs_exn start_node meth_body_nodes [];
Cg.add_node (CContext.get_cg context) (Cfg.Procdesc.get_proc_name procdesc))
| None -> ())
with
| Not_found -> ()
| CTrans_utils.Self.SelfClassException _ ->
assert false (* this shouldn't happen, because self or [a class] should always be arguments of functions. This is to make sure I'm not wrong. *)
| Assert_failure (file, line, column) ->
print_endline ("Fatal error: exception Assert_failure("^
file^", "^(string_of_int line)^", "^(string_of_int column)^")");
file^", "^(string_of_int line)^", "^(string_of_int column)^")");
Cfg.Procdesc.remove cfg procname true;
CMethod_trans.create_external_procdesc cfg procname is_objc_method None;
()
@ -178,13 +178,13 @@ struct
Printing.log_out " ....Processing implementation for method '%s'\n" (Procname.to_string procname);
CMethod_signature.add ms;
(match method_body_to_translate decl_info ms method_decl_info.Clang_ast_t.omdi_body with
| Some body ->
let is_instance = CMethod_signature.ms_is_instance ms in
let attributes = CMethod_signature.ms_get_attributes ms in
if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_instance then
add_method tenv cg cfg curr_class procname namespace [body] true is_instance [] false
method_decl_info.Clang_ast_t.omdi_parameters attributes
| None -> ())
| Some body ->
let is_instance = CMethod_signature.ms_is_instance ms in
let attributes = CMethod_signature.ms_get_attributes ms in
if CMethod_trans.create_local_procdesc cfg tenv ms [body] [] is_instance then
add_method tenv cg cfg curr_class procname namespace [body] true is_instance [] false
method_decl_info.Clang_ast_t.omdi_parameters attributes
| None -> ())
let rec process_one_method_decl tenv cg cfg curr_class namespace dec =
match dec with
@ -199,7 +199,7 @@ struct
| EmptyDecl _ | ObjCIvarDecl _ | ObjCPropertyDecl _ -> ()
| d -> Printing.log_err
"\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d);
"\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED\n\n" (Ast_utils.string_of_decl d);
()
let process_methods tenv cg cfg curr_class namespace decl_list =
@ -211,17 +211,17 @@ struct
let method_name = Procname.c_get_method procname in
match ObjcProperty_decl.method_is_property_accesor cls method_name with
| Some (property_name, property_type, is_getter) when
CMethod_trans.should_create_procdesc context.cfg procname true true ->
CMethod_trans.should_create_procdesc context.cfg procname true true ->
(match property_type with qt, atts, decl_info, _, _, ivar_opt ->
let ivar_name = ObjcProperty_decl.get_ivar_name property_name ivar_opt in
let field = CField_decl.build_sil_field_property cls context.tenv ivar_name qt (Some atts) in
ignore (CField_decl.add_missing_fields context.tenv class_name [field]);
let accessor =
if is_getter then
ObjcProperty_decl.make_getter cls property_name property_type
else ObjcProperty_decl.make_setter cls property_name property_type in
list_iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor;
true)
let ivar_name = ObjcProperty_decl.get_ivar_name property_name ivar_opt in
let field = CField_decl.build_sil_field_property cls context.tenv ivar_name qt (Some atts) in
ignore (CField_decl.add_missing_fields context.tenv class_name [field]);
let accessor =
if is_getter then
ObjcProperty_decl.make_getter cls property_name property_type
else ObjcProperty_decl.make_setter cls property_name property_type in
list_iter (process_one_method_decl context.tenv context.cg context.cfg cls context.namespace) accessor;
true)
| _ -> false
end

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

@ -46,8 +46,8 @@ let resolve_method tenv class_name method_name =
| Some (Sil.TN_csu (Sil.Class, class_name)) ->
let class_method_name = mk_procname_from_method (Mangled.to_string class_name) method_name in
(try let ms = CMethod_signature.find class_method_name in
Some ms
with Not_found -> None)
Some ms
with Not_found -> None)
| _ -> None
let get_superclass_curr_class context =
@ -60,8 +60,8 @@ let get_superclass_curr_class context =
| _ ->
Printing.log_err "NOT FOUND superclass = '%s'\n\n%!" (Sil.typename_to_string iname);
(match super_opt with
| Some super -> super
| _ -> assert false) in
| Some super -> super
| _ -> assert false) in
match CContext.get_curr_class context with
| CContext.ContextCls (cname, super_opt, _) ->
retrive_super cname super_opt
@ -76,10 +76,10 @@ let get_class_selector_instance context obj_c_message_expr_info act_params =
| `Class qt -> (CTypes.get_type qt, selector, MCStatic)
| `Instance ->
(match act_params with
| (instance_obj, Sil.Tptr(t, _)):: _
| (instance_obj, t):: _ ->
(CTypes.classname_of_type t, selector, MCVirtual)
| _ -> assert false)
| (instance_obj, Sil.Tptr(t, _)):: _
| (instance_obj, t):: _ ->
(CTypes.classname_of_type t, selector, MCVirtual)
| _ -> assert false)
| `SuperInstance ->
let superclass = get_superclass_curr_class context in
(superclass, selector, MCNoVirtual)
@ -115,18 +115,18 @@ let captured_vars_from_block_info context cvl =
| [] -> []
| cv:: cvl'' ->
(match cv.Clang_ast_t.bcv_variable with
| Some dr ->
(match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_qual_type with
| Some name_info, _ ->
let n = name_info.Clang_ast_t.ni_name in
if n = CFrontend_config.self && not context.is_instance then []
else
(let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in
(Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals));
let formals = list_map formal2captured procdesc_formals in
[find (context.local_vars @ formals) n])
| _ -> assert false)
| None -> []) :: f cvl'' in
| Some dr ->
(match dr.Clang_ast_t.dr_name, dr.Clang_ast_t.dr_qual_type with
| Some name_info, _ ->
let n = name_info.Clang_ast_t.ni_name in
if n = CFrontend_config.self && not context.is_instance then []
else
(let procdesc_formals = Cfg.Procdesc.get_formals context.procdesc in
(Printing.log_err "formals are %s@." (Utils.list_to_string (fun (x, _) -> x) procdesc_formals));
let formals = list_map formal2captured procdesc_formals in
[find (context.local_vars @ formals) n])
| _ -> assert false)
| None -> []) :: f cvl'' in
list_flatten (f cvl)
let get_return_type tenv ms =
@ -153,9 +153,9 @@ let should_create_procdesc cfg procname defined generated =
let is_generated_previous =
(Cfg.Procdesc.get_attributes prevoius_procdesc).Sil.is_generated in
if defined &&
((not is_defined_previous) || (generated && is_generated_previous)) then
((not is_defined_previous) || (generated && is_generated_previous)) then
(Cfg.Procdesc.remove cfg (Cfg.Procdesc.get_proc_name prevoius_procdesc) true;
true)
true)
else false
| None -> true
@ -195,25 +195,25 @@ let create_local_procdesc cfg tenv ms fbody captured is_objc_inst_method =
Sil.is_generated = is_generated;
} in
create {
cfg = cfg;
name = procname;
is_defined = defined;
ret_type = ret_type;
formals = formals;
locals = [];
captured = captured';
loc = loc_start;
proc_attributes = proc_attributes;
} in
cfg = cfg;
name = procname;
is_defined = defined;
ret_type = ret_type;
formals = formals;
locals = [];
captured = captured';
loc = loc_start;
proc_attributes = proc_attributes;
} in
if defined then
(if !Config.arc_mode then
Cfg.Procdesc.set_flag procdesc Mleak_buckets.objc_arc_flag "true";
let start_kind = Cfg.Node.Start_node procdesc in
let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in
let exit_kind = Cfg.Node.Exit_node procdesc in
let exit_node = Cfg.Node.create cfg loc_exit exit_kind [] procdesc [] in
Cfg.Procdesc.set_start_node procdesc start_node;
Cfg.Procdesc.set_exit_node procdesc exit_node) in
Cfg.Procdesc.set_flag procdesc Mleak_buckets.objc_arc_flag "true";
let start_kind = Cfg.Node.Start_node procdesc in
let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in
let exit_kind = Cfg.Node.Exit_node procdesc in
let exit_node = Cfg.Node.create cfg loc_exit exit_kind [] procdesc [] in
Cfg.Procdesc.set_start_node procdesc start_node;
Cfg.Procdesc.set_exit_node procdesc exit_node) in
let generated = CMethod_signature.ms_is_generated ms in
if should_create_procdesc cfg procname defined generated then
(create_new_procdesc (); true)
@ -226,9 +226,9 @@ let create_external_procdesc cfg procname is_objc_inst_method type_opt =
| None ->
let ret_type, formals =
(match type_opt with
| Some (ret_type, arg_types) ->
ret_type, list_map (fun typ -> ("x", typ)) arg_types
| None -> Sil.Tvoid, []) in
| Some (ret_type, arg_types) ->
ret_type, list_map (fun typ -> ("x", typ)) arg_types
| None -> Sil.Tvoid, []) in
let loc = Sil.loc_none in
let _ =
let open Cfg.Procdesc in
@ -246,16 +246,16 @@ let create_external_procdesc cfg procname is_objc_inst_method type_opt =
Sil.is_generated = false;
} in
create {
cfg = cfg;
name = procname;
is_defined = false;
ret_type = ret_type;
formals = formals;
locals = [];
captured = [];
loc = loc;
proc_attributes = proc_attributes;
} in
cfg = cfg;
name = procname;
is_defined = false;
ret_type = ret_type;
formals = formals;
locals = [];
captured = [];
loc = loc;
proc_attributes = proc_attributes;
} in
()
let instance_to_method_call_type instance =

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

@ -15,7 +15,7 @@ end
module type CMethod_declaration =
sig
val function_decl : Sil.tenv -> Cfg.cfg -> Cg.t -> string option -> bool -> Clang_ast_t.decl_info ->
string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit
string -> Clang_ast_t.qual_type -> Clang_ast_t.function_decl_info -> (Mangled.t * Sil.typ * bool) list -> Procname.t option -> CContext.curr_class -> unit
val process_getter_setter : CContext.t -> Procname.t -> bool
end

1004
infer/src/clang/cTrans.ml
View File

File diff suppressed because it is too large Load Diff

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

@ -32,7 +32,7 @@ let is_alloc_model typ funct =
else
let funct = Procname.to_string procname in
(* if (Core_foundation_model.is_core_lib_create typ funct) then
print_endline ("\nCore Foundation create not modelled "^(Sil.typ_to_string typ)^" "^(funct));*)
print_endline ("\nCore Foundation create not modelled "^(Sil.typ_to_string typ)^" "^(funct));*)
Core_foundation_model.is_core_lib_create typ funct
| None -> false
@ -104,12 +104,12 @@ let builtin_predefined_model fun_stmt sil_fe =
| Some exp ->
let typ = CTypes.get_type exp in
(match sil_fe with
| Sil.Const (Sil.Cfun pn) when Specs.summary_exists pn -> sil_fe, false
| Sil.Const (Sil.Cfun pn) when is_retain_predefined_model typ (Procname.to_string pn) ->
Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_retain_cf) , true
| Sil.Const (Sil.Cfun pn) when is_release_predefined_model typ (Procname.to_string pn) ->
Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_release_cf), true
| _ -> sil_fe, false)
| Sil.Const (Sil.Cfun pn) when Specs.summary_exists pn -> sil_fe, false
| Sil.Const (Sil.Cfun pn) when is_retain_predefined_model typ (Procname.to_string pn) ->
Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_retain_cf) , true
| Sil.Const (Sil.Cfun pn) when is_release_predefined_model typ (Procname.to_string pn) ->
Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__objc_release_cf), true
| _ -> sil_fe, false)
| _ -> sil_fe, false
(** If the function is a builtin model, return the model, otherwise return the function *)
@ -153,7 +153,7 @@ let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname =
let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname =
let condition = (method_name = release || method_name = drain) &&
(class_name = nsautorelease_pool_cl) in
(class_name = nsautorelease_pool_cl) in
get_predefined_ms_method condition class_name method_name mk_procname [(self, class_name, None)]
void [] (Some SymExec.ModelBuiltins.__objc_release_autorelease_pool)
@ -177,7 +177,7 @@ let dispatch_functions = [
("dispatch_group_notify", 2);
("dispatch_group_wait", 2);
("dispatch_barrier_async", 1);
]
]
let is_dispatch_function_name function_name =
let rec is_dispatch functions =

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

@ -99,10 +99,10 @@ struct
try
Hashtbl.find goto_label_node_map label
with Not_found ->
let node_name = Format.sprintf "GotoLabel_%s" label in
let new_node = Nodes.create_node (Cfg.Node.Skip_node node_name) [] [] sil_loc context in
Hashtbl.add goto_label_node_map label new_node;
new_node
let node_name = Format.sprintf "GotoLabel_%s" label in
let new_node = Nodes.create_node (Cfg.Node.Skip_node node_name) [] [] sil_loc context in
Hashtbl.add goto_label_node_map label new_node;
new_node
end
type continuation = {
@ -233,8 +233,8 @@ struct
instrs =[];
exps = []}
| _, true ->
(* We need to create a node but params also created some,*)
(* so we need to pass back the nodes/leafs params*)
(* We need to create a node but params also created some,*)
(* so we need to pass back the nodes/leafs params*)
let node' = mk_node () in
Cfg.Node.set_succs_exn node' trans_state.succ_nodes [];
let ids_parent = ids_to_parent trans_state.continuation res_state_param.ids in
@ -342,7 +342,7 @@ let cast_trans context exps sil_loc callee_pname_opt function_type =
let builtin_trans trans_state loc stmt_info function_type callee_pname_opt =
if CTrans_models.is_cf_non_null_alloc callee_pname_opt ||
CTrans_models.is_alloc_model function_type callee_pname_opt then
CTrans_models.is_alloc_model function_type callee_pname_opt then
Some (alloc_trans trans_state loc stmt_info function_type true)
else if CTrans_models.is_alloc callee_pname_opt then
Some (alloc_trans trans_state loc stmt_info function_type false)
@ -361,8 +361,8 @@ let cast_operation context cast_kind exps cast_typ sil_loc is_objc_bridged =
| `IntegralToBoolean -> (* This is treated as a nop by returning the same expressions exps*)
([],[], exp)
| `LValueToRValue ->
(* Takes an LValue and allow it to use it as RValue. *)
(* So we assign the LValue to a temp and we pass it to the parent.*)
(* Takes an LValue and allow it to use it as RValue. *)
(* So we assign the LValue to a temp and we pass it to the parent.*)
let id = Ident.create_fresh Ident.knormal in
let sil_instr = [Sil.Letderef (id, exp, typ, sil_loc)] in
([id], sil_instr, Sil.Var id)
@ -435,11 +435,11 @@ let fix_param_exps_mismatch params_stmt exps_param =
let get_name_decl_ref_exp_info decl_ref_expr_info si =
match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with
| Some d -> (match d.Clang_ast_t.dr_name with
| Some n -> n.Clang_ast_t.ni_name
| _ -> assert false)
| Some n -> n.Clang_ast_t.ni_name
| _ -> assert false)
| _ -> L.err "FAILING WITH %s pointer=%s@.@."
(Clang_ast_j.string_of_decl_ref_expr_info decl_ref_expr_info )
(Clang_ast_j.string_of_stmt_info si); assert false
(Clang_ast_j.string_of_decl_ref_expr_info decl_ref_expr_info )
(Clang_ast_j.string_of_stmt_info si); assert false
let is_superinstance mei =
match mei.Clang_ast_t.omei_receiver_kind with
@ -463,10 +463,10 @@ let get_value_enum_constant tenv enum_type stmt =
let _, v = try
list_find (fun (c, _) -> Mangled.equal c (Mangled.from_string constant)) enum_constants
with _ -> (Printing.log_err
"Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in
"Enumeration constant '%s' not found. Cannot continue...\n" constant; assert false) in
v
| _ -> Printing.log_err
"Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename);
"Enum type '%s' not found in tenv. Cannot continue...\n" (Sil.typename_to_string typename);
assert false
let get_selector_receiver obj_c_message_expr_info =
@ -487,10 +487,10 @@ let is_enumeration_constant stmt =
match stmt with
| DeclRefExpr(_, _, _, drei) ->
(match drei.Clang_ast_t.drti_decl_ref with
| Some d -> (match d.Clang_ast_t.dr_kind with
| `EnumConstant -> true
| _ -> false)
| _ -> false)
| Some d -> (match d.Clang_ast_t.dr_kind with
| `EnumConstant -> true
| _ -> false)
| _ -> false)
| _ -> false
let is_null_stmt s =
@ -511,8 +511,8 @@ let rec get_type_from_exp_stmt stmt =
let do_decl_ref_exp i =
match i.Clang_ast_t.drti_decl_ref with
| Some d -> (match d.Clang_ast_t.dr_qual_type with
| Some n -> n
| _ -> assert false )
| Some n -> n
| _ -> assert false )
| _ -> assert false in
match stmt with
| CXXOperatorCallExpr(_, _, ei)
@ -578,14 +578,14 @@ let is_owning_name n =
match Str.split (Str.regexp_string ":") n with
| fst:: _ ->
(match Str.split (Str.regexp "['_']+") fst with
| [no_und]
| _:: no_und:: _ ->
is_family CFrontend_config.alloc no_und ||
is_family CFrontend_config.copy no_und ||
is_family CFrontend_config.new_str no_und ||
is_family CFrontend_config.mutableCopy no_und ||
is_family CFrontend_config.init no_und
| _ -> assert false)
| [no_und]
| _:: no_und:: _ ->
is_family CFrontend_config.alloc no_und ||
is_family CFrontend_config.copy no_und ||
is_family CFrontend_config.new_str no_und ||
is_family CFrontend_config.mutableCopy no_und ||
is_family CFrontend_config.init no_und
| _ -> assert false)
| _ -> assert false
let rec is_owning_method s =
@ -593,15 +593,15 @@ let rec is_owning_method s =
| ObjCMessageExpr(_, _ , _, mei) ->
is_owning_name mei.Clang_ast_t.omei_selector
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false
| s'':: _ -> is_owning_method s'')
| [] -> false
| s'':: _ -> is_owning_method s'')
let rec is_method_call s =
match s with
| ObjCMessageExpr(_, _ , _, mei) -> true
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false
| s'':: _ -> is_method_call s'')
| [] -> false
| s'':: _ -> is_method_call s'')
let rec get_decl_ref_info s parent_line_number =
match s with
@ -609,17 +609,17 @@ let rec get_decl_ref_info s parent_line_number =
let line_number = CLocation.get_line stmt_info parent_line_number in
stmt_info.Clang_ast_t.si_pointer, line_number
| _ -> (match Clang_ast_proj.get_stmt_tuple s with
| stmt_info, [] -> assert false
| stmt_info, s'':: _ ->
let line_number = CLocation.get_line stmt_info parent_line_number in
get_decl_ref_info s'' line_number)
| stmt_info, [] -> assert false
| stmt_info, s'':: _ ->
let line_number = CLocation.get_line stmt_info parent_line_number in
get_decl_ref_info s'' line_number)
let rec contains_opaque_value_expr s =
match s with
| OpaqueValueExpr (_, _, _, _) -> true
| _ -> (match snd (Clang_ast_proj.get_stmt_tuple s) with
| [] -> false
| s'':: _ -> contains_opaque_value_expr s'')
| [] -> false
| s'':: _ -> contains_opaque_value_expr s'')
let rec compute_autorelease_pool_vars context stmts =
match stmts with
@ -632,10 +632,10 @@ let rec compute_autorelease_pool_vars context stmts =
list_filter (fun (m, t) -> Mangled.to_string m = name) local_vars
with _ -> [] in
(match mname with
| [(m, t)] ->
CFrontend_utils.General_utils.append_no_duplicated_pvars
[(Sil.Lvar (Sil.mk_pvar m procname), t)] (compute_autorelease_pool_vars context stmts')
| _ -> compute_autorelease_pool_vars context stmts')
| [(m, t)] ->
CFrontend_utils.General_utils.append_no_duplicated_pvars
[(Sil.Lvar (Sil.mk_pvar m procname), t)] (compute_autorelease_pool_vars context stmts')
| _ -> compute_autorelease_pool_vars context stmts')
| s:: stmts' ->
let sl = snd(Clang_ast_proj.get_stmt_tuple s) in
compute_autorelease_pool_vars context (sl@stmts')
@ -651,21 +651,21 @@ let is_dispatch_function stmt_list =
match stmt_list with
| ImplicitCastExpr(_,[DeclRefExpr(_, _, _, di)], _, _):: stmts ->
(match di.Clang_ast_t.drti_decl_ref with
| None -> None
| Some d ->
(match d.Clang_ast_t.dr_kind, d.Clang_ast_t.dr_name with
| `Function, Some name_info ->
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) ->
try
(match list_nth stmts block_arg_pos with
| BlockExpr _ -> Some block_arg_pos
| _ -> None)
with Not_found -> None
)
| _ -> None))
| None -> None
| Some d ->
(match d.Clang_ast_t.dr_kind, d.Clang_ast_t.dr_name with
| `Function, Some name_info ->
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) ->
try
(match list_nth stmts block_arg_pos with
| BlockExpr _ -> Some block_arg_pos
| _ -> None)
with Not_found -> None
)
| _ -> None))
| _ -> None
let assign_default_params params_stmt callee_pname_opt =
@ -683,7 +683,7 @@ let assign_default_params params_stmt callee_pname_opt =
list_map replace_default_arg params_args
with
| Invalid_argument _ ->
(* list_combine failed because of different list lengths *)
(* list_combine failed because of different list lengths *)
Printing.log_err "Param count doesn't match %s\n" (Procname.to_string callee_pname);
params_stmt
| Not_found -> params_stmt

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

@ -46,22 +46,22 @@ let lookup_var_type context pvar =
Printing.log_out "found '%s' in formals.@." (Sil.typ_to_string t);
t
with Not_found ->
try
let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in
Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar);
Printing.log_out "found '%s' in locals.@." (Sil.typ_to_string t);
t
with Not_found ->
try
let s, t = list_find (fun (s, t) -> Mangled.equal (Sil.pvar_get_name pvar) s) locals in
Printing.log_out "When looking for type of variable '%s' " (Sil.pvar_to_string pvar);
Printing.log_out "found '%s' in locals.@." (Sil.typ_to_string t);
t
let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in
Printing.log_out "When looking for type of variable '%s'" (Sil.pvar_to_string pvar);
Printing.log_out " found '%s' in globals.@." (Sil.typ_to_string typ);
typ
with Not_found ->
try
let typ = CGlobal_vars.var_get_typ (CGlobal_vars.find (Sil.pvar_get_name pvar)) in
Printing.log_out "When looking for type of variable '%s'" (Sil.pvar_to_string pvar);
Printing.log_out " found '%s' in globals.@." (Sil.typ_to_string typ);
typ
with Not_found ->
Printing.log_err
"WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!"
(Sil.pvar_to_string pvar);
Sil.Tvoid
Printing.log_err
"WARNING: Variable '%s' not found in local+formal when looking for its type. Returning void.\n%!"
(Sil.pvar_to_string pvar);
Sil.Tvoid
(* Extract the type out of a statement. This is useful when the statement *)
(* denotes actually an expression *)
@ -176,8 +176,8 @@ let get_raw_qual_type_decl_ref_exp_info decl_ref_expr_info =
match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with
| Some d ->
(match d.Clang_ast_t.dr_qual_type with
| Some qt -> Some qt.Clang_ast_t.qt_raw
| None -> None)
| Some qt -> Some qt.Clang_ast_t.qt_raw
| None -> None)
| None -> None
(* Iterates over the tenv to find the value of the enumeration constant *)

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

@ -24,12 +24,12 @@ let add_predefined_types tenv =
let objc_class_name = Sil.TN_csu (Sil.Class, objc_class_mangled) in
let objc_class_type_info =
Sil.Tstruct ([], [], Sil.Struct,
Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in
Some (Mangled.from_string CFrontend_config.objc_class), [], [], []) in
Sil.tenv_add tenv objc_class_name objc_class_type_info;
let mn = Mangled.from_string CFrontend_config.class_type in
let class_typename = Sil.TN_typedef(mn) in
let class_typ = Sil.Tptr ((Sil.Tvar
(Sil.TN_csu (Sil.Struct, objc_class_mangled))), Sil.Pk_pointer) in
(Sil.TN_csu (Sil.Struct, objc_class_mangled))), Sil.Pk_pointer) in
Sil.tenv_add tenv class_typename class_typ;
let typename_objc_object =
Sil.TN_csu (Sil.Struct, Mangled.from_string CFrontend_config.objc_object) in
@ -42,24 +42,24 @@ let rec search_for_named_type tenv typ =
match typename with
| Sil.TN_typedef name ->
(match Sil.tenv_lookup tenv typename with
| Some _ -> typename
| None ->
let pot_class_type = Sil.TN_csu (Sil.Class, name) in
match Sil.tenv_lookup tenv pot_class_type with
| Some _ -> pot_class_type
| None ->
let pot_protocol_type = Sil.TN_csu (Sil.Protocol, name) in
match Sil.tenv_lookup tenv pot_protocol_type with
| Some _ -> pot_protocol_type
| None ->
let pot_struct_type = Sil.TN_csu (Sil.Struct, name) in
match Sil.tenv_lookup tenv pot_struct_type with
| Some _ -> pot_struct_type
| None ->
let pot_union_type = Sil.TN_csu (Sil.Union, name) in
match Sil.tenv_lookup tenv pot_union_type with
| Some _ -> pot_union_type
| None -> raise Typename_not_found)
| Some _ -> typename
| None ->
let pot_class_type = Sil.TN_csu (Sil.Class, name) in
match Sil.tenv_lookup tenv pot_class_type with
| Some _ -> pot_class_type
| None ->
let pot_protocol_type = Sil.TN_csu (Sil.Protocol, name) in
match Sil.tenv_lookup tenv pot_protocol_type with
| Some _ -> pot_protocol_type
| None ->
let pot_struct_type = Sil.TN_csu (Sil.Struct, name) in
match Sil.tenv_lookup tenv pot_struct_type with
| Some _ -> pot_struct_type
| None ->
let pot_union_type = Sil.TN_csu (Sil.Union, name) in
match Sil.tenv_lookup tenv pot_union_type with
| Some _ -> pot_union_type
| None -> raise Typename_not_found)
| _ -> typename in
match typ with
| Sil.Tvar typename -> Sil.Tvar (search typename)
@ -85,10 +85,10 @@ let string_type_to_sil_type tenv s =
(* 'union <anonymous at union.c:4:1>'*)
let s = (match Str.split (Str.regexp "[ \t]+") s with
| "struct"::"(anonymous":: "struct":: s' ->
(*Printing.log_out " ...Getting rid of the extra 'struct' word@."; *)
(*Printing.log_out " ...Getting rid of the extra 'struct' word@."; *)
string_from_list ("struct"::"(anonymous":: s')
| "union"::"(anonymous":: "union":: s' ->
(*Printing.log_out " ...Getting rid of the extra 'union' word@."; *)
(*Printing.log_out " ...Getting rid of the extra 'union' word@."; *)
string_from_list ("union"::"(anonymous":: s')
| _ -> s) in
let lexbuf = Lexing.from_string s in
@ -99,14 +99,14 @@ let string_type_to_sil_type tenv s =
" ...Parsed. Translated with sil TYPE '%a'@." (Sil.pp_typ_full pe_text) t;
t
with Parsing.Parse_error -> (
Printing.log_stats
"\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s;
Sil.Tvoid) in
Printing.log_stats
"\nXXXXXXX PARSE ERROR for string '%s'. RETURNING Void.TODO@.@." s;
Sil.Tvoid) in
try
search_for_named_type tenv t
with Typename_not_found -> Printing.log_stats
"\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s;
t)
"\nXXXXXX Parsed string '%s' as UNKNOWN type name. RETURNING a type name.TODO@.@." s;
t)
let qual_type_to_sil_type_no_expansions tenv qt =
string_type_to_sil_type tenv (CTypes.get_type qt)
@ -129,8 +129,8 @@ let parse_func_type name func_type =
((Sil.typ_to_string return_type)^" <- "^(Utils.list_to_string (Sil.typ_to_string) arg_types));
Some (return_type, arg_types)
with Parsing.Parse_error -> (
Printing.log_stats "\nXXXXXXX PARSE ERROR for string '%s'." func_type;
None)
Printing.log_stats "\nXXXXXXX PARSE ERROR for string '%s'." func_type;
None)
(*In case of typedef like *)
(* typedef struct { f1; f2; ... } s; *)
@ -147,18 +147,18 @@ let rec disambiguate_typedef tenv namespace t mn =
(* Eg. TN_typdef(mn) --> TN_typedef(mn). We need to break it*)
let tn = Sil.TN_csu(Sil.Struct, mn) in
(match Sil.tenv_lookup tenv tn with
| Some _ ->
(* There is a struct in tenv, so we make the typedef mn pointing to the struct*)
Printing.log_out " ...Found type TN_typdef('%s') " (Mangled.to_string mn);
Printing.log_out "in typedef of '%s'@." (Mangled.to_string mn);
Printing.log_out
"Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@."
(Mangled.to_string mn);
Sil.Tvar(tn)
| None ->
if add_late_defined_record tenv namespace tn then
disambiguate_typedef tenv namespace t mn
else t)
| Some _ ->
(* There is a struct in tenv, so we make the typedef mn pointing to the struct*)
Printing.log_out " ...Found type TN_typdef('%s') " (Mangled.to_string mn);
Printing.log_out "in typedef of '%s'@." (Mangled.to_string mn);
Printing.log_out
"Avoid circular definition in tenv by pointing the typedef to struc TN_csu('%s')@."
(Mangled.to_string mn);
Sil.Tvar(tn)
| None ->
if add_late_defined_record tenv namespace tn then
disambiguate_typedef tenv namespace t mn
else t)
else t
| _ -> t
@ -189,10 +189,10 @@ and get_struct_fields tenv record_name namespace decl_list =
let annotation_items = [] in (* For the moment we don't use them*)
(id, typ, annotation_items):: get_struct_fields tenv record_name namespace decl_list'
| CXXRecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decl_list'
:: decl_list'
(* C++/C Records treated in the same way*)
| RecordDecl (decl_info, name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decl_list'->
:: decl_list'->
do_record_declaration tenv namespace decl_info name.Clang_ast_t.ni_name opt_type decl_list decl_context_info record_decl_info;
get_struct_fields tenv record_name namespace decl_list'
| _ :: decl_list' -> get_struct_fields tenv record_name namespace decl_list'
@ -234,7 +234,7 @@ and get_declaration_type tenv namespace decl_info n opt_type decl_list decl_cont
let methods_list = [] in (* No methods list for structs *)
let item_annotation = Sil.item_annotation_empty in (* No annotations for struts *)
Sil.Tstruct
(non_static_fields, static_fields, csu, name, superclass_list, methods_list, item_annotation)
(non_static_fields, static_fields, csu, name, superclass_list, methods_list, item_annotation)
(* Look for a record definition that is defined after it is dereferenced. *)
(* It returns true if a new record definition has been added to tenv.*)
@ -246,26 +246,26 @@ and add_late_defined_record tenv namespace typename =
match decls with
| [] -> false
| CXXRecordDecl
(decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decls'
(decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decls'
| RecordDecl
(decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decls' ->
(decl_info, record_name, opt_type, decl_list, decl_context_info, record_decl_info)
:: decls' ->
(match opt_type with
| `Type t ->
(* the string t contains the name of the type preceded by the word struct. *)
let t_no_struct = CTypes.cut_struct_union t in
let pot_struct_type = Sil.TN_csu (Sil.Struct, (Mangled.from_string t_no_struct)) in
let pot_union_type = Sil.TN_csu (Sil.Union, (Mangled.from_string t_no_struct)) in
if (Sil.typename_equal typename pot_struct_type ||
Sil.typename_equal typename pot_union_type) &&
record_decl_info.Clang_ast_t.rdi_is_complete_definition then (
Printing.log_out "!!!! Adding late-defined record '%s'\n" t;
do_record_declaration tenv namespace decl_info record_name.Clang_ast_t.ni_name opt_type decl_list
decl_context_info record_decl_info;
true)
else scan decls'
| _ -> scan decls')
| `Type t ->
(* the string t contains the name of the type preceded by the word struct. *)
let t_no_struct = CTypes.cut_struct_union t in
let pot_struct_type = Sil.TN_csu (Sil.Struct, (Mangled.from_string t_no_struct)) in
let pot_union_type = Sil.TN_csu (Sil.Union, (Mangled.from_string t_no_struct)) in
if (Sil.typename_equal typename pot_struct_type ||
Sil.typename_equal typename pot_union_type) &&
record_decl_info.Clang_ast_t.rdi_is_complete_definition then (
Printing.log_out "!!!! Adding late-defined record '%s'\n" t;
do_record_declaration tenv namespace decl_info record_name.Clang_ast_t.ni_name opt_type decl_list
decl_context_info record_decl_info;
true)
else scan decls'
| _ -> scan decls')
| LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls')
| _:: decls' -> scan decls' in
scan !CFrontend_config.global_translation_unit_decls
@ -283,13 +283,13 @@ and add_late_defined_typedef tenv namespace typename =
| TypedefDecl (decl_info, name_info, opt_type, tdi) :: decls' ->
let name' = name_info.Clang_ast_t.ni_name in
(match opt_type with
| `Type t ->
if (Mangled.to_string name) = name' then (
Printing.log_out "!!!! Adding late-defined typedef '%s'\n" t;
do_typedef_declaration tenv namespace decl_info name' opt_type tdi;
true)
else scan decls'
| _ -> scan decls')
| `Type t ->
if (Mangled.to_string name) = name' then (
Printing.log_out "!!!! Adding late-defined typedef '%s'\n" t;
do_typedef_declaration tenv namespace decl_info name' opt_type tdi;
true)
else scan decls'
| _ -> scan decls')
| LinkageSpecDecl(_, decl_list', _):: decls' -> scan (decl_list'@decls')
| _:: decls' -> scan decls' in
scan !CFrontend_config.global_translation_unit_decls
@ -300,16 +300,16 @@ and expand_structured_type tenv typ =
match typ with
| Sil.Tvar tn ->
(match Sil.tenv_lookup tenv tn with
| Some t ->
Printing.log_out
" Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t);
if Sil.typ_equal t typ then
typ
else expand_structured_type tenv t
| None -> if (add_late_defined_record tenv None tn ||
add_late_defined_typedef tenv None tn) then
expand_structured_type tenv typ
else typ)
| Some t ->
Printing.log_out
" Type expanded with type '%s' found in tenv@." (Sil.typ_to_string t);
if Sil.typ_equal t typ then
typ
else expand_structured_type tenv t
| None -> if (add_late_defined_record tenv None tn ||
add_late_defined_typedef tenv None tn) then
expand_structured_type tenv typ
else typ)
| Sil.Tptr(t, _) -> typ (*do not expand types under pointers *)
| _ -> typ
@ -329,8 +329,8 @@ and add_struct_to_tenv tenv typ =
Printing.log_out " >>>Verifying that Typename TN_csu('%s') is in tenv\n"
(Sil.typename_to_string typename);
(match Sil.tenv_lookup tenv typename with
| Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n")
| Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n")
and qual_type_to_sil_type_general tenv qt no_pointer =
let typ = string_type_to_sil_type tenv (CTypes.get_type qt) in

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

@ -56,7 +56,7 @@ let rec lookup_ahead_for_vardecl context pointer var_name kind decl_list =
let global_var = CGlobal_vars.find mangled_var_name in
CGlobal_vars.var_get_name global_var)
else (Printing.log_out "SKIPPING VarDecl for '%s'\n" var_name;
lookup_ahead_for_vardecl context pointer var_name kind rest)
lookup_ahead_for_vardecl context pointer var_name kind rest)
| _ :: rest ->
lookup_ahead_for_vardecl context pointer var_name kind rest
@ -94,9 +94,9 @@ let lookup_var stmt_info context pointer var_name kind =
try
lookup_var_static_globals context var_name
with Not_found ->
(Printing.log_out "Looking on later-defined decls for '%s' with pointer '%s' \n" var_name stmt_info.Clang_ast_t.si_pointer;
let decl_list = !CFrontend_config.global_translation_unit_decls in
lookup_ahead_for_vardecl context pointer var_name kind decl_list )
(Printing.log_out "Looking on later-defined decls for '%s' with pointer '%s' \n" var_name stmt_info.Clang_ast_t.si_pointer;
let decl_list = !CFrontend_config.global_translation_unit_decls in
lookup_ahead_for_vardecl context pointer var_name kind decl_list )
(* Traverses the body of the method top down and collects the *)
(* variable definitions in a map in the context. To be able to find the right variable name *)
@ -108,17 +108,17 @@ let rec get_variables_stmt context (stmt : Clang_ast_t.stmt) : unit =
get_variables_decls context decl_list;
get_fun_locals context lstmt;
| DeclRefExpr(stmt_info, stmt_list, expr_info, decl_ref_expr_info) ->
(* Notice that DeclRefExpr is the reference to a declared var/function/enum... *)
(* so no declaration here *)
(* Notice that DeclRefExpr is the reference to a declared var/function/enum... *)
(* so no declaration here *)
Printing.log_out "Collecting variables, passing from DeclRefExpr '%s'\n"
stmt_info.Clang_ast_t.si_pointer;
let var_name = CTrans_utils.get_name_decl_ref_exp_info decl_ref_expr_info stmt_info in
let kind = CTrans_utils.get_decl_kind decl_ref_expr_info in
(match kind with
| `EnumConstant | `ObjCIvar | `CXXMethod | `ObjCProperty -> ()
| _ ->
let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in
CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context)
| `EnumConstant | `ObjCIvar | `CXXMethod | `ObjCProperty -> ()
| _ ->
let pvar = lookup_var stmt_info context stmt_info.Clang_ast_t.si_pointer var_name kind in
CContext.LocalVars.add_pointer_var stmt_info.Clang_ast_t.si_pointer pvar context)
| CompoundStmt(stmt_info, lstmt) ->
Printing.log_out "Collecting variables, passing from CompoundStmt '%s'\n"
stmt_info.Clang_ast_t.si_pointer;
@ -147,15 +147,15 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit =
let name = name_info.Clang_ast_t.ni_name in
let typ = get_var_type context.CContext.tenv name qual_type in
(match var_decl_info.Clang_ast_t.vdi_storage_class with
| Some "static" ->
let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
let static_name = (Procname.to_string pname)^"_"^name in
CGlobal_vars.add static_name typ;
let var = Sil.mk_pvar_global (Mangled.from_string static_name) in
CContext.LocalVars.add_pointer_var decl_info.Clang_ast_t.di_pointer var context
| _ ->
CContext.LocalVars.add_local_var context name typ decl_info.Clang_ast_t.di_pointer
(CFrontend_utils.General_utils.is_static_var var_decl_info))
| Some "static" ->
let pname = Cfg.Procdesc.get_proc_name context.CContext.procdesc in
let static_name = (Procname.to_string pname)^"_"^name in
CGlobal_vars.add static_name typ;
let var = Sil.mk_pvar_global (Mangled.from_string static_name) in
CContext.LocalVars.add_pointer_var decl_info.Clang_ast_t.di_pointer var context
| _ ->
CContext.LocalVars.add_local_var context name typ decl_info.Clang_ast_t.di_pointer
(CFrontend_utils.General_utils.is_static_var var_decl_info))
| CXXRecordDecl(di, n_info, ot, dl, dci, rdi)
| RecordDecl(di, n_info, ot, dl, dci, rdi) ->
let typ = CTypes_decl.get_declaration_type context.CContext.tenv context.CContext.namespace
@ -169,7 +169,7 @@ and get_variables_decls context (decl_list : Clang_ast_t.decl list) : unit =
"WARNING: When collecting variables, passing from StaticAssertDecl '%s'. Skipped.\n"
decl_info.Clang_ast_t.di_pointer
| _ -> Printing.log_out
"!!! When collecting locals of a function found '%s'. Cannot continue\n\n"
(Clang_ast_j.string_of_decl decl);
"!!! When collecting locals of a function found '%s'. Cannot continue\n\n"
(Clang_ast_j.string_of_decl decl);
assert false in
list_iter do_one_decl decl_list

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

@ -35,10 +35,10 @@ let is_pointer_to_objc_class tenv typ =
match typ with
| Sil.Tptr (Sil.Tvar (Sil.TN_csu (Sil.Class, cname)), _) ->
(match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, cname)) with
| Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true
| _ -> false)
| Some Sil.Tstruct(_, _, Sil.Class, _, _, _, a) when is_objc_class_annotation a -> true
| _ -> false)
| Sil.Tptr (Sil.Tstruct(_, _, Sil.Class, _, _, _, a), _) when
is_objc_class_annotation a -> true
is_objc_class_annotation a -> true
| _ -> false
let get_super_interface_decl otdi_super =
@ -48,10 +48,10 @@ let get_super_interface_decl otdi_super =
let get_protocols protocols =
let protocol_names = list_map (
fun decl -> match decl.Clang_ast_t.dr_name with
| Some name -> name.Clang_ast_t.ni_name
| None -> assert false
) protocols in
fun decl -> match decl.Clang_ast_t.dr_name with
| Some name -> name.Clang_ast_t.ni_name
| None -> assert false
) protocols in
protocol_names
(*The superclass is the first element in the list of super classes of structs in the tenv, *)
@ -62,8 +62,8 @@ let get_interface_superclasses super_opt protocols =
| None -> []
| Some super -> [(Sil.Class, Mangled.from_string super)] in
let protocol_names = list_map (
fun name -> (Sil.Protocol, Mangled.from_string name)
) protocols in
fun name -> (Sil.Protocol, Mangled.from_string name)
) protocols in
let super_classes = super_class@protocol_names in
super_classes
@ -77,11 +77,11 @@ let create_curr_class_and_superclasses_fields tenv decl_list class_name otdi_sup
let update_curr_class curr_class superclasses =
let get_protocols protocols = list_fold_right (
fun protocol converted_protocols ->
match protocol with
| (Sil.Protocol, name) -> (Mangled.to_string name):: converted_protocols
| _ -> converted_protocols
) protocols [] in
fun protocol converted_protocols ->
match protocol with
| (Sil.Protocol, name) -> (Mangled.to_string name):: converted_protocols
| _ -> converted_protocols
) protocols [] in
match curr_class with
| CContext.ContextCls (class_name, _, _) ->
let super, protocols =
@ -102,8 +102,8 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info =
let methods = ObjcProperty_decl.get_methods curr_class decl_list in
let fields_sc = CField_decl.fields_superclass tenv obj_c_interface_decl_info in
list_iter (fun (fn, ft, _) ->
Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn);
Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc;
Printing.log_out "----->SuperClass field: '%s' " (Ident.fieldname_to_string fn);
Printing.log_out "type: '%s'\n" (Sil.typ_to_string ft)) fields_sc;
(*In case we found categories, or partial definition of this class earlier and they are already in the tenv *)
let fields, superclasses, methods =
match Sil.tenv_lookup tenv interface_name with
@ -118,16 +118,16 @@ let add_class_to_tenv tenv class_name decl_list obj_c_interface_decl_info =
let fields = CFrontend_utils.General_utils.sort_fields fields in
Printing.log_out "Class %s field:\n" class_name;
list_iter (fun (fn, ft, _) ->
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
Printing.log_out "-----> field: '%s'\n" (Ident.fieldname_to_string fn)) fields;
let interface_type_info =
Sil.Tstruct(fields, [], Sil.Class, Some (Mangled.from_string class_name),
superclasses, methods, objc_class_annotation) in
superclasses, methods, objc_class_annotation) in
Sil.tenv_add tenv interface_name interface_type_info;
Printing.log_out
" >>>Verifying that Typename '%s' is in tenv\n" (Sil.typename_to_string interface_name);
(match Sil.tenv_lookup tenv interface_name with
| Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n");
| Some t -> Printing.log_out " >>>OK. Found typ='%s'\n" (Sil.typ_to_string t)
| None -> Printing.log_out " >>>NOT Found!!\n");
curr_class
let add_missing_methods tenv class_name decl_list curr_class =
@ -165,14 +165,14 @@ let lookup_late_defined_interface tenv cname =
match decls with
| [] -> ()
| ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info)
:: decls'
when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname ->
:: decls'
when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname ->
scan decls'
| ObjCInterfaceDecl(decl_info, name_info, decl_list, decl_context_info, obj_c_interface_decl_info)
:: decls'
when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname ->
(* Assumption: here we assume that the first interface declaration with non empty set of fields is the *)
(* correct one. So we stop. *)
:: decls'
when (Mangled.from_string name_info.Clang_ast_t.ni_name) = cname ->
(* Assumption: here we assume that the first interface declaration with non empty set of fields is the *)
(* correct one. So we stop. *)
ignore (interface_declaration tenv name_info.Clang_ast_t.ni_name decl_list obj_c_interface_decl_info)
| _:: decls' -> scan decls' in
scan !CFrontend_config.global_translation_unit_decls
@ -181,9 +181,9 @@ let lookup_late_defined_interface tenv cname =
(* the search is extended in a recursive way to the hierarchy of superclasses. *)
let rec find_field tenv nfield str searched_late_defined =
(* let add_namespace_to_namefield cname =
match namespace with
| Some _ -> nfield
| None -> (Mangled.to_string cname)^"_"^nfield in *)
match namespace with
| Some _ -> nfield
| None -> (Mangled.to_string cname)^"_"^nfield in *)
let print_error name_field fields =
Printing.log_err "\nFaild to find name field '%s'\n\n" (Ident.fieldname_to_string name_field) ;
Printing.log_err "In the following list of fields\n";
@ -196,8 +196,8 @@ let rec find_field tenv nfield str searched_late_defined =
Printing.log_err "@. ....Searching field in superclass (Class, '%s')@." (Mangled.to_string sname);
let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, sname)) in
(match find_field tenv nfield str' searched_late_defined with
| Some field -> Some field
| None -> search_super s')
| Some field -> Some field
| None -> search_super s')
| (Sil.Protocol, sname):: s' ->
Printing.log_err "@. ... Searching field in protocol (Protocol, '%s')@." (Mangled.to_string sname);
search_super s'
@ -211,24 +211,24 @@ let rec find_field tenv nfield str searched_late_defined =
| Some Sil.Tstruct (sf, nsf, Sil.Struct, Some cname, _, _, _)
| Some Sil.Tstruct (sf, nsf, Sil.Union, Some cname, _, _, _) ->
(let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in
try
Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf))
with Not_found ->
print_error name_field (sf@nsf); None)
try
Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf))
with Not_found ->
print_error name_field (sf@nsf); None)
| Some Sil.Tstruct (sf, nsf, Sil.Class, Some cname, super, _, _) ->
(let name_field = General_utils.mk_class_field_name (Mangled.to_string cname) nfield in
try
Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf))
with Not_found ->
(* if we have already searched for late defined interfaces we check recursively *)
(* whether the field is defined in the hiearchy of superclasses.*)
(* If we don't find it we stop, giving error. *)
print_error name_field (sf@nsf);
if searched_late_defined then search_super super
else (
Printing.log_err "@. Search late defined...@.@.";
(* if we don't find the field the first thing we do is scanning later definitions of interfaces. *)
lookup_late_defined_interface tenv cname;
let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, cname)) in
find_field tenv nfield str' true))
try
Some (list_find (fun (fn, _, _) -> Sil.fld_equal fn name_field) (sf@nsf))
with Not_found ->
(* if we have already searched for late defined interfaces we check recursively *)
(* whether the field is defined in the hiearchy of superclasses.*)
(* If we don't find it we stop, giving error. *)
print_error name_field (sf@nsf);
if searched_late_defined then search_super super
else (
Printing.log_err "@. Search late defined...@.@.";
(* if we don't find the field the first thing we do is scanning later definitions of interfaces. *)
lookup_late_defined_interface tenv cname;
let str' = Sil.tenv_lookup tenv (Sil.TN_csu(Sil.Class, cname)) in
find_field tenv nfield str' true))
| _ -> None

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

@ -29,7 +29,7 @@ type prop_getter_setter = string * (Clang_ast_t.decl * bool) option
(** A property type is a tuple: *)
(** (qual_type, property attributes, decl_info, (getter_name, getter), (setter_name, setter), ivar name) *)
type property_type = Clang_ast_t.qual_type * Clang_ast_t.property_attribute list *
Clang_ast_t.decl_info * prop_getter_setter * prop_getter_setter * string option
Clang_ast_t.decl_info * prop_getter_setter * prop_getter_setter * string option
(** A table that record the property defined in the interface and its getter/setter. *)
(** This info used later on in the implementation if the getter/setter need to automatically *)
@ -54,7 +54,7 @@ sig
val replace_property : property_key -> property_type -> unit
val add_property : property_key -> Clang_ast_t.qual_type ->
Clang_ast_t.property_attribute list -> Clang_ast_t.decl_info -> unit
Clang_ast_t.property_attribute list -> Clang_ast_t.decl_info -> unit
val print_property_table : unit -> unit
@ -91,25 +91,25 @@ struct
let rec find_property curr_class property_name =
try PropertyTableHash.find property_table (curr_class, property_name)
with Not_found ->
match curr_class with
| ContextCls (name, _, protocols) ->
let res_opt = list_fold_right
(fun protocol found_procname_opt ->
match found_procname_opt with
| Some found_procname -> Some found_procname
| None ->
Some (find_property (ContextProtocol protocol) property_name)) protocols None in
(match res_opt with
| Some res -> res
| None -> raise Not_found)
| _ -> raise Not_found
match curr_class with
| ContextCls (name, _, protocols) ->
let res_opt = list_fold_right
(fun protocol found_procname_opt ->
match found_procname_opt with
| Some found_procname -> Some found_procname
| None ->
Some (find_property (ContextProtocol protocol) property_name)) protocols None in
(match res_opt with
| Some res -> res
| None -> raise Not_found)
| _ -> raise Not_found
let find_property_name_from_ivar curr_class ivar =
let res = ref None in
PropertyTableHash.iter (fun (cl, pname) (_, _, _, _, _, ivar') ->
match ivar' with
| Some s when (CContext.curr_class_equal curr_class cl) && s = ivar -> res:= Some pname
| _ -> ()) property_table;
match ivar' with
| Some s when (CContext.curr_class_equal curr_class cl) && s = ivar -> res:= Some pname
| _ -> ()) property_table;
!res
let is_mem_property property =
@ -168,8 +168,8 @@ let find_properties_class = Property.find_properties_class
let get_ivarname_property pidi =
match pidi.Clang_ast_t.opidi_ivar_decl with
| Some dr -> (match dr.Clang_ast_t.dr_name with
| Some n -> n.Clang_ast_t.ni_name
| _ -> assert false)
| Some n -> n.Clang_ast_t.ni_name
| _ -> assert false)
| _ -> (* If ivar is not defined than we need to take the name of the property to define ivar*)
Ast_utils.property_name pidi
@ -194,14 +194,14 @@ let check_for_property curr_class method_name meth_decl body =
let check_property_accessor curr_class method_name is_getter =
let method_is_getter (property_name, property_type) =
match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) ->
let found =
if is_getter then (method_name = getter_name)
else (method_name = setter_name) in
if found then
(Printing.log_out " Found property '%s' defined in property table\n"
(Property.property_key_to_string (curr_class, property_name));
upgrade_property_accessor
(curr_class, property_name) property_type meth_decl defined is_getter) in
let found =
if is_getter then (method_name = getter_name)
else (method_name = setter_name) in
if found then
(Printing.log_out " Found property '%s' defined in property table\n"
(Property.property_key_to_string (curr_class, property_name));
upgrade_property_accessor
(curr_class, property_name) property_type meth_decl defined is_getter) in
list_iter method_is_getter properties_class in
check_property_accessor curr_class method_name true;
check_property_accessor curr_class method_name false
@ -213,34 +213,34 @@ let method_is_property_accesor cls method_name =
| Some res -> res_opt
| None ->
match property_type with (_, _, _, (getter_name, _), (setter_name, _), _) ->
if method_name = getter_name then Some (property_name, property_type, true)
else if method_name = setter_name then Some (property_name, property_type, false)
else None in
if method_name = getter_name then Some (property_name, property_type, true)
else if method_name = setter_name then Some (property_name, property_type, false)
else None in
list_fold_right method_is_getter properties_class None
let prepare_dynamic_property curr_class decl_info property_impl_decl_info =
let pname = Ast_utils.property_name property_impl_decl_info in
let res = (try
let qt', atts, di, getter, setter, _ = Property.find_property curr_class pname in
let ivar = (match property_impl_decl_info.Clang_ast_t.opidi_ivar_decl with
| Some dr -> (match dr.Clang_ast_t.dr_name with
| Some name_info -> name_info.Clang_ast_t.ni_name
| None -> assert false)
| None -> Ast_utils.generated_ivar_name pname) in
(* update property info with proper ivar name *)
Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, Some ivar);
Printing.log_out "Updated property table by adding ivar name for property pname '%s'\n" pname;
Some (qt', ivar)
with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname;
None) in
let qt', atts, di, getter, setter, _ = Property.find_property curr_class pname in
let ivar = (match property_impl_decl_info.Clang_ast_t.opidi_ivar_decl with
| Some dr -> (match dr.Clang_ast_t.dr_name with
| Some name_info -> name_info.Clang_ast_t.ni_name
| None -> assert false)
| None -> Ast_utils.generated_ivar_name pname) in
(* update property info with proper ivar name *)
Property.replace_property (curr_class, pname) (qt', atts, di, getter, setter, Some ivar);
Printing.log_out "Updated property table by adding ivar name for property pname '%s'\n" pname;
Some (qt', ivar)
with Not_found -> L.err "Property '%s' not found in the table. Ivar not updated and qual_type not found.@." pname;
None) in
match property_impl_decl_info.Clang_ast_t.opidi_implementation, res with
| `Dynamic, Some (qt, ivar) ->
(* For Dynamic property we need to create the ObjCIvarDecl which specifies*)
(* the field of the property. In case of Dynamic this is not in the AST.*)
(* Once created the ObjCIvarDecl then we treat the property as synthesized *)
(* For Dynamic property we need to create the ObjCIvarDecl which specifies*)
(* the field of the property. In case of Dynamic this is not in the AST.*)
(* Once created the ObjCIvarDecl then we treat the property as synthesized *)
[Ast_expressions.make_objc_ivar_decl decl_info qt property_impl_decl_info ivar]
| _ ->
(* No names of fields/method to collect from ObjCPropertyImplDecl when Synthesized *)
(* No names of fields/method to collect from ObjCPropertyImplDecl when Synthesized *)
[]
(*NOTE: Assumption: if there is a getter or a setter defined manually, *)
@ -258,8 +258,8 @@ let is_property_read_only attributes =
let get_memory_management_attribute attributes =
let memory_management_attributes = Ast_utils.get_memory_management_attributes () in
try Some (list_find (
fun att -> list_mem (Ast_utils.property_attribute_eq)
att memory_management_attributes) attributes)
fun att -> list_mem (Ast_utils.property_attribute_eq)
att memory_management_attributes) attributes)
with Not_found -> None
let create_generated_method_name name_info =
@ -287,7 +287,7 @@ let make_getter curr_class prop_name prop_type =
Property.replace_property
(curr_class, prop_name)
(qt, attributes, decl_info,
(getter_name, Some (ObjCMethodDecl(di, name_info, mdi), true)), (setter_name, setter), Some ivar_name);
(getter_name, Some (ObjCMethodDecl(di, name_info, mdi), true)), (setter_name, setter), Some ivar_name);
[ObjCMethodDecl(dummy_info, generated_name_info, mdi')]
| _ -> []
@ -332,8 +332,8 @@ let make_setter curr_class prop_name prop_type =
Property.replace_property
(curr_class, prop_name)
(qt, attributes, decl_info,
(getter_name, getter),
(setter_name, Some (ObjCMethodDecl(di, name, mdi), true)), Some ivar_name);
(getter_name, getter),
(setter_name, Some (ObjCMethodDecl(di, name, mdi), true)), Some ivar_name);
[ObjCMethodDecl(dummy_info, name_generated, mdi')]
| _ -> []
@ -351,15 +351,15 @@ let make_getter_setter curr_class decl_info prop_name =
try
Property.find_property curr_class prop_name
with _ ->
Printing.log_out "Property %s not found@." prop_name;
assert false in
Printing.log_out "Property %s not found@." prop_name;
assert false in
(make_getter curr_class prop_name prop_type)@ (make_setter curr_class prop_name prop_type)
let add_properties_to_table curr_class decl_list =
let add_property_to_table dec =
match dec with
| ObjCPropertyDecl(decl_info, name_info, pdi) ->
(* Property declaration register the property on the property table to be *)
(* Property declaration register the property on the property table to be *)
let pname = name_info.Clang_ast_t.ni_name in
Printing.log_out "ADDING: ObjCPropertyDecl for property '%s' " pname;
Printing.log_out " pointer= '%s' \n" decl_info.Clang_ast_t.di_pointer;

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

@ -37,28 +37,28 @@ let android_lifecycles =
let android_app = "android.app" in
let fragment_lifecycle =
["onInflate"; "onAttach"; "onCreate"; "onCreateView"; "onViewCreated"; "onActivityCreated";
"onViewStateRestored"; "onStart"; "onResume"; "onPause"; "onSaveInstanceState"; "onStop";
on_destroy_view; on_destroy; "onDetach"] in
"onViewStateRestored"; "onStart"; "onResume"; "onPause"; "onSaveInstanceState"; "onStop";
on_destroy_view; on_destroy; "onDetach"] in
[ (android_content,
"ContentProvider",
["onCreate"]);
(android_app,
"Activity",
["onCreate"; "onStart"; "onRestoreInstanceState"; "onPostCreate"; "onResume"; "onPostResume";
"onCreateDescription"; "onSaveInstanceState"; "onPause"; "onStop"; on_destroy]);
(android_app,
"Service",
["onCreate"; "onStart"; "onStartCommand"; "onBind"; "onUnbind"; on_destroy]);
(android_content,
"BroadcastReceiever",
["onReceive"]);
(android_app,
"Fragment",
fragment_lifecycle);
(* this is the pre-Android 3.0 Fragment type (can also be used post-3.0) *)
("android.support.v4.app",
"Fragment",
fragment_lifecycle);
"ContentProvider",
["onCreate"]);
(android_app,
"Activity",
["onCreate"; "onStart"; "onRestoreInstanceState"; "onPostCreate"; "onResume"; "onPostResume";
"onCreateDescription"; "onSaveInstanceState"; "onPause"; "onStop"; on_destroy]);
(android_app,
"Service",
["onCreate"; "onStart"; "onStartCommand"; "onBind"; "onUnbind"; on_destroy]);
(android_content,
"BroadcastReceiever",
["onReceive"]);
(android_app,
"Fragment",
fragment_lifecycle);
(* this is the pre-Android 3.0 Fragment type (can also be used post-3.0) *)
("android.support.v4.app",
"Fragment",
fragment_lifecycle);
]
let android_callbacks =
@ -244,10 +244,10 @@ let android_callbacks =
("android.widget", "TextView$OnEditorActionListener");
("android.widget", "TimePicker$OnTimeChangedListener");
("android.widget", "ZoomButtonsController$OnZoomListener");
] in
] in
list_fold_left (fun cbSet (pkg, clazz) ->
let qualified_name = Mangled.from_string (pkg ^ "." ^ clazz) in
Mangled.MangledSet.add qualified_name cbSet) Mangled.MangledSet.empty cb_strs
let qualified_name = Mangled.from_string (pkg ^ "." ^ clazz) in
Mangled.MangledSet.add qualified_name cbSet) Mangled.MangledSet.empty cb_strs
(** return the complete set of superclasses of [typ *)
(* TODO (t4644852): factor out subtyping functions into some sort of JavaUtil module *)
@ -274,9 +274,9 @@ let is_callback_class_name class_name = Mangled.MangledSet.mem class_name androi
let is_callback_class typ tenv =
let supertyps = get_all_supertypes typ tenv in
TypSet.exists (fun typ -> match typ with
| Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _) ->
is_callback_class_name classname
| _ -> false) supertyps
| Sil.Tstruct (_, _, Sil.Class, Some classname, _, _, _) ->
is_callback_class_name classname
| _ -> false) supertyps
(** return true if [typ] is a subclass of [lifecycle_typ] *)
let typ_is_lifecycle_typ typ lifecycle_typ tenv =
@ -289,24 +289,24 @@ let is_android_lib_class class_name =
string_is_prefix "android" class_str || string_is_prefix "com.android" class_str
(** returns an option containing the var name and type of a callback registered by [procname], None
if no callback is registered *)
if no callback is registered *)
let get_callback_registered_by procname args tenv =
(* TODO (t4565077): this check should be replaced with a membership check in a hardcoded list of
* Android callback registration methods *)
* Android callback registration methods *)
(* for now, we assume a method is a callback registration method if it is a setter and has a
* callback class as a non - receiver argument *)
* callback class as a non - receiver argument *)
let is_callback_register_like =
let has_non_this_callback_arg args = list_length args > 1 in
let has_registery_name procname =
Procname.is_java procname && (PatternMatch.is_setter procname ||
is_known_callback_register_method (Procname.java_get_method procname)) in
is_known_callback_register_method (Procname.java_get_method procname)) in
has_registery_name procname && has_non_this_callback_arg args in
let is_ptr_to_callback_class typ tenv = match typ with
| Sil.Tptr (typ, Sil.Pk_pointer) -> is_callback_class typ tenv
| _ -> false in
if is_callback_register_like then
(* we don't want to check if the receiver is a callback class; it's one of the method arguments
* that's being registered as a callback *)
* that's being registered as a callback *)
let get_non_this_args args = list_tl args in
try
Some (list_find (fun (_, typ) -> is_ptr_to_callback_class typ tenv) (get_non_this_args args))
@ -332,20 +332,20 @@ let is_callback_register_method procname args tenv =
| None -> false
(** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity) and
a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *)
a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *)
let get_lifecycle_for_framework_typ_opt lifecycle_typ lifecycle_proc_strs tenv =
match Sil.get_typ lifecycle_typ None tenv with
| Some (Sil.Tstruct(_, _, Sil.Class, Some class_name, _, decl_procs, _) as lifecycle_typ) ->
(* TODO (t4645631): collect the procedures for which is_java is returning false *)
(* TODO (t4645631): collect the procedures for which is_java is returning false *)
let lookup_proc lifecycle_proc =
list_find (fun decl_proc ->
Procname.is_java decl_proc && lifecycle_proc = Procname.java_get_method decl_proc
Procname.is_java decl_proc && lifecycle_proc = Procname.java_get_method decl_proc
) decl_procs in
(* convert each of the framework lifecycle proc strings to a lifecycle method procname *)
let lifecycle_procs =
list_fold_left (fun lifecycle_procs lifecycle_proc_str ->
try (lookup_proc lifecycle_proc_str) :: lifecycle_procs
with Not_found -> lifecycle_procs)
try (lookup_proc lifecycle_proc_str) :: lifecycle_procs
with Not_found -> lifecycle_procs)
[] lifecycle_proc_strs in
Some (lifecycle_typ, lifecycle_procs)
| _ -> None

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

@ -15,8 +15,8 @@ open Utils
(** Automatically create a harness method to exercise code under test *)
(** given a list [lst] = fst @ (e :: rest), a test predicate [test], and a list [to_insert], returns
the list fst @ (e :: to_insert) @ rest, where e is the first element such that test(e) evaluates
to true. if test(e) does not evaluate to true for any element of the list, returns [lst]. *)
the list fst @ (e :: to_insert) @ rest, where e is the first element such that test(e) evaluates
to true. if test(e) does not evaluate to true for any element of the list, returns [lst]. *)
let insert_after lst test to_insert =
let rec insert_rec to_process processed = match to_process with
| instr :: to_process ->
@ -29,10 +29,10 @@ let insert_after lst test to_insert =
insert_rec lst []
(** find callees that register callbacks and add instrumentation to extract the callback.
return the set of new global static fields created to extract callbacks and their types *)
return the set of new global static fields created to extract callbacks and their types *)
let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callback_fields =
(* try to turn a nasty callback name like MyActivity$1 into a nice callback name like
* Button.OnClickListener[line 7]*)
* Button.OnClickListener[line 7]*)
let create_descriptive_callback_name callback_typ loc =
let typ_str = match PatternMatch.type_get_class_name callback_typ with
| Some mangled -> Mangled.get_mangled mangled
@ -41,11 +41,11 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb
if Procname.is_anonymous_inner_class_name typ_str then
match PatternMatch.type_get_direct_supertypes callback_typ with
| [] ->
(* this should never happen since an inner class always has a supertype *)
(* this should never happen since an inner class always has a supertype *)
assert false
| l ->
(* choose to describe this anonymous inner class with one of the interfaces that it
* implements. translation always places interfaces at the end of the supertypes list *)
(* choose to describe this anonymous inner class with one of the interfaces that it
* implements. translation always places interfaces at the end of the supertypes list *)
Mangled.get_mangled (list_hd (list_rev l))
else typ_str in
Mangled.from_string (pretty_typ_str ^ "[line " ^ Sil.loc_to_string loc ^ "]") in
@ -57,13 +57,13 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb
let callback_fld_name = create_descriptive_callback_name ptr_to_cb_typ loc in
let created_fld = Ident.create_fieldname callback_fld_name 0 in
(* create a function that takes the type of the harness class as an argument and modifies
* the instruction set with callback extraction code. we do this because we need to know
* the typ of the harness class before we can write to any of its fields, but we cannot
* actually create this typ until we know how many fields we are going to create in order
* to extract callbacks *)
* the instruction set with callback extraction code. we do this because we need to know
* the typ of the harness class before we can write to any of its fields, but we cannot
* actually create this typ until we know how many fields we are going to create in order
* to extract callbacks *)
let mk_field_write harness_class_typ =
(* create an instruction that writes the registered callback object to a global static
* field in the harness class *)
* field in the harness class *)
let fld_write_lhs = Sil.Lfield (harness_lvar, created_fld, harness_class_typ) in
let extract_cb_instr = Sil.Set (fld_write_lhs, cb_typ, cb_obj, loc) in
let instrumented_instrs =
@ -80,52 +80,52 @@ let extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar callb
(** find all of the callbacks registered by methods in [lifecycle_trace *)
let find_registered_callbacks lifecycle_trace harness_name proc_file_map tenv =
(* what would be ideal to do here is to go through every method (transitively) called by a
* lifecycle method and look for registered callbacks, however, this would need to be a complex
* iterative process, as detecting callbacks can lead to more methods being called, which in
* turn can lead to more callbacks being registered. so what we do here is iterate through each
* file that a lifecycle proc is defined in and collect all callbacks possibly registered in
* methods in that file. this can err on the side of including too many callbacks (for example, if
* a callback is registered in a superclass method that is overridden, this scheme would
* wrongly include it). on the other hand, this will miss callbacks registered in
* callees of lifecycle methods that aren't in our list of "lifecycle methods files" *)
* lifecycle method and look for registered callbacks, however, this would need to be a complex
* iterative process, as detecting callbacks can lead to more methods being called, which in
* turn can lead to more callbacks being registered. so what we do here is iterate through each
* file that a lifecycle proc is defined in and collect all callbacks possibly registered in
* methods in that file. this can err on the side of including too many callbacks (for example, if
* a callback is registered in a superclass method that is overridden, this scheme would
* wrongly include it). on the other hand, this will miss callbacks registered in
* callees of lifecycle methods that aren't in our list of "lifecycle methods files" *)
(* TODO (t4793988): do something more principled here *)
let harness_lvar = Sil.Lvar (Sil.mk_pvar_global harness_name) in
let lifecycle_cfg_files =
list_fold_left (fun lifecycle_files (lifecycle_proc, _) ->
try
let cfg_fname =
let source_dir = Inhabit.source_dir_from_name lifecycle_proc proc_file_map in
DB.source_dir_get_internal_file source_dir ".cfg" in
DB.FilenameSet.add cfg_fname lifecycle_files
with Not_found -> lifecycle_files
try
let cfg_fname =
let source_dir = Inhabit.source_dir_from_name lifecycle_proc proc_file_map in
DB.source_dir_get_internal_file source_dir ".cfg" in
DB.FilenameSet.add cfg_fname lifecycle_files
with Not_found -> lifecycle_files
) DB.FilenameSet.empty lifecycle_trace in
DB.FilenameSet.fold (fun cfg_file registered_callbacks ->
match Cfg.load_cfg_from_file cfg_file with
| Some cfg ->
list_fold_left (fun registered_callbacks procdesc ->
extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar registered_callbacks
) registered_callbacks (Cfg.get_all_procs cfg)
| None -> registered_callbacks
match Cfg.load_cfg_from_file cfg_file with
| Some cfg ->
list_fold_left (fun registered_callbacks procdesc ->
extract_callbacks procdesc cfg_file cfg tenv harness_name harness_lvar registered_callbacks
) registered_callbacks (Cfg.get_all_procs cfg)
| None -> registered_callbacks
) lifecycle_cfg_files []
(** if [typ] is a lifecycle type, generate a list of (method call, receiver) pairs constituting a
lifecycle trace *)
lifecycle trace *)
let try_create_lifecycle_trace typ lifecycle_typ lifecycle_procs proc_file_map tenv = match typ with
| Sil.Tstruct(_, _, Sil.Class, Some class_name, _, methods, _)
when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv &&
not (AndroidFramework.is_android_lib_class class_name) ->
when AndroidFramework.typ_is_lifecycle_typ typ lifecycle_typ tenv &&
not (AndroidFramework.is_android_lib_class class_name) ->
let ptr_to_typ = Some (Sil.Tptr (typ, Sil.Pk_pointer)) in
list_fold_left (fun trace lifecycle_proc ->
(* given a lifecycle subclass T, resolve the call T.lifecycle_proc() to the procname
* that will actually be called at runtime *)
let resolved_proc = SymExec.resolve_method tenv class_name lifecycle_proc in
(resolved_proc, ptr_to_typ) :: trace
* that will actually be called at runtime *)
let resolved_proc = SymExec.resolve_method tenv class_name lifecycle_proc in
(resolved_proc, ptr_to_typ) :: trace
) [] lifecycle_procs
| _ -> []
(** get all the callbacks registered in [lifecycle_trace], transform the SIL to "extract" them into
global static fields belong to the harness so that they are easily callable, and return a list
of the (field, typ) pairs that we have created for this purpose *)
global static fields belong to the harness so that they are easily callable, and return a list
of the (field, typ) pairs that we have created for this purpose *)
let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let harness_name = Mangled.from_string (Procname.to_string harness_procname) in
let registered_cbs =
@ -135,14 +135,14 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
let harness_typ =
Sil.Tstruct (fields, [], Sil.Class, Some harness_name, [], [harness_procname], []) in
(* update the tenv with our created harness typ. we don't have to save the tenv to disk here
* because this is done immediately after harness generation runs in jMain.ml *)
* because this is done immediately after harness generation runs in jMain.ml *)
let harness_class = Sil.TN_csu (Sil.Class, harness_name) in
Sil.tenv_add tenv harness_class harness_typ;
let cfgs_to_save =
list_fold_left (fun cfgs_to_save (_, _, instrument_sil_f) ->
(* instrument the cfg's with callback extraction code *)
let (cfg_file, cfg) = instrument_sil_f harness_typ in
DB.FilenameMap.add cfg_file cfg cfgs_to_save
let (cfg_file, cfg) = instrument_sil_f harness_typ in
DB.FilenameMap.add cfg_file cfg cfgs_to_save
) DB.FilenameMap.empty registered_cbs in
(* re-save the cfgs that we've modified by extracting callbacks *)
DB.FilenameMap.iter
@ -154,26 +154,26 @@ let extract_callbacks lifecycle_trace harness_procname proc_file_map tenv =
(** generate a harness for each lifecycle type in an Android application *)
let create_android_harness proc_file_map tenv =
list_iter (fun (pkg, clazz, lifecycle_methods) ->
let typ_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt typ_name lifecycle_methods tenv with
| Some (framework_typ, framework_procs) ->
let typ_name = Mangled.from_package_class pkg clazz in
match AndroidFramework.get_lifecycle_for_framework_typ_opt typ_name lifecycle_methods tenv with
| Some (framework_typ, framework_procs) ->
(* 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
| [] -> ()
| lifecycle_trace ->
(* we have identified an application lifecycle type and created a trace for it. now,
* identify the callbacks registered by methods belonging to this type and get the
* inhabitation module to create a harness for us *)
let harness_procname =
let harness_cls_name = PatternMatch.get_type_name typ in
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
) tenv
| None -> ()
* [lifecycle_typ] *)
Sil.tenv_iter (fun _ typ ->
match try_create_lifecycle_trace typ framework_typ framework_procs proc_file_map tenv with
| [] -> ()
| lifecycle_trace ->
(* we have identified an application lifecycle type and created a trace for it. now,
* identify the callbacks registered by methods belonging to this type and get the
* inhabitation module to create a harness for us *)
let harness_procname =
let harness_cls_name = PatternMatch.get_type_name typ in
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
) tenv
| None -> ()
) AndroidFramework.get_lifecycles
let parse_trace trace = Stacktrace.parse_stack_trace trace

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

@ -8,7 +8,7 @@
*)
(** Generate a procedure that calls a given sequence of methods. Useful for harness/test
* generation. *)
* generation. *)
module L = Logging
module F = Format
@ -22,14 +22,14 @@ type lifecycle_trace = (Procname.t * Sil.typ option) list
type callback_trace = (Sil.exp * Sil.typ) list
(** list of instrs and temporary variables created during inhabitation and a cache of types that
* have already been inhabited *)
* have already been inhabited *)
type env = { instrs : Sil.instr list;
tmp_vars : Ident.t list;
cache : Sil.exp TypMap.t;
(* set of types currently being inhabited. consult to prevent infinite recursion *)
cur_inhabiting : TypSet.t;
pc : Sil.location;
harness_name : Procname.t }
tmp_vars : Ident.t list;
cache : Sil.exp TypMap.t;
(* set of types currently being inhabited. consult to prevent infinite recursion *)
cur_inhabiting : TypSet.t;
pc : Sil.location;
harness_name : Procname.t }
(** add an instruction to the env, update tmp_vars, and bump the pc *)
let env_add_instr instr tmp_vars env =
@ -84,8 +84,8 @@ let tl_or_empty l = if l = [] then l else list_tl l
let get_non_receiver_formals formals = tl_or_empty formals
(** create Sil corresponding to x = new typ() or x = new typ[]. For ordinary allocation, sizeof_typ
* and ret_typ should be the same, but arrays are slightly odd in that sizeof_typ will have a size
* component but the size component of ret_typ is always -1. *)
* and ret_typ should be the same, but arrays are slightly odd in that sizeof_typ will have a size
* component but the size component of ret_typ is always -1. *)
let inhabit_alloc sizeof_typ ret_typ alloc_kind env =
let retval = Ident.create_fresh Ident.knormal in
let inhabited_exp = Sil.Var retval in
@ -100,59 +100,59 @@ let inhabit_alloc sizeof_typ ret_typ alloc_kind env =
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) ->
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
| Sil.Tptr (typ, Sil.Pk_pointer) as ptr_to_typ ->
(* TODO (t4575417): this case does not work correctly for enums, but they are currently
* broken in Infer anyway (see t4592290) *)
let (allocated_obj_exp, env) = inhabit_alloc typ typ SymExec.ModelBuiltins.__new env in
(* select methods that are constructors and won't force us into infinite recursion because
* we are already inhabiting one of their argument types *)
let get_all_suitable_constructors typ = match typ with
| Sil.Tstruct (_, _, Sil.Class, _, superclasses, methods, _) ->
let is_suitable_constructor p =
let try_get_non_receiver_formals p =
try get_non_receiver_formals (formals_from_name p proc_file_map)
with Not_found -> [] in
Procname.is_constructor p && list_for_all (fun (_, typ) ->
not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in
list_filter (fun p -> is_suitable_constructor p) methods
| _ -> [] in
let (env, typ_class_name) = match get_all_suitable_constructors typ with
| constructor :: _ ->
(* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to
* nondeterministically call all possible constructors instead *)
let env =
inhabit_constructor constructor (allocated_obj_exp, ptr_to_typ) proc_file_map env in
(* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we
* we can use it as a descriptive local variable name in the harness *)
let typ_class_name =
if Procname.is_java constructor then Procname.java_get_simple_class constructor
else create_fresh_local_name () in
(env, Mangled.from_string typ_class_name)
| [] -> (env, Mangled.from_string (create_fresh_local_name ())) in
(* add the instructions *& local = [allocated_obj_exp]; id = *& local, where local and id are
* both fresh. the only point of this is to add a descriptive local name that makes error
* reports from the harness look nicer -- it's not necessary to make symbolic execution work *)
let fresh_local_exp = Sil.Lvar (Sil.mk_pvar typ_class_name env.harness_name) in
let write_to_local_instr =
Sil.Set (fresh_local_exp, ptr_to_typ, allocated_obj_exp, env.pc) in
let env' = env_add_instr write_to_local_instr [] env in
let fresh_id = Ident.create_fresh Ident.knormal in
let read_from_local_instr = Sil.Letderef (fresh_id, fresh_local_exp, ptr_to_typ, env'.pc) in
(Sil.Var fresh_id, env_add_instr read_from_local_instr [fresh_id] env')
| Sil.Tint (_) -> (Sil.Const (Sil.Cint (Sil.Int.zero)), env)
| Sil.Tfloat (_) -> (Sil.Const (Sil.Cfloat 0.0), env)
| typ ->
L.err "Couldn't inhabit typ: %a@." (Sil.pp_typ pe_text) typ;
assert false in
let (inhabited_exp, env') =
inhabit_internal typ { env with cur_inhabiting = TypSet.add typ env.cur_inhabiting } in
(inhabited_exp, { env' with cache = TypMap.add typ inhabited_exp env.cache;
cur_inhabiting = env.cur_inhabiting })
let inhabit_internal typ env = match typ with
| Sil.Tptr (Sil.Tarray (inner_typ, Sil.Const (Sil.Cint size)), 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
| Sil.Tptr (typ, Sil.Pk_pointer) as ptr_to_typ ->
(* TODO (t4575417): this case does not work correctly for enums, but they are currently
* broken in Infer anyway (see t4592290) *)
let (allocated_obj_exp, env) = inhabit_alloc typ typ SymExec.ModelBuiltins.__new env in
(* select methods that are constructors and won't force us into infinite recursion because
* we are already inhabiting one of their argument types *)
let get_all_suitable_constructors typ = match typ with
| Sil.Tstruct (_, _, Sil.Class, _, superclasses, methods, _) ->
let is_suitable_constructor p =
let try_get_non_receiver_formals p =
try get_non_receiver_formals (formals_from_name p proc_file_map)
with Not_found -> [] in
Procname.is_constructor p && list_for_all (fun (_, typ) ->
not (TypSet.mem typ env.cur_inhabiting)) (try_get_non_receiver_formals p) in
list_filter (fun p -> is_suitable_constructor p) methods
| _ -> [] in
let (env, typ_class_name) = match get_all_suitable_constructors typ with
| constructor :: _ ->
(* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to
* nondeterministically call all possible constructors instead *)
let env =
inhabit_constructor constructor (allocated_obj_exp, ptr_to_typ) proc_file_map env in
(* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we
* we can use it as a descriptive local variable name in the harness *)
let typ_class_name =
if Procname.is_java constructor then Procname.java_get_simple_class constructor
else create_fresh_local_name () in
(env, Mangled.from_string typ_class_name)
| [] -> (env, Mangled.from_string (create_fresh_local_name ())) in
(* add the instructions *& local = [allocated_obj_exp]; id = *& local, where local and id are
* both fresh. the only point of this is to add a descriptive local name that makes error
* reports from the harness look nicer -- it's not necessary to make symbolic execution work *)
let fresh_local_exp = Sil.Lvar (Sil.mk_pvar typ_class_name env.harness_name) in
let write_to_local_instr =
Sil.Set (fresh_local_exp, ptr_to_typ, allocated_obj_exp, env.pc) in
let env' = env_add_instr write_to_local_instr [] env in
let fresh_id = Ident.create_fresh Ident.knormal in
let read_from_local_instr = Sil.Letderef (fresh_id, fresh_local_exp, ptr_to_typ, env'.pc) in
(Sil.Var fresh_id, env_add_instr read_from_local_instr [fresh_id] env')
| Sil.Tint (_) -> (Sil.Const (Sil.Cint (Sil.Int.zero)), env)
| Sil.Tfloat (_) -> (Sil.Const (Sil.Cfloat 0.0), env)
| typ ->
L.err "Couldn't inhabit typ: %a@." (Sil.pp_typ pe_text) typ;
assert false in
let (inhabited_exp, env') =
inhabit_internal typ { env with cur_inhabiting = TypSet.add typ env.cur_inhabiting } in
(inhabited_exp, { env' with cache = TypMap.add typ inhabited_exp env.cache;
cur_inhabiting = env.cur_inhabiting })
(** inhabit each of the types in the formals list *)
and inhabit_args formals proc_file_map env =
@ -162,11 +162,11 @@ and inhabit_args formals proc_file_map env =
list_fold_right inhabit_arg formals ([], env)
(** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the
* remaining arguments *)
* remaining arguments *)
and inhabit_constructor constr_name (allocated_obj, obj_type) proc_file_map env =
try
(* this lookup can fail when we try to get the procdesc of a procedure from a different
* module. this could be solved with a whole - program class hierarchy analysis *)
(* this lookup can fail when we try to get the procdesc of a procedure from a different
* module. this could be solved with a whole - program class hierarchy analysis *)
let (args, env) =
let non_receiver_formals = tl_or_empty (formals_from_name constr_name proc_file_map) in
inhabit_args non_receiver_formals proc_file_map env in
@ -219,12 +219,12 @@ let inhabit_fld_trace flds proc_file_map env =
inhabit_args (tl_or_empty formals) proc_file_map env in
inhabit_call_with_args procname procdesc ((Sil.Var lhs, fld_typ) :: args) env
with Not_found ->
(* TODO (t4645631): investigate why this failure occurs *)
env in
(* TODO (t4645631): investigate why this failure occurs *)
env in
list_fold_left (fun env procname ->
if not (Procname.is_constructor procname) &&
not (Procname.java_is_access_method procname) then inhabit_cb_call procname env
else env) env procs
if not (Procname.is_constructor procname) &&
not (Procname.java_is_access_method procname) then inhabit_cb_call procname env
else env) env procs
| _ -> assert false in
list_fold_left (fun env fld -> invoke_cb fld env) env flds
@ -247,10 +247,10 @@ let write_harness_to_file harness_instrs harness_file =
let harness_file_name = DB.source_file_to_string harness_file in
ref (create_outfile harness_file_name) in
let pp_harness fmt = list_iter (fun instr ->
Format.fprintf fmt "%a\n" (Sil.pp_instr pe_text) instr) harness_instrs in
Format.fprintf fmt "%a\n" (Sil.pp_instr pe_text) instr) harness_instrs in
do_outf harness_file (fun outf ->
pp_harness outf.fmt;
close_outf outf)
pp_harness outf.fmt;
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 =
@ -272,7 +272,7 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
let array_typ_size = Sil.exp_get_undefined false in
Sil.Tptr (Sil.Tarray (lookup_typ stripped_typ, array_typ_size), Sil.Pk_pointer)
| _ ->
(* non-primitive/non-array type--resolve it in the tenv *)
(* non-primitive/non-array type--resolve it in the tenv *)
match Sil.get_typ (Mangled.from_string typ_str) None tenv with
| Some typ -> typ
| None -> failwith ("Failed to look up typ " ^ typ_str) in
@ -295,30 +295,30 @@ let add_harness_to_cg harness_name harness_cfg harness_node loc cg tenv =
Sil.is_generated = false;
} in
create {
cfg = harness_cfg;
name = procname;
is_defined = false;
ret_type = return_typ;
formals = params;
locals = [];
captured = [];
loc = loc;
proc_attributes = proc_attributes;
} in
cfg = harness_cfg;
name = procname;
is_defined = false;
ret_type = return_typ;
formals = params;
locals = [];
captured = [];
loc = loc;
proc_attributes = proc_attributes;
} in
list_iter (fun p ->
(* add harness -> callee edge to the call graph *)
Cg.add_edge cg harness_name p;
(* create dummy procdescs for callees not in the module. hopefully t4583729 will remove the
* need to do this in the future *)
if not (SymExec.function_is_builtin p) then
(* simulate symbolic execution's lookup of a procedure *)
match Cfg.Procdesc.find_from_name harness_cfg p with
| Some _ -> ()
| None -> ignore (create_dummy_procdesc p)
Cg.add_edge cg harness_name p;
(* create dummy procdescs for callees not in the module. hopefully t4583729 will remove the
* need to do this in the future *)
if not (SymExec.function_is_builtin p) then
(* simulate symbolic execution's lookup of a procedure *)
match Cfg.Procdesc.find_from_name harness_cfg p with
| Some _ -> ()
| None -> ignore (create_dummy_procdesc 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 *)
* proc to the cg *)
let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv =
(* TMP: pick an arbitrary cg and cfg to piggyback the harness code onto *)
(* TODO (t4707171): create our own fresh cfg / cg instead *)
@ -347,16 +347,16 @@ let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv =
Sil.is_generated = false;
} in
create {
cfg = harness_cfg;
name = harness_name;
is_defined = true;
ret_type = Sil.Tvoid;
formals = [];
locals = [];
captured = [];
loc = env.pc;
proc_attributes = proc_attributes;
} in
cfg = harness_cfg;
name = harness_name;
is_defined = true;
ret_type = Sil.Tvoid;
formals = [];
locals = [];
captured = [];
loc = env.pc;
proc_attributes = proc_attributes;
} in
let harness_node =
(* important to reverse the list or there will be scoping issues! *)
let instrs = (list_rev env.instrs) in
@ -380,7 +380,7 @@ let setup_harness_cfg harness_name harness_cfg env proc_file_map tenv =
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 *)
* order with the specified receiver and add it to the execution environment *)
let inhabit_trace trace cb_flds harness_name proc_file_map tenv = if list_length trace > 0 then
let harness_cfg = Cfg.Node.create_cfg () in
let harness_file = create_dummy_harness_file harness_name harness_cfg tenv in

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

@ -32,7 +32,7 @@ type stack_frame =
| Unresolved of str_frame
(** list representation of a stack trace. head of the list is the top of the stack (line/proc where
exception occurs *)
exception occurs *)
type stack_trace = stack_frame list
(** given [str_frame], try to resolve its components in [exe_env] *)
@ -40,8 +40,8 @@ let try_resolve_frame str_frame exe_env tenv =
try
let class_name = Mangled.from_string str_frame.class_str in
(* find the class name in the tenv and get the procedure(s) whose names match the procedure name
* in the stack trace. Note that the stack trace does not have any type or argument information;
* the name is all that we have to go on *)
* in the stack trace. Note that the stack trace does not have any type or argument information;
* the name is all that we have to go on *)
match Sil.tenv_lookup tenv (Sil.TN_csu (Sil.Class, class_name)) with
| Some Sil.Tstruct (_, _, Sil.Class, _, _, decl_procs, _) ->
let possible_calls =
@ -53,13 +53,13 @@ let try_resolve_frame str_frame exe_env tenv =
* same file, which will be true in Java but not necessarily in other languages *)
let file_name = Exe_env.get_source exe_env (list_hd possible_calls) in
Resolved
{ possible_calls = possible_calls; file_name = file_name; line_num = str_frame.line_num; }
{ possible_calls = possible_calls; file_name = file_name; line_num = str_frame.line_num; }
else Unresolved str_frame
| _ -> Unresolved str_frame
with Not_found -> Unresolved str_frame
(** given a stack trace line like "at com.foo.Class.method(Class.java:42)" extract the class name,
method name, file name, and line number *)
method name, file name, and line number *)
let parse_frame frame_str exe_env tenv =
(* separate the qualified method name and the parenthesized text/line number*)
ignore(Str.string_match (Str.regexp "at \\(.*\\)(\\(.*\\))") frame_str 0);

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

@ -149,14 +149,14 @@ let lookup_node cn (program: program) =
try
Some (JBasics.ClassMap.find cn (get_classmap program))
with Not_found ->
try
let jclass = Javalib.get_class (get_classpath program) cn in
add_class cn jclass program;
Some jclass
with
| JBasics.No_class_found _
| JBasics.Class_structure_error _
| Invalid_argument _ -> None
try
let jclass = Javalib.get_class (get_classpath program) cn in
add_class cn jclass program;
Some jclass
with
| JBasics.No_class_found _
| JBasics.Class_structure_error _
| Invalid_argument _ -> None
let classname_of_class_filename class_filename =

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

@ -81,11 +81,11 @@ let get_or_set_pvar_type context var typ =
else set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map);
(pvar, typ)
with Not_found ->
let procname = (Cfg.Procdesc.get_proc_name (get_procdesc context)) in
let varname = Mangled.from_string (JBir.var_name_g var) in
let pvar = Sil.mk_pvar varname procname in
set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map);
(pvar, typ)
let procname = (Cfg.Procdesc.get_proc_name (get_procdesc context)) in
let varname = Mangled.from_string (JBir.var_name_g var) in
let pvar = Sil.mk_pvar varname procname in
set_var_map context (JBir.VarMap.add var (pvar, typ, typ) var_map);
(pvar, typ)
let lookup_pvar_type context var typ = (get_or_set_pvar_type context var typ)
@ -95,7 +95,7 @@ let reset_pvar_type context =
let var_map = get_var_map context in
let aux var item =
match item with (pvar, otyp, typ) ->
set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in
set_var_map context (JBir.VarMap.add var (pvar, otyp, otyp) var_map) in
JBir.VarMap.iter aux var_map
let get_var_type context var =

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

@ -73,13 +73,13 @@ let add_cmethod never_null_matcher program icfg node cm is_static =
let cn, ms = JBasics.cms_split cm.Javalib.cm_class_method_signature in
let is_clinit = JBasics.ms_equal ms JBasics.clinit_signature in
if !JTrans.no_static_final = false
&& is_clinit
&& not (JTransStaticField.has_static_final_fields node) then
&& is_clinit
&& not (JTransStaticField.has_static_final_fields node) then
JUtils.log "\t\tskipping class initializer: %s@." (JBasics.ms_name ms)
else
match JTrans.get_method_procdesc program cfg tenv cn ms is_static with
| JTrans.Defined procdesc when JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc) ->
(* do not capture the method if there is a model for it *)
(* do not capture the method if there is a model for it *)
JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc));
| JTrans.Defined procdesc ->
let start_node = Cfg.Procdesc.get_start_node procdesc in
@ -112,7 +112,7 @@ let add_amethod program icfg node am is_static =
let cn, ms = JBasics.cms_split am.Javalib.am_class_method_signature in
match JTrans.get_method_procdesc program cfg tenv cn ms is_static with
| JTrans.Defined procdesc when (JClasspath.is_model (Cfg.Procdesc.get_proc_name procdesc)) ->
(* do not capture the method if there is a model for it *)
(* do not capture the method if there is a model for it *)
JUtils.log "Skipping method with a model: %s@." (Procname.to_string (Cfg.Procdesc.get_proc_name procdesc));
| JTrans.Defined procdesc ->
Cg.add_node icfg.JContext.cg (Cfg.Procdesc.get_proc_name procdesc)
@ -150,8 +150,8 @@ let is_classname_cached cn =
Sys.file_exists (path_of_cached_classname cn)
(* Given a source file and a class, translates the code of this class.
In init - mode, finds out whether this class contains initializers at all,
in this case translates it. In standard mode, all methods are translated *)
In init - mode, finds out whether this class contains initializers at all,
in this case translates it. In standard mode, all methods are translated *)
let create_icfg never_null_matcher linereader program icfg source_file cn node =
JUtils.log "\tclassname: %s@." (JBasics.cn_name cn);
cache_classname cn;
@ -160,12 +160,12 @@ let create_icfg never_null_matcher linereader program icfg source_file cn node =
begin
Javalib.m_iter (JTrans.create_local_procdesc program linereader cfg tenv node) node;
Javalib.m_iter (fun m ->
let method_kind = JTransType.get_method_kind m in
match m with
| 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
let method_kind = JTransType.get_method_kind m in
match m with
| 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
) node
end
@ -196,8 +196,8 @@ let should_capture classes source_basename node =
(* Computes the control - flow graph and call - graph of a given source file.
In the standard - mode, it translated all the classes that correspond to this
source file. *)
In the standard - mode, it translated all the classes that correspond to this
source file. *)
let compute_source_icfg
never_null_matcher linereader classes program tenv source_basename source_file =
let icfg =
@ -215,8 +215,8 @@ let compute_source_icfg
let () =
JBasics.ClassMap.iter
(select
(should_capture classes source_basename)
(create_icfg never_null_matcher linereader program icfg source_file))
(should_capture classes source_basename)
(create_icfg never_null_matcher linereader program icfg source_file))
(JClasspath.get_classmap program) in
(icfg.JContext.cg, icfg.JContext.cfg)

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

@ -21,14 +21,14 @@ let arg_desc =
let desc =
(filter base_arg_desc) @
[
"-models", Arg.String (fun filename -> JClasspath.add_models filename), Some "paths", "set the path to the jar containing the models";
"-debug", Arg.Unit (fun () -> JConfig.debug_mode := true), None, "write extra translation information";
"-dependencies", Arg.Unit (fun _ -> JConfig.dependency_mode := true), None, "translate all the dependencies during the capture";
"-no-static_final", Arg.Unit (fun () -> JTrans.no_static_final := true), None, "no special treatment for static final fields";
"-tracing", Arg.Unit (fun () -> JConfig.translate_checks := true), None,
"Translate JVM checks";
"-verbose_out", Arg.String (fun path -> JClasspath.set_verbose_out path), None,
"Set the path to the javac verbose output"
"-models", Arg.String (fun filename -> JClasspath.add_models filename), Some "paths", "set the path to the jar containing the models";
"-debug", Arg.Unit (fun () -> JConfig.debug_mode := true), None, "write extra translation information";
"-dependencies", Arg.Unit (fun _ -> JConfig.dependency_mode := true), None, "translate all the dependencies during the capture";
"-no-static_final", Arg.Unit (fun () -> JTrans.no_static_final := true), None, "no special treatment for static final fields";
"-tracing", Arg.Unit (fun () -> JConfig.translate_checks := true), None,
"Translate JVM checks";
"-verbose_out", Arg.String (fun path -> JClasspath.set_verbose_out path), None,
"Set the path to the javac verbose output"
] in
Arg2.create_options_desc false "Parsing Options" desc in
base_arg
@ -93,7 +93,7 @@ let do_source_file
if JConfig.create_harness then
list_fold_left
(fun proc_file_map pdesc ->
Procname.Map.add (Cfg.Procdesc.get_proc_name pdesc) source_file proc_file_map)
Procname.Map.add (Cfg.Procdesc.get_proc_name pdesc) source_file proc_file_map)
proc_file_map (Cfg.get_all_procs cfg)
else proc_file_map

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

@ -28,8 +28,8 @@ let constr_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap.
let init_loc_map : Sil.location JBasics.ClassMap.t ref = ref JBasics.ClassMap.empty
(** Fix the line associated to a method definition.
Since Sawja often reports a method off by a few lines, we search
backwards for a line where the method name is. *)
Since Sawja often reports a method off by a few lines, we search
backwards for a line where the method name is. *)
let fix_method_definition_line linereader proc_name loc =
let method_name =
if Procname.is_constructor proc_name then
@ -42,7 +42,7 @@ let fix_method_definition_line linereader proc_name loc =
| None -> raise Not_found
| Some line ->
(try ignore (Str.search_forward regex line 0); true
with Not_found -> false) in
with Not_found -> false) in
let line = ref loc.Sil.line in
try
while not (method_is_defined_here !line) do
@ -111,9 +111,9 @@ let get_field_name program static tenv cn fs context =
(fun (fieldname, _, _) -> retrieve_fieldname fieldname = JBasics.fs_name fs)
(if static then sfields else fields)
with Not_found ->
(* TODO: understand why fields cannot be found here *)
JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs);
raise (Frontend_error "Cannot find fieldname") in
(* TODO: understand why fields cannot be found here *)
JUtils.log "cannot find %s.%s@." (JBasics.cn_name cn) (JBasics.fs_name fs);
raise (Frontend_error "Cannot find fieldname") in
fieldname
| _ -> assert false
@ -142,8 +142,8 @@ let formals program tenv cn impl =
list_rev (list_fold_left collect [] (JBir.params impl))
(** Creates the local and formal variables from a procedure based on the
impl argument. If the meth_kind is Init, we add a parameter field to
the initialiser method. *)
impl argument. If the meth_kind is Init, we add a parameter field to
the initialiser method. *)
let locals_formals program tenv cn impl meth_kind =
let form_list =
if meth_kind = JContext.Init then
@ -298,16 +298,16 @@ let create_local_procdesc program linereader cfg tenv node m =
Sil.is_generated = false;
} in
create {
cfg = cfg;
name = procname;
is_defined = true;
ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals;
locals = [];
captured = [];
loc = Sil.dummy_location;
proc_attributes = proc_attributes
} in
cfg = cfg;
name = procname;
is_defined = true;
ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals;
locals = [];
captured = [];
loc = Sil.dummy_location;
proc_attributes = proc_attributes
} in
let start_kind = Cfg.Node.Start_node procdesc in
let start_node = Cfg.Node.create cfg Sil.dummy_location start_kind [] procdesc [] in
let exit_kind = (Cfg.Node.Exit_node procdesc) in
@ -334,16 +334,16 @@ let create_local_procdesc program linereader cfg tenv node m =
Sil.is_generated = false;
} in
create {
cfg = cfg;
name = procname;
is_defined = false;
ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals;
locals = [];
captured = [];
loc = Sil.dummy_location;
proc_attributes = proc_attributes;
} in
cfg = cfg;
name = procname;
is_defined = false;
ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals;
locals = [];
captured = [];
loc = Sil.dummy_location;
proc_attributes = proc_attributes;
} in
()
| Javalib.ConcreteMethod cm ->
let impl = get_implementation cm in
@ -371,16 +371,16 @@ let create_local_procdesc program linereader cfg tenv node m =
Sil.is_generated = false;
} in
create {
cfg = cfg;
name = procname;
is_defined = true;
ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals;
locals = locals;
captured = [];
loc = loc_start;
proc_attributes = proc_attributes;
} in
cfg = cfg;
name = procname;
is_defined = true;
ret_type = JTransType.return_type program tenv ms meth_kind;
formals = formals;
locals = locals;
captured = [];
loc = loc_start;
proc_attributes = proc_attributes;
} in
let start_kind = Cfg.Node.Start_node procdesc in
let start_node = Cfg.Node.create cfg loc_start start_kind [] procdesc [] in
let exit_kind = (Cfg.Node.Exit_node procdesc) in
@ -392,7 +392,7 @@ let create_local_procdesc program linereader cfg tenv node m =
Cfg.Procdesc.set_exit_node procdesc exit_node;
Cfg.Node.add_locals_ret_declaration start_node locals;
with JBir.Subroutine ->
L.err "create_local_procdesc raised JBir.Subroutine on %a@." Procname.pp procname in
L.err "create_local_procdesc raised JBir.Subroutine on %a@." Procname.pp procname in
match lookup_procdesc cfg procname with
| Unknown -> create_new_procdesc ()
| Created defined_status ->
@ -412,31 +412,31 @@ let create_external_procdesc program cfg tenv cn ms method_annotation kind =
let formals = formals_from_signature program tenv cn ms kind in
let procname = JTransType.get_method_procname cn ms kind in
ignore (
let open Cfg.Procdesc in
let proc_attributes =
{
Sil.access = Sil.Default;
Sil.exceptions = [];
Sil.is_abstract = false;
Sil.is_bridge_method = false;
Sil.is_objc_instance_method = false;
Sil.is_synthetic_method = false;
Sil.language = Sil.Java;
Sil.func_attributes = [];
Sil.method_annotation = method_annotation;
Sil.is_generated = false;
} in
create {
cfg = cfg;
name = procname;
is_defined = false;
ret_type = return_type;
formals = formals;
locals = [];
captured = [];
loc = Sil.dummy_location;
proc_attributes = proc_attributes;
})
let open Cfg.Procdesc in
let proc_attributes =
{
Sil.access = Sil.Default;
Sil.exceptions = [];
Sil.is_abstract = false;
Sil.is_bridge_method = false;
Sil.is_objc_instance_method = false;
Sil.is_synthetic_method = false;
Sil.language = Sil.Java;
Sil.func_attributes = [];
Sil.method_annotation = method_annotation;
Sil.is_generated = false;
} in
create {
cfg = cfg;
name = procname;
is_defined = false;
ret_type = return_type;
formals = formals;
locals = [];
captured = [];
loc = Sil.dummy_location;
proc_attributes = proc_attributes;
})
(** returns the procedure description of the given method and creates it if it hasn't been created before *)
let rec get_method_procdesc program cfg tenv cn ms kind =
@ -510,16 +510,16 @@ let rec expression context pc expr =
| JBir.InstanceOf ot | JBir.Cast ot ->
let subtypes =
(match unop with
| JBir.InstanceOf _ -> Sil.Subtype.subtypes_instof
| JBir.Cast _ -> Sil.Subtype.subtypes_cast
| _ -> assert false) in
| JBir.InstanceOf _ -> Sil.Subtype.subtypes_instof
| JBir.Cast _ -> Sil.Subtype.subtypes_cast
| _ -> assert false) in
let sizeof_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)
| _ -> assert false) in
| JBir.InstanceOf ot -> Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof)
| JBir.Cast ot -> 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
let call = Sil.Call([ret_id], builtin, args, loc, Sil.cf_default) in
@ -532,7 +532,7 @@ let rec expression context pc expr =
begin
match binop with
| JBir.ArrayLoad vt ->
(* add an instruction that dereferences the array *)
(* add an instruction that dereferences the array *)
let array_typ = Sil.Tarray(type_of_expr, Sil.Var (Ident.create_fresh Ident.kprimed)) in
let fresh_id, deref_array_instr = create_sil_deref sil_ex1 array_typ loc in
let id = Ident.create_fresh Ident.knormal in
@ -609,7 +609,7 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
match sil_obj_opt with
| None -> ([], [], [])
| Some (sil_obj_expr, sil_obj_type) ->
(* for non-constructors, add an instruction that dereferences the receiver *)
(* for non-constructors, add an instruction that dereferences the receiver *)
let ids, instrs =
let is_non_constructor_call =
match invoke_code with
@ -628,9 +628,9 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
let (idl, instrs, call_args) =
list_fold_left
(fun (idl_accu, instrs_accu, args_accu) expr ->
let (idl, instrs, sil_expr) = expression context pc expr in
let sil_expr_type = JTransType.expr_type context expr in
(idl_accu @ idl, instrs_accu @ instrs, args_accu @ [(sil_expr, sil_expr_type)]))
let (idl, instrs, sil_expr) = expression context pc expr in
let sil_expr_type = JTransType.expr_type context expr in
(idl_accu @ idl, instrs_accu @ instrs, args_accu @ [(sil_expr, sil_expr_type)]))
init
expr_list in
let callee_procname =
@ -659,22 +659,22 @@ let method_invocation context loc pc var_opt cn ms sil_obj_opt expr_list invoke_
(* add a file attribute when calling the constructor of a subtype of Closeable *)
| (var, 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
Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in
(* Exceptions thrown in the constructor should prevent adding the resource attribute *)
call_instrs @ [set_file_attr]
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
Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in
(* Exceptions thrown in the constructor should prevent adding the resource attribute *)
call_instrs @ [set_file_attr]
(* remove file attribute when calling the close method of a subtype of Closeable *)
| (var, 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
Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in
(* Exceptions thrown in the close method should not prevent the resource from being *)
(* considered as closed *)
[set_mem_attr] @ call_instrs
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
Sil.Call ([], set_builtin, [exp], loc, Sil.cf_default) in
(* Exceptions thrown in the close method should not prevent the resource from being *)
(* considered as closed *)
[set_mem_attr] @ call_instrs
| _ -> call_instrs in
@ -791,15 +791,15 @@ let rec extends context node1 node2 =
let instruction_array_call ms obj_type obj args var_opt vt =
if is_clone ms then
(let cn = JBasics.make_cn JConfig.infer_array_cl in
let vt = (JBasics.TObject obj_type) in
let ms = JBasics.make_ms JConfig.clone_name [vt] (Some vt) in
JBir.InvokeStatic (var_opt, cn, ms, obj:: args))
let vt = (JBasics.TObject obj_type) in
let ms = JBasics.make_ms JConfig.clone_name [vt] (Some vt) in
JBir.InvokeStatic (var_opt, cn, ms, obj:: args))
else
(let undef_cn, undef_ms = get_undefined_method_call (JBasics.ms_rtype ms) in
JBir.InvokeStatic (var_opt, undef_cn, undef_ms, []))
JBir.InvokeStatic (var_opt, undef_cn, undef_ms, []))
(* special translation of the method start() of a Thread or a Runnable object.
We translate it directly as the run() method *)
We translate it directly as the run() method *)
let instruction_thread_start context cn ms obj args var_opt =
match JClasspath.lookup_node cn (JContext.get_program context) with
| None ->
@ -849,7 +849,7 @@ let rec instruction context pc instr : translation =
cfg (get_location (JContext.get_impl context) pc meth_kind cn) node_kind sil_instrs (JContext.get_procdesc context) temps in
let return_not_null () =
(match_never_null loc.Sil.file proc_name
|| list_exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in
|| list_exists (fun p -> Procname.equal p proc_name) JTransType.never_returning_null) in
try
match instr with
| JBir.AffectVar (var, expr) ->
@ -990,8 +990,8 @@ let rec instruction context pc instr : translation =
let sil_obj_opt, args, ids, instrs =
match args with
| [arg] when is_clone ms ->
(* hack to null check the receiver of clone when clone is an array. in the array.clone()
case, clone is a virtual call that we translate as a static call *)
(* hack to null check the receiver of clone when clone is an array. in the array.clone()
case, clone is a virtual call that we translate as a static call *)
let (ids, instrs, sil_arg_expr) = expression context pc arg in
let arg_typ = JTransType.expr_type context arg in
Some (sil_arg_expr, arg_typ), [], ids, instrs
@ -1051,7 +1051,7 @@ let rec instruction context pc instr : translation =
Instr call_node
| JBir.Check (JBir.CheckNullPointer expr) when !JConfig.translate_checks && is_this expr ->
(* TODO #6509339: refactor the boilterplate code in the translattion of JVM checks *)
(* TODO #6509339: refactor the boilterplate code in the translattion of JVM checks *)
let (ids, instrs, sil_expr) = expression context pc expr in
let this_not_null_node =
create_node
@ -1183,5 +1183,5 @@ let rec instruction context pc instr : translation =
| _ -> Skip
with Frontend_error s ->
JUtils.log "Skipping because of: %s@." s;
Skip
JUtils.log "Skipping because of: %s@." s;
Skip

120
infer/src/java/jTransExn.ml
Unescape View File

@ -20,7 +20,7 @@ let create_handler_table impl =
let handlers = Hashtbl.find handler_tb pc in
Hashtbl.replace handler_tb pc (exn_handler:: handlers)
with Not_found ->
Hashtbl.add handler_tb pc [exn_handler] in
Hashtbl.add handler_tb pc [exn_handler] in
List.iter collect (JBir.exception_edges impl);
handler_tb
@ -46,62 +46,62 @@ let translate_exceptions context exit_nodes get_body_nodes handler_table =
try
ignore (Hashtbl.find catch_block_table handler_list)
with Not_found ->
let collect succ_nodes last_handler rethrow_exception handler =
let catch_nodes = get_body_nodes handler.JBir.e_handler in
let loc = match catch_nodes with
| n:: _ -> Cfg.Node.get_loc n
| [] -> Sil.dummy_location in
let exn_type =
let class_name =
match handler.JBir.e_catch_type with
| None -> JBasics.make_cn "java.lang.Exception"
| Some cn -> cn in
match JTransType.get_class_type (JContext.get_program context) (JContext.get_tenv context) class_name with
| Sil.Tptr (typ, _) -> typ
| _ -> assert false in
let id_instanceof = Ident.create_fresh Ident.knormal in
let instr_call_instanceof =
let instanceof_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) in
let args = [(Sil.Var id_exn_val, Sil.Tptr(exn_type, Sil.Pk_pointer)); (Sil.Sizeof (exn_type, Sil.Subtype.exact), Sil.Tvoid)] in
Sil.Call ([id_instanceof], instanceof_builtin, args, loc, Sil.cf_default) in
let if_kind = Sil.Ik_switch in
let instr_prune_true = Sil.Prune (Sil.Var id_instanceof, loc, true, if_kind) in
let instr_prune_false = Sil.Prune (Sil.UnOp(Sil.LNot, Sil.Var id_instanceof, None), loc, false, if_kind) in
let instr_set_catch_var =
let catch_var = JContext.set_pvar context handler.JBir.e_catch_var ret_type in
Sil.Set (Sil.Lvar catch_var, ret_type, Sil.Var id_exn_val, loc) in
let instr_rethrow_exn = Sil.Set (Sil.Lvar ret_var, ret_type, Sil.Const (Sil.Cexn (Sil.Var id_exn_val)), loc) in
let node_kind_true = Cfg.Node.Prune_node (true, if_kind, exn_message) in
let node_kind_false = Cfg.Node.Prune_node (false, if_kind, exn_message) in
let node_true =
let instrs_true = [instr_call_instanceof; instr_prune_true; instr_set_catch_var] in
let ids_true = [id_exn_val; id_instanceof] in
create_node loc node_kind_true instrs_true ids_true in
let node_false =
let instrs_false = [instr_call_instanceof; instr_prune_false] @ (if rethrow_exception then [instr_rethrow_exn] else []) in
let ids_false = (if last_handler then [id_exn_val] else []) @ [id_instanceof] in
create_node loc node_kind_false instrs_false ids_false in
Cfg.Node.set_succs_exn node_true catch_nodes exit_nodes;
Cfg.Node.set_succs_exn node_false succ_nodes exit_nodes;
let is_finally = handler.JBir.e_catch_type = None in
if is_finally
then [node_true] (* TODO (#4759480): clean up the translation so prune nodes are not created at all *)
else [node_true; node_false] in
let is_last_handler = ref true in
let process_handler succ_nodes handler = (* process handlers starting from the last one *)
let is_finally_handler = handler.JBir.e_catch_type = None in
let remove_temps = !is_last_handler in (* remove temporary variables on last handler *)
let rethrow_exception = !is_last_handler && not is_finally_handler in (* rethrow exception if there is no finally *)
is_last_handler := false;
collect succ_nodes remove_temps rethrow_exception handler in
let nodes_first_handler = List.fold_left process_handler exit_nodes (List.rev handler_list) in
let loc = match nodes_first_handler with
let collect succ_nodes last_handler rethrow_exception handler =
let catch_nodes = get_body_nodes handler.JBir.e_handler in
let loc = match catch_nodes with
| n:: _ -> Cfg.Node.get_loc n
| [] -> Sil.dummy_location in
let entry_node = create_entry_node loc in
Cfg.Node.set_succs_exn entry_node nodes_first_handler exit_nodes;
Hashtbl.add catch_block_table handler_list [entry_node] in
let exn_type =
let class_name =
match handler.JBir.e_catch_type with
| None -> JBasics.make_cn "java.lang.Exception"
| Some cn -> cn in
match JTransType.get_class_type (JContext.get_program context) (JContext.get_tenv context) class_name with
| Sil.Tptr (typ, _) -> typ
| _ -> assert false in
let id_instanceof = Ident.create_fresh Ident.knormal in
let instr_call_instanceof =
let instanceof_builtin = Sil.Const (Sil.Cfun SymExec.ModelBuiltins.__instanceof) in
let args = [(Sil.Var id_exn_val, Sil.Tptr(exn_type, Sil.Pk_pointer)); (Sil.Sizeof (exn_type, Sil.Subtype.exact), Sil.Tvoid)] in
Sil.Call ([id_instanceof], instanceof_builtin, args, loc, Sil.cf_default) in
let if_kind = Sil.Ik_switch in
let instr_prune_true = Sil.Prune (Sil.Var id_instanceof, loc, true, if_kind) in
let instr_prune_false = Sil.Prune (Sil.UnOp(Sil.LNot, Sil.Var id_instanceof, None), loc, false, if_kind) in
let instr_set_catch_var =
let catch_var = JContext.set_pvar context handler.JBir.e_catch_var ret_type in
Sil.Set (Sil.Lvar catch_var, ret_type, Sil.Var id_exn_val, loc) in
let instr_rethrow_exn = Sil.Set (Sil.Lvar ret_var, ret_type, Sil.Const (Sil.Cexn (Sil.Var id_exn_val)), loc) in
let node_kind_true = Cfg.Node.Prune_node (true, if_kind, exn_message) in
let node_kind_false = Cfg.Node.Prune_node (false, if_kind, exn_message) in
let node_true =
let instrs_true = [instr_call_instanceof; instr_prune_true; instr_set_catch_var] in
let ids_true = [id_exn_val; id_instanceof] in
create_node loc node_kind_true instrs_true ids_true in
let node_false =
let instrs_false = [instr_call_instanceof; instr_prune_false] @ (if rethrow_exception then [instr_rethrow_exn] else []) in
let ids_false = (if last_handler then [id_exn_val] else []) @ [id_instanceof] in
create_node loc node_kind_false instrs_false ids_false in
Cfg.Node.set_succs_exn node_true catch_nodes exit_nodes;
Cfg.Node.set_succs_exn node_false succ_nodes exit_nodes;
let is_finally = handler.JBir.e_catch_type = None in
if is_finally
then [node_true] (* TODO (#4759480): clean up the translation so prune nodes are not created at all *)
else [node_true; node_false] in
let is_last_handler = ref true in
let process_handler succ_nodes handler = (* process handlers starting from the last one *)
let is_finally_handler = handler.JBir.e_catch_type = None in
let remove_temps = !is_last_handler in (* remove temporary variables on last handler *)
let rethrow_exception = !is_last_handler && not is_finally_handler in (* rethrow exception if there is no finally *)
is_last_handler := false;
collect succ_nodes remove_temps rethrow_exception handler in
let nodes_first_handler = List.fold_left process_handler exit_nodes (List.rev handler_list) in
let loc = match nodes_first_handler with
| n:: _ -> Cfg.Node.get_loc n
| [] -> Sil.dummy_location in
let entry_node = create_entry_node loc in
Cfg.Node.set_succs_exn entry_node nodes_first_handler exit_nodes;
Hashtbl.add catch_block_table handler_list [entry_node] in
Hashtbl.iter (fun pc handler_list -> create_entry_block pc handler_list) handler_table;
catch_block_table
@ -112,8 +112,8 @@ let create_exception_handlers context exit_nodes get_body_nodes impl =
let handler_table = create_handler_table impl in
let catch_block_table = translate_exceptions context exit_nodes get_body_nodes handler_table in
fun pc ->
try
let handler_list = Hashtbl.find handler_table pc in
Hashtbl.find catch_block_table handler_list
with Not_found ->
exit_nodes
try
let handler_list = Hashtbl.find handler_table pc in
Hashtbl.find catch_block_table handler_list
with Not_found ->
exit_nodes

46
infer/src/java/jTransStaticField.ml
Unescape View File

@ -33,7 +33,7 @@ let is_basic_type fs =
| JBasics.TObject ot -> false
(** Returns whether the node contains static final fields
that are not of a primitive type or String. *)
that are not of a primitive type or String. *)
let rec has_static_final_fields node =
let detect fs f test =
test || (Javalib.is_static_field f && Javalib.is_final_field f) in
@ -42,7 +42,7 @@ let rec has_static_final_fields node =
(* Patricia trees *)
(** collects the code line where the fields are initialised. The list is
reversed in order to access the previous element in the list easier (as the successor.) *)
reversed in order to access the previous element in the list easier (as the successor.) *)
let collect_field_pc instrs field_pc_list =
let aux pc instr =
match instr with
@ -53,7 +53,7 @@ let collect_field_pc instrs field_pc_list =
(List.rev !field_pc_list)
(** Changes every position in the code where a static field is set to a value,
to returning that value *)
to returning that value *)
let add_return_field instrs =
let aux instr =
match instr with
@ -63,8 +63,8 @@ let add_return_field instrs =
(Array.map aux instrs)
(** Given a list with the lines where the fields are initialised,
finds the line where the code for the initialisation of the given field starts,
which is the line after the previous field has been initialised. *)
finds the line where the code for the initialisation of the given field starts,
which is the line after the previous field has been initialised. *)
let rec find_pc field list =
match list with
| (fs, pc):: rest ->
@ -107,9 +107,9 @@ let has_unclear_control_flow code =
(** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter. *)
for returning the field selected by the parameter. *)
(* The constant s means the parameter field of the function.
Note that we remove the initialisation of non - final static fields. *)
Note that we remove the initialisation of non - final static fields. *)
let rec static_field_init_complex cn code fields length =
let code = Array.append [| (JBir.Goto length ) |] code in
let s = JConfig.field_cst in
@ -130,7 +130,7 @@ let rec static_field_init_complex cn code fields length =
else
let _ =
if Javalib.is_static_field field && pc <> -1 then
field_nonfinal_pcs := pc::!field_nonfinal_pcs in
field_nonfinal_pcs := pc::!field_nonfinal_pcs in
aux s rest
| [] -> [| JBir.Nop |] in
let new_instrs = aux s fields in
@ -140,8 +140,8 @@ let rec static_field_init_complex cn code fields length =
code
(** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter without changing
the control flow of the original code. *)
for returning the field selected by the parameter without changing
the control flow of the original code. *)
let rec static_field_init_simple cn code fields length =
let s = JConfig.field_cst in
let rec aux s pc fields =
@ -161,13 +161,13 @@ let rec static_field_init_simple cn code fields length =
code
(** In the initialiser of static fields, we add instructions
for returning the field selected by the parameter. In normal
cases the code for the initialisation of each field is clearly separated
from the code for the initialisation of the next field. However, in some cases
the fields are initialised in static blocks in which they may use try and catch.
In these cases it is not possible to separate the code for the initialisation
of each field, so we do not change the original code, but append intructions
for returning the selected field. *)
for returning the field selected by the parameter. In normal
cases the code for the initialisation of each field is clearly separated
from the code for the initialisation of the next field. However, in some cases
the fields are initialised in static blocks in which they may use try and catch.
In these cases it is not possible to separate the code for the initialisation
of each field, so we do not change the original code, but append intructions
for returning the selected field. *)
let rec static_field_init node cn code =
try
let field_list = JBasics.FieldMap.elements (Javalib.get_fields node) in
@ -200,9 +200,9 @@ let is_static_final_field context cn fs =
match JClasspath.lookup_node cn (JContext.get_program context) with
| None -> false
| Some node ->
try
let f = Javalib.get_field node fs in
let is_static = Javalib.is_static_field f in
let is_final = Javalib.is_final_field f in
(is_static && is_final)
with Not_found -> false
try
let f = Javalib.get_field node fs in
let is_static = Javalib.is_static_field f in
let is_final = Javalib.is_final_field f in
(is_static && is_final)
with Not_found -> false

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

@ -105,14 +105,14 @@ let rec array_type_to_string vt =
match vt with
| JBasics.TBasic bt ->
(match bt with
| `Bool -> JConfig.boolean_code
| `Byte -> JConfig.byte_code
| `Char -> JConfig.char_code
| `Double -> JConfig.double_code
| `Float -> JConfig.float_code
| `Int -> JConfig.int_code
| `Long -> JConfig.long_code
| `Short -> JConfig.short_code)
| `Bool -> JConfig.boolean_code
| `Byte -> JConfig.byte_code
| `Char -> JConfig.char_code
| `Double -> JConfig.double_code
| `Float -> JConfig.float_code
| `Int -> JConfig.int_code
| `Long -> JConfig.long_code
| `Short -> JConfig.short_code)
| JBasics.TObject ot -> object_type_to_string' ot in
"["^s
and object_type_to_string' ot =
@ -158,7 +158,7 @@ let package_to_string p =
let cn_to_java_type cn =
(package_to_string (JBasics.cn_package cn),
(JBasics.cn_simple_name cn))
(JBasics.cn_simple_name cn))
let rec vt_to_java_type vt =
@ -274,7 +274,7 @@ let collect_models_class_fields classpath_field_map static cn cf l =
(Sil.pp_typ_full pe_text) classpath_ft
(Sil.pp_typ_full pe_text) field_type in l
with Not_found ->
(field_name, field_type, annotation):: l
(field_name, field_type, annotation):: l
let add_model_fields program (static_fields, nonstatic_fields) cn =
@ -312,7 +312,7 @@ let rec create_sil_type program tenv cn =
let item_annotation = JAnnotation.translate_item jinterface.Javalib.i_annotations in
(sil_interface_list, [], static_fields, item_annotation)
| Javalib.JClass jclass ->
(* TODO: create two functions to get static fields and non-static ones *)
(* TODO: create two functions to get static fields and non-static ones *)
let static_fields, nonstatic_fields =
let classpath_static_fields = get_all_fields program true cn
and classpath_nonstatic_fields = get_all_fields program false cn in
@ -421,7 +421,7 @@ let extract_array_type typ =
(** translate the type of an expression, looking in the method signature for formal parameters
this is because variables in expressions do not have accurate types *)
this is because variables in expressions do not have accurate types *)
let rec expr_type context expr =
let program = JContext.get_program context in
let tenv = JContext.get_tenv context in
@ -429,8 +429,8 @@ let rec expr_type context expr =
| JBir.Const const -> value_type program tenv (const_type const)
| JBir.Var (vt, var) ->
(match get_var_type context var with
| Some typ -> typ
| None -> (value_type program tenv vt))
| Some typ -> typ
| None -> (value_type program tenv vt))
| JBir.Binop ((JBir.ArrayLoad typ), e1, e2) ->
let typ = expr_type context e1 in
(extract_array_type typ)
@ -438,8 +438,8 @@ let rec expr_type context expr =
(** Returns the return type of the method based on the return type
specified in ms. If the method is the initialiser, return the type
Object instead. *)
specified in ms. If the method is the initialiser, return the type
Object instead. *)
let return_type program tenv ms meth_kind =
if meth_kind = JContext.Init then
get_class_type program tenv (JBasics.make_cn JConfig.object_cl)
@ -467,7 +467,7 @@ let saturate_tenv_with_classpath classpath tenv =
Sil.TN_csu (Sil.Class, classname) in
let rec is_useful_subtype jar_tenv = function
| Sil.TN_csu (Sil.Class, classname) when
Mangled.equal classname JConfig.java_lang_object_classname -> false
Mangled.equal classname JConfig.java_lang_object_classname -> false
| typename when Sil.tenv_mem tenv typename -> true
| typename ->
begin
@ -515,8 +515,8 @@ let never_returning_null =
let fragment_type = "android.support.v4.app.Fragment" in
let never_null_method_sigs =
[
(fragment_type, "getContext", [], "android.content.Context", Procname.Non_Static);
(fragment_type, "getActivity", [], "android.support.v4.app.FragmentActivity", Procname.Non_Static)
(fragment_type, "getContext", [], "android.content.Context", Procname.Non_Static);
(fragment_type, "getActivity", [], "android.support.v4.app.FragmentActivity", Procname.Non_Static)
] in
let make_procname = function
| (class_name, method_name, arg_types, ret_type, kind) ->

18
infer/src/llvm/lMain.ml
Unescape View File

@ -12,13 +12,13 @@ open Printf
exception UsageError of string
let () = try
if Array.length Sys.argv < 2 then
raise (UsageError ("Missing source file as first command line argument."))
else
let filename = Sys.argv.(1) in
let lexbuf = Lexing.from_channel (open_in filename) in
let prog = LParser.prog LLexer.token lexbuf in
let pretty = LPretty.pretty_prog prog in
LTrans.gen_prog prog; ()
with
if Array.length Sys.argv < 2 then
raise (UsageError ("Missing source file as first command line argument."))
else
let filename = Sys.argv.(1) in
let lexbuf = Lexing.from_channel (open_in filename) in
let prog = LParser.prog LLexer.token lexbuf in
let pretty = LPretty.pretty_prog prog in
LTrans.gen_prog prog; ()
with
| UsageError msg -> print_string ("Usage error: " ^ msg ^ "\n")

10
infer/src/llvm/lPretty.ml
Unescape View File

@ -47,10 +47,10 @@ let pretty_instr : instr -> string = function
let pretty_instr_ln (i : instr) : string = pretty_instr i ^ "\n"
let pretty_func_def : func_def -> string = function
FuncDef (name, ret_tp, params, instrs) ->
"define " ^ pretty_ret_typ ret_tp ^ " " ^ pretty_variable name ^ "(" ^
concatmap ", " (fun (tp, id) -> pretty_typ tp ^ " " ^ id) params ^ ") {\n" ^
concatmap "" pretty_instr_ln instrs ^ "}\n"
FuncDef (name, ret_tp, params, instrs) ->
"define " ^ pretty_ret_typ ret_tp ^ " " ^ pretty_variable name ^ "(" ^
concatmap ", " (fun (tp, id) -> pretty_typ tp ^ " " ^ id) params ^ ") {\n" ^
concatmap "" pretty_instr_ln instrs ^ "}\n"
let pretty_prog : prog -> string = function
Prog defs -> concatmap "" pretty_func_def defs
Prog defs -> concatmap "" pretty_func_def defs

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

Write Preview
Loading…
Cancel
Save