Pass tenv to everywhere that matches on Tstruct

Reviewed By: cristianoc

Differential Revision: D3809094

fbshipit-source-id: b3a8449
master
Josh Berdine 8 years ago committed by Facebook Github Bot 5
parent 2bebd94553
commit 8a85919001

@ -92,6 +92,17 @@ let find_tenv_from_class_of_proc procname =>
};
/** Given a procedure name, find the file where it is defined and its corresponding type
environment, or create an empty tenv if necessary. */
let get_tenv proc_name =>
switch (find_tenv_from_class_of_proc proc_name) {
| Some tenv => tenv
/* ToDo: a tenv should always be found, it should not be necessary to create one here */
| None => Tenv.create ()
| exception _ => Tenv.create ()
};
/** Given the name of an ObjC class, extract the type from the tenv where the class was defined. We
do this by adding a method that is unique to each class, and then finding the tenv that
corresponds to the class definition. */

@ -27,6 +27,11 @@ let load_attributes: Procname.t => option ProcAttributes.t;
let find_tenv_from_class_of_proc: Procname.t => option Tenv.t;
/** Given a procedure name, find the file where it is defined and its corresponding type
environment, or create an empty tenv if necessary. */
let get_tenv: Procname.t => Tenv.t;
/** Given the name of an ObjC class, extract the type from the tenv where the class was defined. We
do this by adding a method that is unique to each class, and then finding the tenv that
corresponds to the class definition. */

@ -897,7 +897,7 @@ let get_name_of_objc_block_locals p => {
IList.flatten (IList.flatten vars_sigma)
};
let remove_abducted_retvars p =>
let remove_abducted_retvars tenv p =>
/* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] */
{
let compute_reachable p seed_exps => {
@ -985,7 +985,7 @@ let remove_abducted_retvars p =>
)
([], [])
p.Prop.sigma;
let (_, p') = Attribute.deallocate_stack_vars p abducteds;
let (_, p') = Attribute.deallocate_stack_vars tenv p abducteds;
let normal_pvar_set =
IList.fold_left
(fun normal_pvar_set pvar => Exp.Set.add (Exp.Lvar pvar) normal_pvar_set)
@ -993,10 +993,10 @@ let remove_abducted_retvars p =>
normal_pvars;
/* walk forward from non-abducted pvars, keep everything reachable. remove everything else */
let (sigma_reach, pi_reach) = compute_reachable p' normal_pvar_set;
Prop.normalize (Prop.set p' pi::pi_reach sigma::sigma_reach)
Prop.normalize tenv (Prop.set p' pi::pi_reach sigma::sigma_reach)
};
let remove_locals (curr_f: Procdesc.t) p => {
let remove_locals tenv (curr_f: Procdesc.t) p => {
let names_of_locals = IList.map (get_name_of_local curr_f) (Procdesc.get_locals curr_f);
let names_of_locals' =
switch !Config.curr_language {
@ -1007,55 +1007,57 @@ let remove_locals (curr_f: Procdesc.t) p => {
names_of_block_locals @ names_of_locals @ names_of_static_locals
| _ => names_of_locals
};
let (removed, p') = Attribute.deallocate_stack_vars p names_of_locals';
let (removed, p') = Attribute.deallocate_stack_vars tenv p names_of_locals';
(
removed,
if Config.angelic_execution {
remove_abducted_retvars p'
remove_abducted_retvars tenv p'
} else {
p'
}
)
};
let remove_formals (curr_f: Procdesc.t) p => {
let remove_formals tenv (curr_f: Procdesc.t) p => {
let pname = Procdesc.get_proc_name curr_f;
let formal_vars = IList.map (fun (n, _) => Pvar.mk n pname) (Procdesc.get_formals curr_f);
Attribute.deallocate_stack_vars p formal_vars
Attribute.deallocate_stack_vars tenv p formal_vars
};
/** remove the return variable from the prop */
let remove_ret (curr_f: Procdesc.t) (p: Prop.t Prop.normal) => {
let remove_ret tenv (curr_f: Procdesc.t) (p: Prop.t Prop.normal) => {
let pname = Procdesc.get_proc_name curr_f;
let name_of_ret = Procdesc.get_ret_var curr_f;
let (_, p') = Attribute.deallocate_stack_vars p [Pvar.to_callee pname name_of_ret];
let (_, p') = Attribute.deallocate_stack_vars tenv p [Pvar.to_callee pname name_of_ret];
p'
};
/** remove locals and return variable from the prop */
let remove_locals_ret (curr_f: Procdesc.t) p => snd (remove_locals curr_f (remove_ret curr_f p));
let remove_locals_ret tenv (curr_f: Procdesc.t) p => snd (
remove_locals tenv curr_f (remove_ret tenv curr_f p)
);
/** Remove locals and formal parameters from the prop.
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;
let (pvars2, p2) = remove_locals curr_f p1;
let remove_locals_formals tenv (curr_f: Procdesc.t) p => {
let (pvars1, p1) = remove_formals tenv curr_f p;
let (pvars2, p2) = remove_locals tenv curr_f p1;
(pvars1 @ pvars2, p2)
};
/** remove seed vars from a prop */
let remove_seed_vars (prop: Prop.t 'a) :Prop.t Prop.normal => {
let remove_seed_vars tenv (prop: Prop.t 'a) :Prop.t Prop.normal => {
let hpred_not_seed =
fun
| Sil.Hpointsto (Exp.Lvar pv) _ _ => not (Pvar.is_seed pv)
| _ => true;
let sigma = prop.sigma;
let sigma' = IList.filter hpred_not_seed sigma;
Prop.normalize (Prop.set prop sigma::sigma')
Prop.normalize tenv (Prop.set prop sigma::sigma')
};
@ -1101,7 +1103,7 @@ let check_cfg_connectedness cfg => {
/** Removes seeds variables from a prop corresponding to captured variables in an objc block */
let remove_seed_captured_vars_block captured_vars prop => {
let remove_seed_captured_vars_block tenv captured_vars prop => {
let is_captured pname vn => Mangled.equal pname vn;
let hpred_seed_captured =
fun
@ -1112,7 +1114,7 @@ let remove_seed_captured_vars_block captured_vars prop => {
| _ => false;
let sigma = prop.Prop.sigma;
let sigma' = IList.filter (fun hpred => not (hpred_seed_captured hpred)) sigma;
Prop.normalize (Prop.set prop sigma::sigma')
Prop.normalize tenv (Prop.set prop sigma::sigma')
};

@ -300,20 +300,21 @@ let set_procname_priority: cfg => Procname.t => unit;
/** remove the return variable from the prop */
let remove_ret: Procdesc.t => Prop.t Prop.normal => Prop.t Prop.normal;
let remove_ret: Tenv.t => Procdesc.t => Prop.t Prop.normal => Prop.t Prop.normal;
/** remove locals and return variable from the prop */
let remove_locals_ret: Procdesc.t => Prop.t Prop.normal => Prop.t Prop.normal;
let remove_locals_ret: Tenv.t => Procdesc.t => Prop.t Prop.normal => Prop.t Prop.normal;
/** 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. */
let remove_locals_formals: Procdesc.t => Prop.t Prop.normal => (list Pvar.t, Prop.t Prop.normal);
let remove_locals_formals:
Tenv.t => Procdesc.t => Prop.t Prop.normal => (list Pvar.t, Prop.t Prop.normal);
/** remove seed vars from a prop */
let remove_seed_vars: Prop.t 'a => Prop.t Prop.normal;
let remove_seed_vars: Tenv.t => Prop.t 'a => Prop.t Prop.normal;
/** checks whether a cfg is connected or not */
@ -321,7 +322,8 @@ let check_cfg_connectedness: cfg => unit;
/** Removes seeds variables from a prop corresponding to captured variables in an objc block */
let remove_seed_captured_vars_block: list Mangled.t => Prop.t Prop.normal => Prop.t Prop.normal;
let remove_seed_captured_vars_block:
Tenv.t => list Mangled.t => Prop.t Prop.normal => Prop.t Prop.normal;
/** Creates a copy of a procedure description and a list of type substitutions of the form

@ -188,7 +188,7 @@ let hpred_get_lhs h =>
/** {2 Comparision and Inspection Functions} */
let has_objc_ref_counter hpred =>
let has_objc_ref_counter _tenv hpred =>
switch hpred {
| Hpointsto _ _ (Sizeof (Tstruct struct_typ) _ _) =>
IList.exists Typ.is_objc_ref_counter_field struct_typ.instance_fields

@ -239,7 +239,7 @@ let hpred_compact: sharing_env => hpred => hpred;
/** {2 Comparision And Inspection Functions} */
let has_objc_ref_counter: hpred => bool;
let has_objc_ref_counter: Tenv.t => hpred => bool;
/** Returns the zero value of a type, for int, float and ptr types, None othwewise */

@ -23,8 +23,8 @@ let is_pred atom =
| _ -> false
(** Add an attribute associated to the argument expressions *)
let add ?(footprint = false) ?(polarity = true) prop attr args =
Prop.prop_atom_and ~footprint prop
let add tenv ?(footprint = false) ?(polarity = true) prop attr args =
Prop.prop_atom_and tenv ~footprint prop
(if polarity then Sil.Apred (attr, args) else Sil.Anpred (attr, args))
let attributes_in_same_category attr1 attr2 =
@ -33,10 +33,10 @@ let attributes_in_same_category attr1 attr2 =
PredSymb.category_equal cat1 cat2
(** Replace an attribute associated to the expression *)
let add_or_replace_check_changed check_attribute_change prop atom0 =
let add_or_replace_check_changed tenv check_attribute_change prop atom0 =
match atom0 with
| Sil.Apred (att0, ((_ :: _) as exps0)) | Anpred (att0, ((_ :: _) as exps0)) ->
let nexps = IList.map (fun e -> Prop.exp_normalize_prop prop e) exps0 in
let nexps = IList.map (fun e -> Prop.exp_normalize_prop tenv prop e) exps0 in
let nexp = IList.hd nexps in (* len nexps = len exps0 > 0 by match *)
let natom = Sil.atom_replace_exp (IList.combine exps0 nexps) atom0 in
let atom_map = function
@ -49,15 +49,15 @@ let add_or_replace_check_changed check_attribute_change prop atom0 =
let pi = prop.Prop.pi in
let pi' = IList.map_changed atom_map pi in
if pi == pi'
then Prop.prop_atom_and prop natom
else Prop.normalize (Prop.set prop ~pi:pi')
then Prop.prop_atom_and tenv prop natom
else Prop.normalize tenv (Prop.set prop ~pi:pi')
| _ ->
prop
let add_or_replace prop atom =
let add_or_replace tenv prop atom =
(* wrapper for the most common case: do nothing *)
let check_attr_changed = (fun _ _ -> ()) in
add_or_replace_check_changed check_attr_changed prop atom
add_or_replace_check_changed tenv check_attr_changed prop atom
(** Get all the attributes of the prop *)
let get_all (prop: 'a Prop.t) =
@ -74,16 +74,16 @@ let get_for_symb prop att =
) prop.Prop.pi
(** Get the attribute associated to the expression, if any *)
let get_for_exp (prop: 'a Prop.t) exp =
let nexp = Prop.exp_normalize_prop prop exp in
let get_for_exp tenv (prop: 'a Prop.t) exp =
let nexp = Prop.exp_normalize_prop tenv prop exp in
let atom_get_attr attributes atom =
match atom with
| Sil.Apred (_, es) | Anpred (_, es) when IList.mem Exp.equal nexp es -> atom :: attributes
| _ -> attributes in
IList.fold_left atom_get_attr [] prop.pi
let get prop exp category =
let atts = get_for_exp prop exp in
let get tenv prop exp category =
let atts = get_for_exp tenv prop exp in
try
Some
(IList.find (function
@ -93,70 +93,70 @@ let get prop exp category =
) atts)
with Not_found -> None
let get_undef prop exp =
get prop exp ACundef
let get_undef tenv prop exp =
get tenv prop exp ACundef
let get_resource prop exp =
get prop exp ACresource
let get_resource tenv prop exp =
get tenv prop exp ACresource
let get_taint prop exp =
get prop exp ACtaint
let get_taint tenv prop exp =
get tenv prop exp ACtaint
let get_autorelease prop exp =
get prop exp ACautorelease
let get_autorelease tenv prop exp =
get tenv prop exp ACautorelease
let get_objc_null prop exp =
get prop exp ACobjc_null
let get_objc_null tenv prop exp =
get tenv prop exp ACobjc_null
let get_div0 prop exp =
get prop exp ACdiv0
let get_div0 tenv prop exp =
get tenv prop exp ACdiv0
let get_observer prop exp =
get prop exp ACobserver
let get_observer tenv prop exp =
get tenv prop exp ACobserver
let get_retval prop exp =
get prop exp ACretval
let get_retval tenv prop exp =
get tenv prop exp ACretval
let has_dangling_uninit prop exp =
let la = get_for_exp prop exp in
let has_dangling_uninit tenv prop exp =
let la = get_for_exp tenv prop exp in
IList.exists (function
| Sil.Apred (a, _) -> PredSymb.equal a (Adangling DAuninit)
| _ -> false
) la
let filter_atoms ~f prop =
let filter_atoms tenv ~f prop =
let pi0 = prop.Prop.pi in
let pi1 = IList.filter_changed f pi0 in
if pi1 == pi0 then
prop
else
Prop.normalize (Prop.set prop ~pi:pi1)
Prop.normalize tenv (Prop.set prop ~pi:pi1)
let remove prop atom =
let remove tenv prop atom =
if is_pred atom then
let natom = Prop.atom_normalize_prop prop atom in
let natom = Prop.atom_normalize_prop tenv prop atom in
let f a = not (Sil.atom_equal natom a) in
filter_atoms ~f prop
filter_atoms tenv ~f prop
else
prop
(** Remove an attribute from all the atoms in the heap *)
let remove_for_attr prop att0 =
let remove_for_attr tenv prop att0 =
let f = function
| Sil.Apred (att, _) | Anpred (att, _) -> not (PredSymb.equal att0 att)
| _ -> true in
filter_atoms ~f prop
filter_atoms tenv ~f prop
let remove_resource ra_kind ra_res =
let remove_resource tenv ra_kind ra_res =
let f = function
| Sil.Apred (Aresource res_action, _) ->
PredSymb.res_act_kind_compare res_action.ra_kind ra_kind <> 0
|| PredSymb.resource_compare res_action.ra_res ra_res <> 0
| _ -> true in
filter_atoms ~f
filter_atoms tenv ~f
(** Apply f to every resource attribute in the prop *)
let map_resource prop f =
let map_resource tenv prop f =
let attribute_map e = function
| PredSymb.Aresource ra -> PredSymb.Aresource (f e ra)
| att -> att in
@ -169,40 +169,40 @@ let map_resource prop f =
if pi1 == pi0 then
prop
else
Prop.normalize (Prop.set prop ~pi:pi1)
Prop.normalize tenv (Prop.set prop ~pi:pi1)
(* Replace an attribute OBJC_NULL($n1) with OBJC_NULL(var) when var = $n1, and also sets $n1 =
0 *)
let replace_objc_null prop lhs_exp rhs_exp =
match get_objc_null prop rhs_exp, rhs_exp with
let replace_objc_null tenv prop lhs_exp rhs_exp =
match get_objc_null tenv prop rhs_exp, rhs_exp with
| Some atom, Exp.Var _ ->
let prop = remove prop atom in
let prop = Prop.conjoin_eq rhs_exp Exp.zero prop in
let prop = remove tenv prop atom in
let prop = Prop.conjoin_eq tenv rhs_exp Exp.zero prop in
let natom = Sil.atom_replace_exp [(rhs_exp, lhs_exp)] atom in
add_or_replace prop natom
add_or_replace tenv prop natom
| _ -> prop
let rec nullify_exp_with_objc_null prop exp =
let rec nullify_exp_with_objc_null tenv prop exp =
match exp with
| Exp.BinOp (_, exp1, exp2) ->
let prop' = nullify_exp_with_objc_null prop exp1 in
nullify_exp_with_objc_null prop' exp2
let prop' = nullify_exp_with_objc_null tenv prop exp1 in
nullify_exp_with_objc_null tenv prop' exp2
| Exp.UnOp (_, exp, _) ->
nullify_exp_with_objc_null prop exp
nullify_exp_with_objc_null tenv prop exp
| Exp.Var _ ->
(match get_objc_null prop exp with
(match get_objc_null tenv prop exp with
| Some atom ->
let prop' = remove prop atom in
Prop.conjoin_eq exp Exp.zero prop'
let prop' = remove tenv prop atom in
Prop.conjoin_eq tenv exp Exp.zero prop'
| _ -> prop)
| _ -> prop
(** mark Exp.Var's or Exp.Lvar's as undefined *)
let mark_vars_as_undefined prop vars_to_mark callee_pname ret_annots loc path_pos =
let mark_vars_as_undefined tenv prop vars_to_mark callee_pname ret_annots loc path_pos =
let att_undef = PredSymb.Aundef (callee_pname, ret_annots, loc, path_pos) in
let mark_var_as_undefined exp prop =
match exp with
| Exp.Var _ | Lvar _ -> add_or_replace prop (Apred (att_undef, [exp]))
| Exp.Var _ | Lvar _ -> add_or_replace tenv prop (Apred (att_undef, [exp]))
| _ -> prop in
IList.fold_left (fun prop id -> mark_var_as_undefined id prop) prop vars_to_mark
@ -215,15 +215,15 @@ type arith_problem =
| UminusUnsigned of Exp.t * Typ.t
(** Look for an arithmetic problem in [exp] *)
let find_arithmetic_problem proc_node_session prop exp =
let find_arithmetic_problem tenv proc_node_session prop exp =
let exps_divided = ref [] in
let uminus_unsigned = ref [] in
let res = ref prop in
let check_zero e =
match Prop.exp_normalize_prop prop e with
match Prop.exp_normalize_prop tenv prop e with
| Exp.Const c when Const.iszero_int_float c -> true
| _ ->
res := add_or_replace !res (Apred (Adiv0 proc_node_session, [e]));
res := add_or_replace tenv !res (Apred (Adiv0 proc_node_session, [e]));
false in
let rec walk = function
| Exp.Var _ -> ()
@ -253,7 +253,7 @@ let find_arithmetic_problem proc_node_session prop exp =
(** 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. *)
let deallocate_stack_vars (p: 'a Prop.t) pvars =
let deallocate_stack_vars tenv (p: 'a Prop.t) pvars =
let filter = function
| Sil.Hpointsto (Exp.Lvar v, _, _) ->
IList.exists (Pvar.equal v) pvars
@ -270,10 +270,10 @@ let deallocate_stack_vars (p: 'a Prop.t) pvars =
let pi1 = IList.map (fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in
let pi = IList.map (Sil.atom_replace_exp exp_replace) (p.pi @ pi1) in
let p' =
Prop.normalize
Prop.normalize tenv
(Prop.set p
~sub:Sil.sub_empty
~sigma: (Prop.sigma_replace_exp exp_replace sigma_other)) in
~sigma: (Prop.sigma_replace_exp tenv exp_replace sigma_other)) in
let p'' =
let res = ref p' in
let p'_fav = Prop.prop_fav p' in
@ -282,16 +282,16 @@ let deallocate_stack_vars (p: 'a Prop.t) pvars =
begin
stack_vars_address_in_post := v :: !stack_vars_address_in_post;
let pred = Sil.Apred (Adangling DAaddr_stack_var, [Exp.Var freshv]) in
res := add_or_replace !res pred
res := add_or_replace tenv !res pred
end in
IList.iter do_var !fresh_address_vars;
!res in
!stack_vars_address_in_post, IList.fold_left Prop.prop_atom_and p'' pi
!stack_vars_address_in_post, IList.fold_left (Prop.prop_atom_and tenv) p'' pi
(** Input of this method 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. *)
let find_equal_formal_path e prop =
let find_equal_formal_path tenv e prop =
let rec find_in_sigma e seen_hpreds =
IList.fold_right (
fun hpred res ->
@ -321,6 +321,6 @@ let find_equal_formal_path e prop =
match find_in_sigma e [] with
| Some vfs -> Some vfs
| None ->
match get_objc_null prop e with
match get_objc_null tenv prop e with
| Some (Apred (Aobjc_null, [_; vfs])) -> Some vfs
| _ -> None

@ -20,78 +20,78 @@ module F = Format
val is_pred : Sil.atom -> bool
(** Add an attribute associated to the argument expressions *)
val add : ?footprint: bool -> ?polarity: bool ->
val add : Tenv.t -> ?footprint: bool -> ?polarity: bool ->
Prop.normal Prop.t -> PredSymb.t -> Exp.t list -> Prop.normal Prop.t
(** Replace an attribute associated to the expression *)
val add_or_replace : Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
val add_or_replace : Tenv.t -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
(** Replace an attribute associated to the expression, and call the given function with new and
old attributes if they changed. *)
val add_or_replace_check_changed :
(PredSymb.t -> PredSymb.t -> unit) -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
Tenv.t -> (PredSymb.t -> PredSymb.t -> unit) -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
(** Get all the attributes of the prop *)
val get_all : 'a Prop.t -> Sil.atom list
(** Get the attributes associated to the expression, if any *)
val get_for_exp : 'a Prop.t -> Exp.t -> Sil.atom list
val get_for_exp : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom list
(** Retrieve all the atoms that contain a specific attribute *)
val get_for_symb : 'a Prop.t -> PredSymb.t -> Sil.atom list
(** Get the autorelease attribute associated to the expression, if any *)
val get_autorelease : 'a Prop.t -> Exp.t -> Sil.atom option
val get_autorelease : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Get the div0 attribute associated to the expression, if any *)
val get_div0 : 'a Prop.t -> Exp.t -> Sil.atom option
val get_div0 : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Get the objc null attribute associated to the expression, if any *)
val get_objc_null : 'a Prop.t -> Exp.t -> Sil.atom option
val get_objc_null : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Get the observer attribute associated to the expression, if any *)
val get_observer : 'a Prop.t -> Exp.t -> Sil.atom option
val get_observer : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Get the resource attribute associated to the expression, if any *)
val get_resource : 'a Prop.t -> Exp.t -> Sil.atom option
val get_resource : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Get the retval null attribute associated to the expression, if any *)
val get_retval : 'a Prop.t -> Exp.t -> Sil.atom option
val get_retval : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Get the taint attribute associated to the expression, if any *)
val get_taint : 'a Prop.t -> Exp.t -> Sil.atom option
val get_taint : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Get the undef attribute associated to the expression, if any *)
val get_undef : 'a Prop.t -> Exp.t -> Sil.atom option
val get_undef : Tenv.t -> 'a Prop.t -> Exp.t -> Sil.atom option
(** Test for existence of an Adangling DAuninit attribute associated to the exp *)
val has_dangling_uninit : 'a Prop.t -> Exp.t -> bool
val has_dangling_uninit : Tenv.t -> 'a Prop.t -> Exp.t -> bool
(** Remove an attribute *)
val remove : Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
val remove : Tenv.t -> Prop.normal Prop.t -> Sil.atom -> Prop.normal Prop.t
(** Remove all attributes for the given attr *)
val remove_for_attr : Prop.normal Prop.t -> PredSymb.t -> Prop.normal Prop.t
val remove_for_attr : Tenv.t -> Prop.normal Prop.t -> PredSymb.t -> Prop.normal Prop.t
(** Remove all attributes for the given resource and kind *)
val remove_resource :
PredSymb.res_act_kind -> PredSymb.resource -> Prop.normal Prop.t -> Prop.normal Prop.t
Tenv.t -> PredSymb.res_act_kind -> PredSymb.resource -> Prop.normal Prop.t -> Prop.normal Prop.t
(** Apply f to every resource attribute in the prop *)
val map_resource :
Prop.normal Prop.t -> (Exp.t -> PredSymb.res_action -> PredSymb.res_action) -> Prop.normal Prop.t
Tenv.t -> Prop.normal Prop.t -> (Exp.t -> PredSymb.res_action -> PredSymb.res_action) -> Prop.normal Prop.t
(** [replace_objc_null lhs rhs].
If rhs has the objc_null attribute, replace the attribute and set the lhs = 0 *)
val replace_objc_null : Prop.normal Prop.t -> Exp.t -> Exp.t -> Prop.normal Prop.t
val replace_objc_null : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Exp.t -> Prop.normal Prop.t
(** For each Var subexp of the argument with an Aobjc_null attribute,
remove the attribute and conjoin an equality to zero. *)
val nullify_exp_with_objc_null : Prop.normal Prop.t -> Exp.t -> Prop.normal Prop.t
val nullify_exp_with_objc_null : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Prop.normal Prop.t
(** mark Exp.Var's or Exp.Lvar's as undefined *)
val mark_vars_as_undefined :
Prop.normal Prop.t -> Exp.t list -> Procname.t -> Typ.item_annotation -> Location.t ->
Tenv.t -> Prop.normal Prop.t -> Exp.t list -> Procname.t -> Typ.item_annotation -> Location.t ->
PredSymb.path_pos -> Prop.normal Prop.t
(** type for arithmetic problems *)
@ -104,10 +104,10 @@ type arith_problem =
(** Look for an arithmetic problem in [exp] *)
val find_arithmetic_problem :
PredSymb.path_pos -> Prop.normal Prop.t -> Exp.t -> arith_problem option * Prop.normal Prop.t
Tenv.t -> PredSymb.path_pos -> Prop.normal Prop.t -> Exp.t -> arith_problem option * Prop.normal Prop.t
(** 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. *)
val deallocate_stack_vars : Prop.normal Prop.t -> Pvar.t list -> Pvar.t list * Prop.normal Prop.t
val deallocate_stack_vars : Tenv.t -> Prop.normal Prop.t -> Pvar.t list -> Pvar.t list * Prop.normal Prop.t
val find_equal_formal_path : Exp.t -> 'a Prop.t -> Exp.t option
val find_equal_formal_path : Tenv.t -> Exp.t -> 'a Prop.t -> Exp.t option

@ -25,17 +25,17 @@ type rule =
r_new_pi: Prop.normal Prop.t -> Prop.normal Prop.t -> Sil.subst -> Sil.atom list;
r_condition: Prop.normal Prop.t -> Sil.subst -> bool }
let sigma_rewrite p r : Prop.normal Prop.t option =
match (Match.prop_match_with_impl p r.r_condition r.r_vars r.r_root r.r_sigma) with
let sigma_rewrite tenv p r : Prop.normal Prop.t option =
match (Match.prop_match_with_impl tenv p r.r_condition r.r_vars r.r_root r.r_sigma) with
| None -> None
| Some(sub, p_leftover) ->
if not (r.r_condition p_leftover sub) then None
else
let res_pi = r.r_new_pi p p_leftover sub in
let res_sigma = Prop.sigma_sub sub r.r_new_sigma in
let p_with_res_pi = IList.fold_left Prop.prop_atom_and p_leftover res_pi in
let p_with_res_pi = IList.fold_left (Prop.prop_atom_and tenv) p_leftover res_pi in
let p_new = Prop.prop_sigma_star p_with_res_pi res_sigma in
Some (Prop.normalize p_new)
Some (Prop.normalize tenv p_new)
let sigma_fav_list sigma =
Sil.fav_to_list (Prop.sigma_fav sigma)
@ -91,7 +91,7 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.subst) =
(not (IList.intersect Ident.compare fav_insts_of_private_ids fav_p_leftover)) &&
(not (IList.intersect Ident.compare fav_insts_of_private_ids fav_insts_of_public_ids))
let mk_rule_ptspts_ls impl_ok1 impl_ok2 (para: Sil.hpara) =
let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para: Sil.hpara) =
let (ids_tuple, exps_tuple) = create_fresh_primeds_ls para in
let (id_base, id_next, id_end, ids_shared) = ids_tuple in
let (exp_base, exp_next, exp_end, exps_shared) = exps_tuple in
@ -109,7 +109,7 @@ let mk_rule_ptspts_ls impl_ok1 impl_ok2 (para: Sil.hpara) =
let (ids, para_body) = Sil.hpara_instantiate para exp_next exp_end exps_shared in
let para_body_hpats = IList.map mark_impl_flag para_body in
(ids, para_body_hpats) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_next :: (ids_exist_fst @ ids_exist_snd) in
@ -121,7 +121,7 @@ let mk_rule_ptspts_ls impl_ok1 impl_ok2 (para: Sil.hpara) =
r_new_pi = gen_pi_res;
r_condition = condition }
let mk_rule_ptsls_ls k2 impl_ok1 impl_ok2 para =
let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para =
let (ids_tuple, exps_tuple) = create_fresh_primeds_ls para in
let (id_base, id_next, id_end, ids_shared) = ids_tuple in
let (exp_base, exp_next, exp_end, exps_shared) = exps_tuple in
@ -132,8 +132,8 @@ let mk_rule_ptsls_ls k2 impl_ok1 impl_ok2 para =
| hpred :: hpreds ->
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok1 } in
(allow_impl hpred, IList.map allow_impl hpreds) in
let lseg_pat = { Match.hpred = Prop.mk_lseg k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let lseg_pat = { Match.hpred = Prop.mk_lseg tenv k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_next :: ids_exist in
@ -145,17 +145,17 @@ let mk_rule_ptsls_ls k2 impl_ok1 impl_ok2 para =
r_new_sigma = [lseg_res];
r_condition = condition }
let mk_rule_lspts_ls k1 impl_ok1 impl_ok2 para =
let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para =
let (ids_tuple, exps_tuple) = create_fresh_primeds_ls para in
let (id_base, id_next, id_end, ids_shared) = ids_tuple in
let (exp_base, exp_next, exp_end, exps_shared) = exps_tuple in
let lseg_pat = { Match.hpred = Prop.mk_lseg k1 para exp_base exp_next exps_shared; Match.flag = impl_ok1 } in
let lseg_pat = { Match.hpred = Prop.mk_lseg tenv k1 para exp_base exp_next exps_shared; Match.flag = impl_ok1 } in
let (ids_exist, para_inst_pat) =
let (ids, para_body) = Sil.hpara_instantiate para exp_next exp_end exps_shared in
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok2 } in
let para_body_pat = IList.map allow_impl para_body in
(ids, para_body_pat) in
let lseg_res = Prop.mk_lseg Sil.Lseg_NE para exp_base exp_end exps_shared in
let lseg_res = Prop.mk_lseg tenv Sil.Lseg_NE para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_next :: ids_exist in
@ -171,16 +171,16 @@ let lseg_kind_add k1 k2 = match k1, k2 with
| Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_NE -> Sil.Lseg_NE
| Sil.Lseg_PE, Sil.Lseg_PE -> Sil.Lseg_PE
let mk_rule_lsls_ls k1 k2 impl_ok1 impl_ok2 para =
let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para =
let (ids_tuple, exps_tuple) = create_fresh_primeds_ls para in
let (id_base, id_next, id_end, ids_shared) = ids_tuple in
let (exp_base, exp_next, exp_end, exps_shared) = exps_tuple in
let lseg_fst_pat =
{ Match.hpred = Prop.mk_lseg k1 para exp_base exp_next exps_shared; Match.flag = impl_ok1 } in
{ Match.hpred = Prop.mk_lseg tenv k1 para exp_base exp_next exps_shared; Match.flag = impl_ok1 } in
let lseg_snd_pat =
{ Match.hpred = Prop.mk_lseg k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in
{ Match.hpred = Prop.mk_lseg tenv k2 para exp_next exp_end exps_shared; Match.flag = impl_ok2 } in
let k_res = lseg_kind_add k1 k2 in
let lseg_res = Prop.mk_lseg k_res para exp_base exp_end exps_shared in
let lseg_res = Prop.mk_lseg tenv k_res para exp_base exp_end exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = []
(*
let inst_base, inst_next, inst_end =
@ -210,23 +210,23 @@ let mk_rule_lsls_ls k1 k2 impl_ok1 impl_ok2 para =
r_new_pi = gen_pi_res;
r_condition = condition }
let mk_rules_for_sll (para : Sil.hpara) : rule list =
let mk_rules_for_sll tenv (para : Sil.hpara) : rule list =
if not Config.nelseg then
begin
let pts_pts = mk_rule_ptspts_ls true true para in
let pts_pels = mk_rule_ptsls_ls Sil.Lseg_PE true false para in
let pels_pts = mk_rule_lspts_ls Sil.Lseg_PE false true para in
let pels_nels = mk_rule_lsls_ls Sil.Lseg_PE Sil.Lseg_NE false false para in
let nels_pels = mk_rule_lsls_ls Sil.Lseg_NE Sil.Lseg_PE false false para in
let pels_pels = mk_rule_lsls_ls Sil.Lseg_PE Sil.Lseg_PE false false para in
let pts_pts = mk_rule_ptspts_ls tenv true true para in
let pts_pels = mk_rule_ptsls_ls tenv Sil.Lseg_PE true false para in
let pels_pts = mk_rule_lspts_ls tenv Sil.Lseg_PE false true para in
let pels_nels = mk_rule_lsls_ls tenv Sil.Lseg_PE Sil.Lseg_NE false false para in
let nels_pels = mk_rule_lsls_ls tenv Sil.Lseg_NE Sil.Lseg_PE false false para in
let pels_pels = mk_rule_lsls_ls tenv Sil.Lseg_PE Sil.Lseg_PE false false para in
[pts_pts; pts_pels; pels_pts; pels_nels; nels_pels; pels_pels]
end
else
begin
let pts_pts = mk_rule_ptspts_ls true true para in
let pts_nels = mk_rule_ptsls_ls Sil.Lseg_NE true false para in
let nels_pts = mk_rule_lspts_ls Sil.Lseg_NE false true para in
let nels_nels = mk_rule_lsls_ls Sil.Lseg_NE Sil.Lseg_NE false false para in
let pts_pts = mk_rule_ptspts_ls tenv true true para in
let pts_nels = mk_rule_ptsls_ls tenv Sil.Lseg_NE true false para in
let nels_pts = mk_rule_lspts_ls tenv Sil.Lseg_NE false true para in
let nels_nels = mk_rule_lsls_ls tenv Sil.Lseg_NE Sil.Lseg_NE false false para in
[pts_pts; pts_nels; nels_pts; nels_nels]
end
(****************** End of SLL abstraction rules ******************)
@ -234,7 +234,7 @@ let mk_rules_for_sll (para : Sil.hpara) : rule list =
(****************** Start of DLL abstraction rules ******************)
let create_condition_dll = create_condition_ls
let mk_rule_ptspts_dll impl_ok1 impl_ok2 para =
let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para =
let id_iF = Ident.create_fresh Ident.kprimed in
let id_iF' = Ident.create_fresh Ident.kprimed in
let id_oB = Ident.create_fresh Ident.kprimed in
@ -262,7 +262,7 @@ let mk_rule_ptspts_dll impl_ok1 impl_ok2 para =
let (ids, para_body) = Sil.hpara_dll_instantiate para exp_iF' exp_iF exp_oF exps_shared in
let para_body_hpats = IList.map mark_impl_flag para_body in
(ids, para_body_hpats) in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
(* for the case of ptspts since iF'=iB therefore iF' cannot be private*)
@ -281,7 +281,7 @@ let mk_rule_ptspts_dll impl_ok1 impl_ok2 para =
r_new_pi = gen_pi_res;
r_condition = condition }
let mk_rule_ptsdll_dll k2 impl_ok1 impl_ok2 para =
let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para =
let id_iF = Ident.create_fresh Ident.kprimed in
let id_iF' = Ident.create_fresh Ident.kprimed in
let id_oB = Ident.create_fresh Ident.kprimed in
@ -304,8 +304,8 @@ let mk_rule_ptsdll_dll k2 impl_ok1 impl_ok2 para =
| hpred :: hpreds ->
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok1 } in
(allow_impl hpred, IList.map allow_impl hpreds) in
let dllseg_pat = { Match.hpred = Prop.mk_dllseg k2 para exp_iF' exp_iF exp_oF exp_iB exps_shared; Match.flag = impl_ok2 } in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in
let dllseg_pat = { Match.hpred = Prop.mk_dllseg tenv k2 para exp_iF' exp_iF exp_oF exp_iB exps_shared; Match.flag = impl_ok2 } in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_iF':: ids_exist in
@ -317,7 +317,7 @@ let mk_rule_ptsdll_dll k2 impl_ok1 impl_ok2 para =
r_new_sigma = [dllseg_res];
r_condition = condition }
let mk_rule_dllpts_dll k1 impl_ok1 impl_ok2 para =
let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para =
let id_iF = Ident.create_fresh Ident.kprimed in
let id_iF' = Ident.create_fresh Ident.kprimed in
let id_oB = Ident.create_fresh Ident.kprimed in
@ -337,8 +337,8 @@ let mk_rule_dllpts_dll k1 impl_ok1 impl_ok2 para =
let para_inst_pat =
let allow_impl hpred = { Match.hpred = hpred; Match.flag = impl_ok2 } in
IList.map allow_impl para_inst in
let dllseg_pat = { Match.hpred = Prop.mk_dllseg k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared; Match.flag = impl_ok1 } in
let dllseg_res = Prop.mk_dllseg Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let dllseg_pat = { Match.hpred = Prop.mk_dllseg tenv k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared; Match.flag = impl_ok1 } in
let dllseg_res = Prop.mk_dllseg tenv Sil.Lseg_NE para exp_iF exp_oB exp_oF exp_iF' exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = id_oB':: ids_exist in
@ -350,7 +350,7 @@ let mk_rule_dllpts_dll k1 impl_ok1 impl_ok2 para =
r_new_sigma = [dllseg_res];
r_condition = condition }
let mk_rule_dlldll_dll k1 k2 impl_ok1 impl_ok2 para =
let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para =
let id_iF = Ident.create_fresh Ident.kprimed in
let id_iF' = Ident.create_fresh Ident.kprimed in
let id_oB = Ident.create_fresh Ident.kprimed in
@ -368,10 +368,10 @@ let mk_rule_dlldll_dll k1 k2 impl_ok1 impl_ok2 para =
let exp_oF = Exp.Var id_oF in
let exp_iB = Exp.Var id_iB in
let exps_shared = IList.map (fun id -> Exp.Var id) ids_shared in
let lseg_fst_pat = { Match.hpred = Prop.mk_dllseg k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared; Match.flag = impl_ok1 } in
let lseg_snd_pat = { Match.hpred = Prop.mk_dllseg k2 para exp_iF' exp_oB' exp_oF exp_iB exps_shared; Match.flag = impl_ok2 } in
let lseg_fst_pat = { Match.hpred = Prop.mk_dllseg tenv k1 para exp_iF exp_oB exp_iF' exp_oB' exps_shared; Match.flag = impl_ok1 } in
let lseg_snd_pat = { Match.hpred = Prop.mk_dllseg tenv k2 para exp_iF' exp_oB' exp_oF exp_iB exps_shared; Match.flag = impl_ok2 } in
let k_res = lseg_kind_add k1 k2 in
let lseg_res = Prop.mk_dllseg k_res para exp_iF exp_oB exp_oF exp_iB exps_shared in
let lseg_res = Prop.mk_dllseg tenv k_res para exp_iF exp_oB exp_oF exp_iB exps_shared in
let gen_pi_res _ _ (_: Sil.subst) = [] in
let condition =
let ids_private = [id_iF'; id_oB'] in
@ -383,23 +383,23 @@ let mk_rule_dlldll_dll k1 k2 impl_ok1 impl_ok2 para =
r_new_pi = gen_pi_res;
r_condition = condition }
let mk_rules_for_dll (para : Sil.hpara_dll) : rule list =
let mk_rules_for_dll tenv (para : Sil.hpara_dll) : rule list =
if not Config.nelseg then
begin
let pts_pts = mk_rule_ptspts_dll true true para in
let pts_pedll = mk_rule_ptsdll_dll Sil.Lseg_PE true false para in
let pedll_pts = mk_rule_dllpts_dll Sil.Lseg_PE false true para in
let pedll_nedll = mk_rule_dlldll_dll Sil.Lseg_PE Sil.Lseg_NE false false para in
let nedll_pedll = mk_rule_dlldll_dll Sil.Lseg_NE Sil.Lseg_PE false false para in
let pedll_pedll = mk_rule_dlldll_dll Sil.Lseg_PE Sil.Lseg_PE false false para in
let pts_pts = mk_rule_ptspts_dll tenv true true para in
let pts_pedll = mk_rule_ptsdll_dll tenv Sil.Lseg_PE true false para in
let pedll_pts = mk_rule_dllpts_dll tenv Sil.Lseg_PE false true para in
let pedll_nedll = mk_rule_dlldll_dll tenv Sil.Lseg_PE Sil.Lseg_NE false false para in
let nedll_pedll = mk_rule_dlldll_dll tenv Sil.Lseg_NE Sil.Lseg_PE false false para in
let pedll_pedll = mk_rule_dlldll_dll tenv Sil.Lseg_PE Sil.Lseg_PE false false para in
[pts_pts; pts_pedll; pedll_pts; pedll_nedll; nedll_pedll; pedll_pedll]
end
else
begin
let ptspts_dll = mk_rule_ptspts_dll true true para in
let ptsdll_dll = mk_rule_ptsdll_dll Sil.Lseg_NE true false para in
let dllpts_dll = mk_rule_dllpts_dll Sil.Lseg_NE false true para in
let dlldll_dll = mk_rule_dlldll_dll Sil.Lseg_NE Sil.Lseg_NE false false para in
let ptspts_dll = mk_rule_ptspts_dll tenv true true para in
let ptsdll_dll = mk_rule_ptsdll_dll tenv Sil.Lseg_NE true false para in
let dllpts_dll = mk_rule_dllpts_dll tenv Sil.Lseg_NE false true para in
let dlldll_dll = mk_rule_dlldll_dll tenv Sil.Lseg_NE Sil.Lseg_NE false false para in
[ptspts_dll; ptsdll_dll; dllpts_dll; dlldll_dll]
end
(****************** End of DLL abstraction rules ******************)
@ -433,7 +433,7 @@ let typ_get_recursive_flds tenv typ_exp =
L.err "@.typ_get_recursive: unexpected type expr: %a@." (Sil.pp_exp pe_text) typ_exp;
assert false
let discover_para_roots p root1 next1 root2 next2 : Sil.hpara option =
let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option =
let eq_arg1 = Exp.equal root1 next1 in
let eq_arg2 = Exp.equal root2 next2 in
let precondition_check = (not eq_arg1 && not eq_arg2) in
@ -442,13 +442,13 @@ let discover_para_roots p root1 next1 root2 next2 : Sil.hpara option =
let corres = [(next1, next2)] in
let todos = [(root1, root2)] in
let sigma = p.Prop.sigma in
match Match.find_partial_iso (Prover.check_equal p) corres todos sigma with
match Match.find_partial_iso tenv (Prover.check_equal tenv p) corres todos sigma with
| None -> None
| Some (new_corres, new_sigma1, _, _) ->
let hpara, _ = Match.hpara_create new_corres new_sigma1 root1 next1 in
let hpara, _ = Match.hpara_create tenv new_corres new_sigma1 root1 next1 in
Some hpara
let discover_para_dll_roots p root1 blink1 flink1 root2 blink2 flink2 : Sil.hpara_dll option =
let discover_para_dll_roots tenv p root1 blink1 flink1 root2 blink2 flink2 : Sil.hpara_dll option =
let eq_arg1 = Exp.equal root1 blink1 in
let eq_arg1' = Exp.equal root1 flink1 in
let eq_arg2 = Exp.equal root2 blink2 in
@ -459,10 +459,10 @@ let discover_para_dll_roots p root1 blink1 flink1 root2 blink2 flink2 : Sil.hpar
let corres = [(blink1, blink2); (flink1, flink2)] in
let todos = [(root1, root2)] in
let sigma = p.Prop.sigma in
match Match.find_partial_iso (Prover.check_equal p) corres todos sigma with
match Match.find_partial_iso tenv (Prover.check_equal tenv p) corres todos sigma with
| None -> None
| Some (new_corres, new_sigma1, _, _) ->
let hpara_dll, _ = Match.hpara_dll_create new_corres new_sigma1 root1 blink1 flink1 in
let hpara_dll, _ = Match.hpara_dll_create tenv new_corres new_sigma1 root1 blink1 flink1 in
Some hpara_dll
let discover_para_candidates tenv p =
@ -544,9 +544,9 @@ let discover_para_dll_candidates tenv p =
let discover_para tenv p =
let candidates = discover_para_candidates tenv p in
let already_defined para paras =
IList.exists (fun para' -> Match.hpara_iso para para') paras in
IList.exists (fun para' -> Match.hpara_iso tenv para para') paras in
let f paras (root, next, out) =
match (discover_para_roots p root next next out) with
match (discover_para_roots tenv p root next next out) with
| None -> paras
| Some para -> if already_defined para paras then paras else para :: paras in
IList.fold_left f [] candidates
@ -558,9 +558,9 @@ let discover_para_dll tenv p =
*)
let candidates = discover_para_dll_candidates tenv p in
let already_defined para paras =
IList.exists (fun para' -> Match.hpara_dll_iso para para') paras in
IList.exists (fun para' -> Match.hpara_dll_iso tenv para para') paras in
let f paras (iF, oB, iF', oF) =
match (discover_para_dll_roots p iF oB iF' iF' iF oF) with
match (discover_para_dll_roots tenv p iF oB iF' iF' iF oF) with
| None -> paras
| Some para -> if already_defined para paras then paras else para :: paras in
IList.fold_left f [] candidates
@ -680,9 +680,9 @@ let hpara_special_cases_dll hpara : Sil.hpara_dll list =
let special_cases = sigma_special_cases hpara.Sil.evars_dll hpara.Sil.body_dll in
IList.map update_para special_cases
let abs_rules_apply_rsets (rsets: rule_set list) (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
let abs_rules_apply_rsets tenv (rsets: rule_set list) (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
let apply_rule (changed, p) r =
match (sigma_rewrite p r) with
match (sigma_rewrite tenv p r) with
| None -> (changed, p)
| Some p' ->
(*
@ -722,10 +722,10 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
end in
let (todo_paras_sll, todo_paras_dll) =
let eq_sll para rset = match rset with
| (SLL para', _) -> Match.hpara_iso para para'
| (SLL para', _) -> Match.hpara_iso tenv para para'
| _ -> false in
let eq_dll para rset = match rset with
| (DLL para', _) -> Match.hpara_dll_iso para para'
| (DLL para', _) -> Match.hpara_dll_iso tenv para para'
| _ -> false in
let filter_sll para =
not (IList.exists (eq_sll para) old_rsets) &&
@ -738,17 +738,17 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
(todo_paras_sll, todo_paras_dll) in
let f_recurse () =
let todo_rsets_sll =
IList.map (fun para -> (SLL para, mk_rules_for_sll para)) todo_paras_sll in
IList.map (fun para -> (SLL para, mk_rules_for_sll tenv para)) todo_paras_sll in
let todo_rsets_dll =
IList.map (fun para -> (DLL para, mk_rules_for_dll para)) todo_paras_dll in
IList.map (fun para -> (DLL para, mk_rules_for_dll tenv para)) todo_paras_dll in
new_rsets := !new_rsets @ todo_rsets_sll @ todo_rsets_dll;
let p' = abs_rules_apply_rsets todo_rsets_sll p in
let p'' = abs_rules_apply_rsets todo_rsets_dll p' in
let p' = abs_rules_apply_rsets tenv todo_rsets_sll p in
let p'' = abs_rules_apply_rsets tenv todo_rsets_dll p' in
discover_then_abstract p'' in
match todo_paras_sll, todo_paras_dll with
| [], [] -> p
| _ -> f_recurse () in
let p1 = abs_rules_apply_rsets old_rsets p_in in
let p1 = abs_rules_apply_rsets tenv old_rsets p_in in
let p2 = discover_then_abstract p1 in
let new_rules = old_rsets @ !new_rsets in
set_current_rules new_rules;
@ -759,7 +759,7 @@ let abs_rules_apply tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t =
(****************** End of the ADT abs_rules ******************)
(****************** Start of Main Abstraction Functions ******************)
let abstract_pure_part p ~(from_abstract_footprint: bool) =
let abstract_pure_part tenv p ~(from_abstract_footprint: bool) =
let do_pure pure =
let pi_filtered =
let sigma = p.Prop.sigma in
@ -801,12 +801,12 @@ let abstract_pure_part p ~(from_abstract_footprint: bool) =
let new_pi_footprint = do_pure p.Prop.pi_fp in
Prop.set eprop' ~pi_fp:new_pi_footprint
else eprop' in
Prop.normalize eprop''
Prop.normalize tenv eprop''
(** Collect symbolic garbage from pi and sigma *)
let abstract_gc p =
let abstract_gc tenv p =
let pi = p.Prop.pi in
let p_without_pi = Prop.normalize (Prop.set p ~pi:[]) in
let p_without_pi = Prop.normalize tenv (Prop.set p ~pi:[]) in
let fav_p_without_pi = Prop.prop_fav p_without_pi in
(* let weak_filter atom =
let fav_atom = atom_fav atom in
@ -826,10 +826,10 @@ let abstract_gc p =
||
IList.intersect Ident.compare (Sil.fav_to_list fav_a) (Sil.fav_to_list fav_p_without_pi) in
let new_pi = IList.filter strong_filter pi in
let prop = Prop.normalize (Prop.set p ~pi:new_pi) in
let prop = Prop.normalize tenv (Prop.set p ~pi:new_pi) in
match Prop.prop_iter_create prop with
| None -> prop
| Some iter -> Prop.prop_iter_to_prop (Prop.prop_iter_gc_fields iter)
| Some iter -> Prop.prop_iter_to_prop tenv (Prop.prop_iter_gc_fields iter)
module IdMap = Map.Make (Ident) (** maps from identifiers *)
@ -999,7 +999,7 @@ let remove_opt _prop =
(** Checks if cycle has fields (derived from a property or directly defined as ivar) with attributes
weak/unsafe_unretained/assing *)
let cycle_has_weak_or_unretained_or_assign_field cycle =
let cycle_has_weak_or_unretained_or_assign_field _tenv cycle =
(* returns items annotation for field fn in struct t *)
let get_item_annotation t fn =
match t with
@ -1028,12 +1028,12 @@ let cycle_has_weak_or_unretained_or_assign_field cycle =
else do_cycle c' in
do_cycle cycle
let check_observer_is_unsubscribed_deallocation prop e =
let pvar_opt = match Attribute.get_resource prop e with
let check_observer_is_unsubscribed_deallocation tenv prop e =
let pvar_opt = match Attribute.get_resource tenv prop e with
| Some (Apred (Aresource ({ ra_vpath = Some (Dpvar pvar) }), _)) -> Some pvar
| _ -> None in
let loc = State.get_loc () in
match Attribute.get_observer prop e with
match Attribute.get_observer tenv prop e with
| Some (Apred (Aobserver, _)) ->
(match pvar_opt with
| Some pvar when Config.nsnotification_center_checker_backend ->
@ -1098,13 +1098,13 @@ let check_junk ?original_prop pname tenv prop =
(* find the alloc attribute of one of the roots of hpred, if it exists *)
let res = ref None in
let do_entry e =
check_observer_is_unsubscribed_deallocation prop e;
match Attribute.get_resource prop e with
check_observer_is_unsubscribed_deallocation tenv prop e;
match Attribute.get_resource tenv prop e with
| Some (Apred (Aresource ({ ra_kind = Racquire }) as a, _)) ->
L.d_str "ATTRIBUTE: "; PredSymb.d_attribute a; L.d_ln ();
res := Some a
| _ ->
(match Attribute.get_undef prop e with
(match Attribute.get_undef tenv prop e with
| Some (Apred (Aundef _ as a, _)) ->
res := Some a
| _ -> ()) in
@ -1112,7 +1112,7 @@ let check_junk ?original_prop pname tenv prop =
!res in
L.d_decrease_indent 1;
let is_undefined = Option.map_default PredSymb.is_undef false alloc_attribute in
let resource = match Errdesc.hpred_is_open_resource prop hpred with
let resource = match Errdesc.hpred_is_open_resource tenv prop hpred with
| Some res -> res
| None -> PredSymb.Rmemory PredSymb.Mmalloc in
let ml_bucket_opt =
@ -1143,7 +1143,7 @@ let check_junk ?original_prop pname tenv prop =
let cycle = get_var_retain_cycle (remove_opt original_prop) in
let ignore_cycle =
(IList.length cycle = 0) ||
(cycle_has_weak_or_unretained_or_assign_field cycle) in
(cycle_has_weak_or_unretained_or_assign_field tenv cycle) in
ignore_cycle, exn_retain_cycle cycle
| Some _, Rmemory Mobjc
| Some _, Rmemory Mnew
@ -1153,7 +1153,7 @@ let check_junk ?original_prop pname tenv prop =
| Some _, Rignore -> true, exn_leak
| Some _, Rfile -> false, exn_leak
| Some _, Rlock -> false, exn_leak
| _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter hpred ->
| _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter tenv hpred ->
(* When it's a cycle and the object has a ref counter then
we have a retain cycle. Objc object may not have the
Mobjc qualifier when added in footprint doing abduction *)
@ -1196,7 +1196,7 @@ let check_junk ?original_prop pname tenv prop =
Prop.sigma_equal prop.Prop.sigma sigma_new
&& Prop.sigma_equal prop.Prop.sigma_fp sigma_fp_new
then prop
else Prop.normalize (Prop.set prop ~sigma:sigma_new ~sigma_fp:sigma_fp_new)
else Prop.normalize tenv (Prop.set prop ~sigma:sigma_new ~sigma_fp:sigma_fp_new)
(** Check whether the prop contains junk.
If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *)
@ -1207,22 +1207,23 @@ let abstract_junk ?original_prop pname tenv prop =
(** Remove redundant elements in an array, and check for junk afterwards *)
let remove_redundant_array_elements pname tenv prop =
Absarray.array_abstraction_performed := false;
let prop' = Absarray.remove_redundant_elements prop in
let prop' = Absarray.remove_redundant_elements tenv prop in
check_junk ~original_prop: (Some(prop)) pname tenv prop'
let abstract_prop pname tenv ~(rename_primed: bool) ~(from_abstract_footprint: bool) p =
Absarray.array_abstraction_performed := false;
let pure_abs_p = abstract_pure_part ~from_abstract_footprint: true p in
let pure_abs_p = abstract_pure_part tenv ~from_abstract_footprint: true p in
let array_abs_p =
if from_abstract_footprint
then pure_abs_p
else abstract_pure_part ~from_abstract_footprint: from_abstract_footprint (Absarray.abstract_array_check pure_abs_p) in
else
abstract_pure_part tenv ~from_abstract_footprint (Absarray.abstract_array_check tenv pure_abs_p) in
let abs_p = abs_rules_apply tenv array_abs_p in
let abs_p = abstract_gc abs_p in (* abstraction might enable more gc *)
let abs_p = abstract_gc tenv abs_p in (* abstraction might enable more gc *)
let abs_p = check_junk ~original_prop: (Some(p)) pname tenv abs_p in
let ren_abs_p =
if rename_primed
then Prop.prop_rename_primed_footprint_vars abs_p
then Prop.prop_rename_primed_footprint_vars tenv abs_p
else abs_p in
ren_abs_p
@ -1273,9 +1274,9 @@ let abstract_footprint pname (tenv : Tenv.t) (prop : Prop.normal Prop.t) : Prop.
let p_abs =
abstract_prop
pname tenv ~rename_primed: false
~from_abstract_footprint: true (Prop.normalize p) in
~from_abstract_footprint: true (Prop.normalize tenv p) in
let prop' = set_footprint_for_abs prop p_abs added_local_vars in
Prop.normalize prop'
Prop.normalize tenv prop'
let _abstract pname pay tenv p =
if pay then SymOp.pay(); (* pay one symop *)
@ -1290,9 +1291,9 @@ let abstract_no_symop pname tenv p =
let lifted_abstract pname tenv pset =
let f p =
if Prover.check_inconsistency p then None
if Prover.check_inconsistency tenv p then None
else Some (abstract pname tenv p) in
let abstracted_pset = Propset.map_option f pset in
let abstracted_pset = Propset.map_option tenv f pset in
abstracted_pset
(***************** End of Main Abstraction Functions *****************)

@ -38,16 +38,16 @@ module StrexpMatch : sig
val find_path : sigma -> path -> t
(** Find a strexp with the given property. *)
val find : sigma -> (strexp_data -> bool) -> t list
val find : Tenv.t -> sigma -> (strexp_data -> bool) -> t list
(** Get the array *)
val get_data : t -> strexp_data
val get_data : Tenv.t -> t -> strexp_data
(** Replace the strexp at a given position by a new strexp *)
val replace_strexp : bool -> t -> Sil.strexp -> sigma
val replace_strexp : Tenv.t -> bool -> t -> Sil.strexp -> sigma
(** Replace the index in the array at a given position with the new index *)
val replace_index : bool -> t -> Exp.t -> Exp.t -> sigma
val replace_index : Tenv.t -> bool -> t -> Exp.t -> Exp.t -> sigma
(*
(** Get the partition of the sigma: the unmatched part of the sigma and the matched hpred *)
val get_sigma_partition : t -> sigma * Sil.hpred
@ -64,7 +64,7 @@ end = struct
type path = Exp.t * (syn_offset list)
(** Find a strexp and a type at the given syntactic offset list *)
let rec get_strexp_at_syn_offsets se t syn_offs =
let rec get_strexp_at_syn_offsets tenv se t syn_offs =
match se, t, syn_offs with
| _, _, [] -> (se, t)
| Sil.Estruct (fsel, _), Typ.Tstruct { Typ.instance_fields }, Field (fld, _) :: syn_offs' ->
@ -72,10 +72,10 @@ end = struct
let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) ->
Ident.fieldname_equal f' fld) instance_fields) in
get_strexp_at_syn_offsets se' t' syn_offs'
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| Sil.Earray (_, esel, _), Typ.Tarray (t', _), Index ind :: syn_offs' ->
let se' = snd (IList.find (fun (i', _) -> Exp.equal i' ind) esel) in
get_strexp_at_syn_offsets se' t' syn_offs'
get_strexp_at_syn_offsets tenv se' t' syn_offs'
| _ ->
L.d_strln "Failure of get_strexp_at_syn_offsets";
L.d_str "se: "; Sil.d_sexp se; L.d_ln ();
@ -83,7 +83,7 @@ end = struct
assert false
(** Replace a strexp at the given syntactic offset list *)
let rec replace_strexp_at_syn_offsets se t syn_offs update =
let rec replace_strexp_at_syn_offsets tenv se t syn_offs update =
match se, t, syn_offs with
| _, _, [] ->
update se
@ -92,7 +92,7 @@ end = struct
let t' = (fun (_,y,_) -> y)
(IList.find (fun (f', _, _) ->
Ident.fieldname_equal f' fld) instance_fields) in
let se_mod = replace_strexp_at_syn_offsets se' t' syn_offs' update in
let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let fsel' =
IList.map (fun (f'', se'') ->
if Ident.fieldname_equal f'' fld then (fld, se_mod) else (f'', se'')
@ -100,7 +100,7 @@ end = struct
Sil.Estruct (fsel', inst)
| Sil.Earray (len, esel, inst), Typ.Tarray (t', _), Index idx :: syn_offs' ->
let se' = snd (IList.find (fun (i', _) -> Exp.equal i' idx) esel) in
let se_mod = replace_strexp_at_syn_offsets se' t' syn_offs' update in
let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in
let esel' =
IList.map (fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel in
Sil.Earray (len, esel', inst)
@ -143,7 +143,7 @@ end = struct
(sigma, hpred, syn_offs)
(** Find a sub strexp with the given property. Can raise [Not_found] *)
let find (sigma : sigma) (pred : strexp_data -> bool) : t list =
let find _tenv (sigma : sigma) (pred : strexp_data -> bool) : t list =
let found = ref [] in
let rec find_offset_sexp sigma_other hpred root offs se typ =
let offs' = IList.rev offs in
@ -192,10 +192,10 @@ end = struct
end
(** Get the matched strexp *)
let get_data ((_ , hpred, syn_offs) : t) = match hpred with
let get_data tenv ((_ , hpred, syn_offs) : t) = match hpred with
| Sil.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in
let se', t' = get_strexp_at_syn_offsets se t syn_offs in
let se', t' = get_strexp_at_syn_offsets tenv se t syn_offs in
let path' = (root, syn_offs) in
(path', se', t')
| _ -> assert false
@ -205,7 +205,7 @@ end = struct
IList.map (fun hpred'' -> if hpred''== hpred then hpred' else hpred'') sigma
(** Replace the strexp at the given offset in the given hpred *)
let hpred_replace_strexp footprint_part hpred syn_offs update =
let hpred_replace_strexp tenv footprint_part hpred syn_offs update =
let update se' =
let se_in = update se' in
match se', se_in with
@ -221,19 +221,19 @@ end = struct
match hpred with
| Sil.Hpointsto (root, se, te) ->
let t = Exp.texp_to_typ None te in
let se' = replace_strexp_at_syn_offsets se t syn_offs update in
let se' = replace_strexp_at_syn_offsets tenv se t syn_offs update in
Sil.Hpointsto (root, se', te)
| _ -> assert false
end
(** Replace the strexp at a given position by a new strexp *)
let replace_strexp footprint_part ((sigma, hpred, syn_offs) : t) se_in =
let replace_strexp tenv footprint_part ((sigma, hpred, syn_offs) : t) se_in =
let update _ = se_in in
let hpred' = hpred_replace_strexp footprint_part hpred syn_offs update in
let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in
replace_hpred (sigma, hpred, syn_offs) hpred'
(** Replace the index in the array at a given position with the new index *)
let replace_index footprint_part ((sigma, hpred, syn_offs) : t) (index: Exp.t) (index': Exp.t) =
let replace_index tenv footprint_part ((sigma, hpred, syn_offs) : t) (index: Exp.t) (index': Exp.t) =
let update se' =
match se' with
| Sil.Earray (len, esel, inst) ->
@ -243,7 +243,7 @@ end = struct
) esel in
Sil.Earray (len, esel', inst)
| _ -> assert false in
let hpred' = hpred_replace_strexp footprint_part hpred syn_offs update in
let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in
replace_hpred (sigma, hpred, syn_offs) hpred'
(*
(** Get the partition of the sigma: the unmatched part of the sigma and the matched hpred *)
@ -254,14 +254,14 @@ end = struct
(** Replace the strexp and the unmatched part of the sigma by the given inputs *)
let replace_strexp_sigma footprint_part ((_, hpred, syn_offs) : t) se_in sigma_in =
let new_sigma = hpred :: sigma_in in
let sigma' = replace_strexp footprint_part (new_sigma, hpred, syn_offs) se_in in
let sigma' = replace_strexp tenv footprint_part (new_sigma, hpred, syn_offs) se_in in
IList.sort Sil.hpred_compare sigma'
*)
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]. *)
let prop_replace_path_index
let prop_replace_path_index tenv
(p: Prop.exposed Prop.t)
(path: StrexpMatch.path)
(map : (Exp.t * Exp.t) list) : Prop.exposed Prop.t
@ -270,8 +270,8 @@ let prop_replace_path_index
let expmap_list =
IList.fold_left (fun acc_outer e_path ->
IList.fold_left (fun acc_inner (old_index, new_index) ->
let old_e_path_index = Prop.exp_normalize_prop p (Exp.Lindex(e_path, old_index)) in
let new_e_path_index = Prop.exp_normalize_prop p (Exp.Lindex(e_path, new_index)) in
let old_e_path_index = Prop.exp_normalize_prop tenv p (Exp.Lindex(e_path, old_index)) in
let new_e_path_index = Prop.exp_normalize_prop tenv p (Exp.Lindex(e_path, new_index)) in
(old_e_path_index, new_e_path_index) :: acc_inner
) acc_outer map
) [] elist_path in
@ -284,7 +284,7 @@ let prop_replace_path_index
(** 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]. *)
let prop_update_sigma_and_fp_sigma
let prop_update_sigma_and_fp_sigma tenv
(p : Prop.normal Prop.t)
(update : bool -> sigma -> sigma * bool) : Prop.normal Prop.t * bool
=
@ -295,7 +295,7 @@ let prop_update_sigma_and_fp_sigma
let sigma_fp', changed' = update true ep1.Prop.sigma_fp in
(Prop.set ep1 ~sigma_fp:sigma_fp', changed')
else (ep1, false) in
(Prop.normalize ep2, changed || changed2)
(Prop.normalize tenv ep2, changed || changed2)
(** Remember whether array abstraction was performed (to be reset before calling Abs.abstract) *)
let array_abstraction_performed = ref false
@ -303,7 +303,7 @@ 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. *)
let generic_strexp_abstract
let generic_strexp_abstract tenv
(abstraction_name : string)
(p_in : Prop.normal Prop.t)
(can_abstract_ : StrexpMatch.strexp_data -> bool)
@ -315,7 +315,7 @@ let generic_strexp_abstract
if r then array_abstraction_performed := true;
r in
let find_strexp_to_abstract p0 =
let find sigma = StrexpMatch.find sigma can_abstract in
let find sigma = StrexpMatch.find tenv sigma can_abstract in
let matchings_cur = find p0.Prop.sigma in
let matchings_fp = find p0.Prop.sigma_fp in
matchings_cur, matchings_fp in
@ -329,7 +329,7 @@ let generic_strexp_abstract
let matched, footprint_part, matchings_cur_fp' = match_select_next matchings_cur_fp in
let n = IList.length (snd matchings_cur_fp') + 1 in
if Config.trace_absarray then (L.d_strln ("Num of fp candidates " ^ (string_of_int n)));
let strexp_data = StrexpMatch.get_data matched in
let strexp_data = StrexpMatch.get_data tenv matched in
let p1, changed = do_abstract footprint_part p0 strexp_data in
if changed then (p1, true)
else match_abstract p0 matchings_cur_fp'
@ -352,13 +352,13 @@ let generic_strexp_abstract
(** Return [true] if there's a pointer to the index *)
let index_is_pointed_to (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t) : bool =
let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t) : bool =
let indices =
let index_plus_one = Exp.BinOp(Binop.PlusA, index, Exp.one) in
[index; index_plus_one] in
let add_index_to_paths =
let elist_path = StrexpMatch.path_to_exps path in
let add_index i e = Prop.exp_normalize_prop p (Exp.Lindex(e, i)) in
let add_index i e = Prop.exp_normalize_prop tenv p (Exp.Lindex(e, i)) in
fun i -> IList.map (add_index i) elist_path in
let pointers = IList.flatten (IList.map add_index_to_paths indices) in
let filter = function
@ -368,7 +368,7 @@ let index_is_pointed_to (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index:
(** Given [p] containing an array at [path], blur [index] in it *)
let blur_array_index
let blur_array_index tenv
(p: Prop.normal Prop.t)
(path: StrexpMatch.path)
(index: Exp.t) : Prop.normal Prop.t
@ -383,36 +383,36 @@ let blur_array_index
begin
let sigma_fp = p.Prop.sigma_fp in
let matched_fp = StrexpMatch.find_path sigma_fp path in
let sigma_fp' = StrexpMatch.replace_index true matched_fp index fresh_index in
let sigma_fp' = StrexpMatch.replace_index tenv true matched_fp index fresh_index in
Prop.set p ~sigma_fp:sigma_fp'
end
else Prop.expose p
with Not_found -> Prop.expose p in
let p3 =
let matched = StrexpMatch.find_path p.Prop.sigma path in
let sigma' = StrexpMatch.replace_index false matched index fresh_index in
let sigma' = StrexpMatch.replace_index tenv false matched index fresh_index in
Prop.set p2 ~sigma:sigma' in
let p4 =
let index_next = Exp.BinOp(Binop.PlusA, index, Exp.one) in
let fresh_index_next = Exp.BinOp (Binop.PlusA, fresh_index, Exp.one) in
let map = [(index, fresh_index); (index_next, fresh_index_next)] in
prop_replace_path_index p3 path map in
Prop.normalize p4
prop_replace_path_index tenv p3 path map in
Prop.normalize tenv p4
with Not_found -> p
(** Given [p] containing an array at [root], blur [indices] in it *)
let blur_array_indices
let blur_array_indices tenv
(p: Prop.normal Prop.t)
(root: StrexpMatch.path)
(indices: Exp.t list) : Prop.normal Prop.t * bool
=
let f prop index = blur_array_index prop root index in
let f prop index = blur_array_index tenv prop root index in
(IList.fold_left f p indices, IList.length indices > 0)
(** Given [p] containing an array at [root], only keep [indices] in it *)
let keep_only_indices
let keep_only_indices tenv
(p: Prop.normal Prop.t)
(path: StrexpMatch.path)
(indices: Exp.t list) : Prop.normal Prop.t * bool
@ -420,7 +420,7 @@ let keep_only_indices
let prune_sigma footprint_part sigma =
try
let matched = StrexpMatch.find_path sigma path in
let (_, se, _) = StrexpMatch.get_data matched in
let (_, se, _) = StrexpMatch.get_data tenv matched in
match se with
| Sil.Earray (len, esel, inst) ->
let esel', esel_leftover' =
@ -428,12 +428,12 @@ let keep_only_indices
if esel_leftover' == [] then (sigma, false)
else begin
let se' = Sil.Earray (len, esel', inst) in
let sigma' = StrexpMatch.replace_strexp footprint_part matched se' in
let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in
(sigma', true)
end
| _ -> (sigma, false)
with Not_found -> (sigma, false) in
prop_update_sigma_and_fp_sigma p prune_sigma
prop_update_sigma_and_fp_sigma tenv p prune_sigma
(** If the type is array, check whether we should do abstraction *)
@ -452,7 +452,7 @@ let strexp_can_abstract ((_, se, typ) : StrexpMatch.strexp_data) : bool =
(** This function abstracts a strexp *)
let strexp_do_abstract
let strexp_do_abstract tenv
footprint_part p ((path, se_in, _) : StrexpMatch.strexp_data) : Prop.normal Prop.t * bool =
if Config.trace_absarray && footprint_part then
(L.d_str "strexp_do_abstract (footprint)"; L.d_ln ());
@ -471,7 +471,7 @@ let strexp_do_abstract
if Config.trace_absarray then (L.d_strln "Returns"; Prop.d_prop p3; L.d_ln (); L.d_ln ());
(p3, changed2 || changed3) in
let prune_and_blur_indices =
prune_and_blur Sil.d_exp_list keep_only_indices blur_array_indices in
prune_and_blur Sil.d_exp_list (keep_only_indices tenv) (blur_array_indices tenv) in
let partition_abstract should_keep abstract ksel default_keys =
let keep_ksel, remove_ksel = IList.partition should_keep ksel in
@ -481,7 +481,7 @@ let strexp_do_abstract
abstract keep_keys' keep_keys' in
let do_array_footprint esel =
(* array case footprint: keep only the last index, and blur it *)
let should_keep (i0, _) = index_is_pointed_to p path i0 in
let should_keep (i0, _) = index_is_pointed_to tenv p path i0 in
let abstract = prune_and_blur_indices path in
let default_indices =
match IList.map fst esel with
@ -501,7 +501,7 @@ let strexp_do_abstract
abstract keep_keys' [] in
let do_array_reexecution esel =
(* array case re-execution: remove and blur constant and primed indices *)
let is_pointed index = index_is_pointed_to p path index in
let is_pointed index = index_is_pointed_to tenv p path index in
let should_keep (index, _) = match index with
| Exp.Const _ -> is_pointed index
| Exp.Var id -> Ident.is_normal id || is_pointed index
@ -516,8 +516,8 @@ let strexp_do_abstract
if !Config.footprint then do_footprint ()
else do_reexecution ()
let strexp_abstract (p : Prop.normal Prop.t) : Prop.normal Prop.t =
generic_strexp_abstract "strexp_abstract" p strexp_can_abstract strexp_do_abstract
let strexp_abstract tenv (p : Prop.normal Prop.t) : Prop.normal Prop.t =
generic_strexp_abstract tenv "strexp_abstract" p strexp_can_abstract (strexp_do_abstract tenv)
let report_error prop =
L.d_strln "Check after array abstraction: FAIL";
@ -525,11 +525,11 @@ let report_error prop =
assert false
(** Check performed after the array abstraction to see whether it was successful. Raise assert false in case of failure *)
let check_after_array_abstraction prop =
let check_after_array_abstraction tenv prop =
let check_index root offs (ind, _) =
if !Config.footprint then
let path = StrexpMatch.path_from_exp_offsets root offs in
index_is_pointed_to prop path ind
index_is_pointed_to tenv prop path ind
else not (Sil.fav_exists (Sil.exp_fav ind) Ident.is_primed) in
let rec check_se root offs typ = function
| Sil.Eexp _ -> ()
@ -554,13 +554,13 @@ let check_after_array_abstraction prop =
check_sigma prop.Prop.sigma_fp
(** Apply array abstraction and check the result *)
let abstract_array_check p =
let p_res = strexp_abstract p in
check_after_array_abstraction p_res;
let abstract_array_check tenv p =
let p_res = strexp_abstract tenv p in
check_after_array_abstraction tenv p_res;
p_res
(** remove redundant elements in an array *)
let remove_redundant_elements prop =
let remove_redundant_elements tenv prop =
Prop.d_prop prop; L.d_ln ();
let occurs_at_most_once : Ident.t -> bool = (* the variable occurs at most once in the footprint or current part *)
let fav_curr = Sil.fav_new () in
@ -609,5 +609,5 @@ let remove_redundant_elements prop =
let sigma_fp' = remove_redundant_sigma true prop.Prop.sigma_fp in
if !modified then
let prop' = Prop.set prop ~sigma:sigma' ~sigma_fp:sigma_fp' in
Prop.normalize prop'
Prop.normalize tenv prop'
else prop

@ -13,10 +13,10 @@ open! Utils
(** Abstraction for Arrays *)
(** Apply array abstraction and check the result *)
val abstract_array_check : Prop.normal Prop.t -> Prop.normal Prop.t
val abstract_array_check : Tenv.t -> Prop.normal Prop.t -> Prop.normal Prop.t
(** Remember whether array abstraction was performed (to be reset before calling Abs.abstract) *)
val array_abstraction_performed : bool ref
(** remove redundant elements in an array *)
val remove_redundant_elements : Prop.normal Prop.t -> Prop.normal Prop.t
val remove_redundant_elements : Tenv.t -> Prop.normal Prop.t -> Prop.normal Prop.t

@ -178,6 +178,9 @@ let iterate_callbacks store_summary call_graph exe_env =
(iterate_cluster_callbacks originally_defined_procs exe_env)
(cluster procs_to_analyze);
IList.iter store_summary procs_to_analyze;
IList.iter (fun proc_name ->
let tenv = Exe_env.get_tenv ~create:true exe_env proc_name in
store_summary tenv proc_name
) procs_to_analyze;
Config.curr_language := saved_language

@ -44,4 +44,4 @@ val register_cluster_callback : Config.language option -> cluster_callback_t ->
val unregister_all_callbacks : unit -> unit
(** Invoke all the registered callbacks. *)
val iterate_callbacks : (Procname.t -> unit) -> Cg.t -> Exe_env.t -> unit
val iterate_callbacks : (Tenv.t -> Procname.t -> unit) -> Cg.t -> Exe_env.t -> unit

@ -435,7 +435,7 @@ module FreshVarExp : sig
val init : unit -> unit
val get_fresh_exp : Exp.t -> Exp.t -> Exp.t
val get_induced_pi : unit -> Prop.pi
val get_induced_pi : Tenv.t -> unit -> Prop.pi
val final : unit -> unit
(*
@ -461,14 +461,14 @@ end = struct
t := (e1, e2, e)::!t;
e
let get_induced_atom acc strict_lower upper e =
let ineq_lower = Prop.mk_inequality (Exp.BinOp(Binop.Lt, strict_lower, e)) in
let ineq_upper = Prop.mk_inequality (Exp.BinOp(Binop.Le, e, upper)) in
let get_induced_atom tenv acc strict_lower upper e =
let ineq_lower = Prop.mk_inequality tenv (Exp.BinOp(Binop.Lt, strict_lower, e)) in
let ineq_upper = Prop.mk_inequality tenv (Exp.BinOp(Binop.Le, e, upper)) in
ineq_lower:: ineq_upper:: acc
let minus2_to_2 = IList.map IntLit.of_int [-2; -1; 0; 1; 2]
let get_induced_pi () =
let get_induced_pi tenv () =
let t_sorted = IList.sort entry_compare !t in
let add_and_chk_eq e1 e1' n =
@ -477,7 +477,7 @@ end = struct
| _ -> false in
let add_and_gen_eq e e' n =
let e_plus_n = Exp.BinOp(Binop.PlusA, e, Exp.int n) in
Prop.mk_eq e_plus_n e' in
Prop.mk_eq tenv e_plus_n e' in
let rec f_eqs_entry ((e1, e2, e) as entry) eqs_acc t_seen = function
| [] -> eqs_acc, t_seen
| ((e1', e2', e') as entry'):: t_rest' ->
@ -504,7 +504,7 @@ end = struct
if IntLit.leq n1 n2 then (n1 -- IntLit.one, n2) else (n2 -- IntLit.one, n1) in
let e_strict_lower1 = Exp.int strict_lower1 in
let e_upper1 = Exp.int upper1 in
get_induced_atom acc e_strict_lower1 e_upper1 e
get_induced_atom tenv acc e_strict_lower1 e_upper1 e
| _ -> acc in
IList.fold_left f_ineqs eqs t_minimal
@ -533,7 +533,7 @@ module Rename : sig
val check : (side -> Exp.t -> Exp.t list -> bool) -> bool
val get_others : side -> Exp.t -> (Exp.t * Exp.t) option
val get_other_atoms : side -> Sil.atom -> (Sil.atom * Sil.atom) option
val get_other_atoms : Tenv.t -> side -> Sil.atom -> (Sil.atom * Sil.atom) option
val lookup : side -> Exp.t -> Exp.t
val lookup_list : side -> Exp.t list -> Exp.t list
@ -688,7 +688,7 @@ end = struct
Some (e_res'', e_op''))
| _ -> None
let get_other_atoms side atom_in =
let get_other_atoms tenv side atom_in =
let build_other_atoms construct side e =
if Config.trace_join then (L.d_str "build_other_atoms: "; Sil.d_exp e; L.d_ln ());
let others1 = get_others_direct_or_induced side e in
@ -716,30 +716,30 @@ end = struct
match atom_in with
| Sil.Aneq((Exp.Var id as e), e') | Sil.Aneq(e', (Exp.Var id as e))
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
build_other_atoms (fun e0 -> Prop.mk_neq e0 e') side e
build_other_atoms (fun e0 -> Prop.mk_neq tenv e0 e') side e
| Sil.Apred (a, (Var id as e) :: es)
when not (Ident.is_normal id) && IList.for_all exp_contains_only_normal_ids es ->
build_other_atoms (fun e0 -> Prop.mk_pred a (e0 :: es)) side e
build_other_atoms (fun e0 -> Prop.mk_pred tenv a (e0 :: es)) side e
| Sil.Anpred (a, (Var id as e) :: es)
when not (Ident.is_normal id) && IList.for_all exp_contains_only_normal_ids es ->
build_other_atoms (fun e0 -> Prop.mk_npred a (e0 :: es)) side e
build_other_atoms (fun e0 -> Prop.mk_npred tenv a (e0 :: es)) side e
| Sil.Aeq((Exp.Var id as e), e') | Sil.Aeq(e', (Exp.Var id as e))
when (exp_contains_only_normal_ids e' && not (Ident.is_normal id)) ->
build_other_atoms (fun e0 -> Prop.mk_eq e0 e') side e
build_other_atoms (fun e0 -> Prop.mk_eq tenv e0 e') side e
| Sil.Aeq(Exp.BinOp(Binop.Le, e, e'), Exp.Const (Const.Cint i))
| Sil.Aeq(Exp.Const (Const.Cint i), Exp.BinOp(Binop.Le, e, e'))
when IntLit.isone i && (exp_contains_only_normal_ids e') ->
let construct e0 = Prop.mk_inequality (Exp.BinOp(Binop.Le, e0, e')) in
let construct e0 = Prop.mk_inequality tenv (Exp.BinOp(Binop.Le, e0, e')) in
build_other_atoms construct side e
| Sil.Aeq(Exp.BinOp(Binop.Lt, e', e), Exp.Const (Const.Cint i))
| Sil.Aeq(Exp.Const (Const.Cint i), Exp.BinOp(Binop.Lt, e', e))
when IntLit.isone i && (exp_contains_only_normal_ids e') ->
let construct e0 = Prop.mk_inequality (Exp.BinOp(Binop.Lt, e', e0)) in
let construct e0 = Prop.mk_inequality tenv (Exp.BinOp(Binop.Lt, e', e0)) in
build_other_atoms construct side e
| Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ -> None
@ -1187,57 +1187,57 @@ let kind_meet k1 k2 = match k1, k2 with
| _, Sil.Lseg_NE -> Sil.Lseg_NE
| Sil.Lseg_PE, Sil.Lseg_PE -> Sil.Lseg_PE
let hpara_partial_join (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara =
if Match.hpara_match_with_impl true hpara2 hpara1 then
let hpara_partial_join tenv (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara =
if Match.hpara_match_with_impl tenv true hpara2 hpara1 then
hpara1
else if Match.hpara_match_with_impl true hpara1 hpara2 then
else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then
hpara2
else
(L.d_strln "failure reason 53"; raise IList.Fail)
let hpara_partial_meet (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara =
if Match.hpara_match_with_impl true hpara2 hpara1 then
let hpara_partial_meet tenv (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara =
if Match.hpara_match_with_impl tenv true hpara2 hpara1 then
hpara2
else if Match.hpara_match_with_impl true hpara1 hpara2 then
else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then
hpara1
else
(L.d_strln "failure reason 54"; raise IList.Fail)
let hpara_dll_partial_join (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll =
if Match.hpara_dll_match_with_impl true hpara2 hpara1 then
let hpara_dll_partial_join tenv (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll =
if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then
hpara1
else if Match.hpara_dll_match_with_impl true hpara1 hpara2 then
else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then
hpara2
else
(L.d_strln "failure reason 55"; raise IList.Fail)
let hpara_dll_partial_meet (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll =
if Match.hpara_dll_match_with_impl true hpara2 hpara1 then
let hpara_dll_partial_meet tenv (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll =
if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then
hpara2
else if Match.hpara_dll_match_with_impl true hpara1 hpara2 then
else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then
hpara1
else
(L.d_strln "failure reason 56"; raise IList.Fail)
(** {2 Join and Meet for hpred} *)
let hpred_partial_join mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2: Sil.hpred)
let hpred_partial_join tenv mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2: Sil.hpred)
: Sil.hpred =
let e1, e2, e = todo in
match hpred1, hpred2 with
| Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) ->
let te = exp_partial_join te1 te2 in
Prop.mk_ptsto e (strexp_partial_join mode se1 se2) te
Prop.mk_ptsto tenv e (strexp_partial_join mode se1 se2) te
| Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) ->
let hpara' = hpara_partial_join hpara1 hpara2 in
let hpara' = hpara_partial_join tenv hpara1 hpara2 in
let next' = exp_partial_join next1 next2 in
let shared' = exp_list_partial_join shared1 shared2 in
Prop.mk_lseg (kind_join k1 k2) hpara' e next' shared'
Prop.mk_lseg tenv (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) ->
let fwd1 = Exp.equal e1 iF1 in
let fwd2 = Exp.equal e2 iF2 in
let hpara' = hpara_dll_partial_join para1 para2 in
let hpara' = hpara_dll_partial_join tenv para1 para2 in
let iF', iB' =
if (fwd1 && fwd2) then (e, exp_partial_join iB1 iB2)
else if (not fwd1 && not fwd2) then (exp_partial_join iF1 iF2, e)
@ -1245,28 +1245,28 @@ let hpred_partial_join mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (h
let oF' = exp_partial_join oF1 oF2 in
let oB' = exp_partial_join oB1 oB2 in
let shared' = exp_list_partial_join shared1 shared2 in
Prop.mk_dllseg (kind_join k1 k2) hpara' iF' oB' oF' iB' shared'
Prop.mk_dllseg tenv (kind_join k1 k2) hpara' iF' oB' oF' iB' shared'
| _ ->
assert false
let hpred_partial_meet (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2: Sil.hpred)
let hpred_partial_meet tenv (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2: Sil.hpred)
: Sil.hpred =
let e1, e2, e = todo in
match hpred1, hpred2 with
| Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) when Exp.equal te1 te2 ->
Prop.mk_ptsto e (strexp_partial_meet se1 se2) te1
Prop.mk_ptsto tenv e (strexp_partial_meet se1 se2) te1
| Sil.Hpointsto _, _ | _, Sil.Hpointsto _ ->
(L.d_strln "failure reason 58"; raise IList.Fail)
| Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) ->
let hpara' = hpara_partial_meet hpara1 hpara2 in
let hpara' = hpara_partial_meet tenv hpara1 hpara2 in
let next' = exp_partial_meet next1 next2 in
let shared' = exp_list_partial_meet shared1 shared2 in
Prop.mk_lseg (kind_meet k1 k2) hpara' e next' shared'
Prop.mk_lseg tenv (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) ->
let fwd1 = Exp.equal e1 iF1 in
let fwd2 = Exp.equal e2 iF2 in
let hpara' = hpara_dll_partial_meet para1 para2 in
let hpara' = hpara_dll_partial_meet tenv para1 para2 in
let iF', iB' =
if (fwd1 && fwd2) then (e, exp_partial_meet iB1 iB2)
else if (not fwd1 && not fwd2) then (exp_partial_meet iF1 iF2, e)
@ -1274,15 +1274,15 @@ let hpred_partial_meet (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2
let oF' = exp_partial_meet oF1 oF2 in
let oB' = exp_partial_meet oB1 oB2 in
let shared' = exp_list_partial_meet shared1 shared2 in
Prop.mk_dllseg (kind_meet k1 k2) hpara' iF' oB' oF' iB' shared'
Prop.mk_dllseg tenv (kind_meet k1 k2) hpara' iF' oB' oF' iB' shared'
| _ ->
assert false
(** {2 Join and Meet for Sigma} *)
let find_hpred_by_address (e: Exp.t) (sigma: Prop.sigma) : Sil.hpred option * Prop.sigma =
let find_hpred_by_address tenv (e: Exp.t) (sigma: Prop.sigma) : Sil.hpred option * Prop.sigma =
let is_root_for_e e' =
match (Prover.is_root Prop.prop_emp e' e) with
match (Prover.is_root tenv Prop.prop_emp e' e) with
| None -> false
| Some _ -> true in
let contains_e = function
@ -1319,7 +1319,7 @@ let sigma_renaming_check (lhs: side) (sigma: Prop.sigma) (sigma_new: Prop.sigma)
let sigma_renaming_check_lhs = sigma_renaming_check Lhs
let sigma_renaming_check_rhs = sigma_renaming_check Rhs
let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma)
(sigma1_in: Prop.sigma) (sigma2_in: Prop.sigma) : (Prop.sigma * Prop.sigma * Prop.sigma) =
let lookup_and_expand side e e' =
@ -1392,12 +1392,12 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
let res =
match side with
| Lhs ->
let res, target', other' = sigma_partial_join' mode [] target other in
let res, target', other' = sigma_partial_join' tenv mode [] target other in
list_is_empty target';
sigma_renaming_check_lhs target res;
other'
| Rhs ->
let res, other', target' = sigma_partial_join' mode [] other target in
let res, other', target' = sigma_partial_join' tenv mode [] other target in
list_is_empty target';
sigma_renaming_check_rhs target res;
other' in
@ -1428,17 +1428,17 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
L.d_strln "SIGMA2 ="; Prop.d_sigma sigma2_in; L.d_ln ();
L.d_ln ()
end;
let hpred_opt1, sigma1 = find_hpred_by_address e1 sigma1_in in
let hpred_opt2, sigma2 = find_hpred_by_address e2 sigma2_in in
let hpred_opt1, sigma1 = find_hpred_by_address tenv e1 sigma1_in in
let hpred_opt2, sigma2 = find_hpred_by_address tenv e2 sigma2_in in
match hpred_opt1, hpred_opt2 with
| None, None ->
sigma_partial_join' mode sigma_acc sigma1 sigma2
sigma_partial_join' tenv mode sigma_acc sigma1 sigma2
| Some (Sil.Hlseg (k, _, _, _, _) as lseg), None
| Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg), None ->
if (not Config.nelseg) || (Sil.lseg_kind_equal k Sil.Lseg_PE) then
let sigma_acc' = join_list_and_non Lhs e lseg e1 e2 :: sigma_acc in
sigma_partial_join' mode sigma_acc' sigma1 sigma2
sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2
else
(L.d_strln "failure reason 62"; raise IList.Fail)
@ -1446,25 +1446,25 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
| None, Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg) ->
if (not Config.nelseg) || (Sil.lseg_kind_equal k Sil.Lseg_PE) then
let sigma_acc' = join_list_and_non Rhs e lseg e2 e1 :: sigma_acc in
sigma_partial_join' mode sigma_acc' sigma1 sigma2
sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2
else
(L.d_strln "failure reason 63"; raise IList.Fail)
| None, _ | _, None -> (L.d_strln "failure reason 64"; raise IList.Fail)
| Some (hpred1), Some (hpred2) when same_pred hpred1 hpred2 ->
let hpred_res1 = hpred_partial_join mode todo_curr hpred1 hpred2 in
sigma_partial_join' mode (hpred_res1:: sigma_acc) sigma1 sigma2
let hpred_res1 = hpred_partial_join tenv mode todo_curr hpred1 hpred2 in
sigma_partial_join' tenv mode (hpred_res1:: sigma_acc) sigma1 sigma2
| Some (Sil.Hlseg _ as lseg), Some (hpred2) ->
let sigma2' = cut_lseg Lhs todo_curr lseg (hpred2:: sigma2) in
let sigma_acc' = update_list Lhs lseg e :: sigma_acc in
sigma_partial_join' mode sigma_acc' sigma1 sigma2'
sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2'
| Some (hpred1), Some (Sil.Hlseg _ as lseg) ->
let sigma1' = cut_lseg Rhs todo_curr lseg (hpred1:: sigma1) in
let sigma_acc' = update_list Rhs lseg e :: sigma_acc in
sigma_partial_join' mode sigma_acc' sigma1' sigma2
sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2
| Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some (hpred2)
when Exp.equal e1 iF1 ->
@ -1472,7 +1472,7 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
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
CheckJoin.add Lhs iF1 iB1; (* add equality iF1=iB1 *)
sigma_partial_join' mode sigma_acc' sigma1 sigma2'
sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2'
| Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some (hpred2)
(* when Exp.equal e1 iB1 *) ->
@ -1480,7 +1480,7 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
let sigma2' = cut_dllseg Lhs todo_curr iB1 dllseg (hpred2:: sigma2) in
let sigma_acc' = update_dllseg Lhs dllseg iF_res e :: sigma_acc in
CheckJoin.add Lhs iF1 iB1; (* add equality iF1=iB1 *)
sigma_partial_join' mode sigma_acc' sigma1 sigma2'
sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2'
| Some (hpred1), Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg)
when Exp.equal e2 iF2 ->
@ -1488,14 +1488,14 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
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
CheckJoin.add Rhs iF2 iB2; (* add equality iF2=iB2 *)
sigma_partial_join' mode sigma_acc' sigma1' sigma2
sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2
| Some (hpred1), Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) ->
let iF_res = exp_partial_join e1 iF2 in
let sigma1' = cut_dllseg Rhs todo_curr iB2 dllseg (hpred1:: sigma1) in
let sigma_acc' = update_dllseg Rhs dllseg iF_res e :: sigma_acc in
CheckJoin.add Rhs iF2 iB2; (* add equality iF2=iB2 *)
sigma_partial_join' mode sigma_acc' sigma1' sigma2
sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2
| Some (Sil.Hpointsto _), Some (Sil.Hpointsto _) ->
assert false (* Should be handled by a guarded case *)
@ -1505,11 +1505,11 @@ let rec sigma_partial_join' mode (sigma_acc: Prop.sigma)
| _:: _, _:: _ -> L.d_strln "todo is empty, but the sigmas are not"; raise IList.Fail
| _ -> sigma_acc, sigma1_in, sigma2_in
let sigma_partial_join mode (sigma1: Prop.sigma) (sigma2: Prop.sigma)
let sigma_partial_join tenv mode (sigma1: Prop.sigma) (sigma2: Prop.sigma)
: (Prop.sigma * Prop.sigma * Prop.sigma) =
CheckJoin.init mode sigma1 sigma2;
let lost_little = CheckJoin.lost_little in
let s1, s2, s3 = sigma_partial_join' mode [] sigma1 sigma2 in
let s1, s2, s3 = sigma_partial_join' tenv mode [] sigma1 sigma2 in
try
if Rename.check lost_little then
(CheckJoin.final (); (s1, s2, s3))
@ -1521,7 +1521,7 @@ let sigma_partial_join mode (sigma1: Prop.sigma) (sigma2: Prop.sigma)
with
| exn -> (CheckJoin.final (); raise exn)
let rec sigma_partial_meet' (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) (sigma2_in: Prop.sigma)
let rec sigma_partial_meet' tenv (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) (sigma2_in: Prop.sigma)
: Prop.sigma =
try
let todo_curr = Todo.pop () in
@ -1531,25 +1531,25 @@ let rec sigma_partial_meet' (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) (sig
L.d_str "PROP1="; Prop.d_sigma sigma1_in; L.d_ln ();
L.d_str "PROP2="; Prop.d_sigma sigma2_in; L.d_ln ();
L.d_ln ();
let hpred_opt1, sigma1 = find_hpred_by_address e1 sigma1_in in
let hpred_opt2, sigma2 = find_hpred_by_address e2 sigma2_in in
let hpred_opt1, sigma1 = find_hpred_by_address tenv e1 sigma1_in in
let hpred_opt2, sigma2 = find_hpred_by_address tenv e2 sigma2_in in
match hpred_opt1, hpred_opt2 with
| None, None ->
sigma_partial_meet' sigma_acc sigma1 sigma2
sigma_partial_meet' tenv sigma_acc sigma1 sigma2
| Some hpred, None ->
let hpred' = hpred_construct_fresh Lhs hpred in
let sigma_acc' = hpred' :: sigma_acc in
sigma_partial_meet' sigma_acc' sigma1 sigma2
sigma_partial_meet' tenv sigma_acc' sigma1 sigma2
| None, Some hpred ->
let hpred' = hpred_construct_fresh Rhs hpred in
let sigma_acc' = hpred' :: sigma_acc in
sigma_partial_meet' sigma_acc' sigma1 sigma2
sigma_partial_meet' tenv sigma_acc' sigma1 sigma2
| Some (hpred1), Some (hpred2) when same_pred hpred1 hpred2 ->
let hpred' = hpred_partial_meet todo_curr hpred1 hpred2 in
sigma_partial_meet' (hpred':: sigma_acc) sigma1 sigma2
let hpred' = hpred_partial_meet tenv todo_curr hpred1 hpred2 in
sigma_partial_meet' tenv (hpred':: sigma_acc) sigma1 sigma2
| Some _, Some _ ->
(L.d_strln "failure reason 65"; raise IList.Fail)
@ -1559,8 +1559,8 @@ let rec sigma_partial_meet' (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) (sig
| [], [] -> sigma_acc
| _, _ -> L.d_strln "todo is empty, but the sigmas are not"; raise IList.Fail
let sigma_partial_meet (sigma1: Prop.sigma) (sigma2: Prop.sigma) : Prop.sigma =
sigma_partial_meet' [] sigma1 sigma2
let sigma_partial_meet tenv (sigma1: Prop.sigma) (sigma2: Prop.sigma) : Prop.sigma =
sigma_partial_meet' tenv [] sigma1 sigma2
let widening_top =
(* nearly max_int but not so close to overflow *)
@ -1570,7 +1570,7 @@ let widening_bottom =
IntLit.of_int64 Int64.min_int ++ IntLit.of_int 1000
(** {2 Join and Meet for Pi} *)
let pi_partial_join mode
let pi_partial_join tenv mode
(ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t)
(pi1: Prop.pi) (pi2: Prop.pi) : Prop.pi
=
@ -1603,11 +1603,11 @@ let pi_partial_join mode
if IntLit.leq n first_try then
if IntLit.leq n second_try then second_try else first_try
else widening_top in
let a' = Prop.mk_inequality (Exp.BinOp(Binop.Le, e, Exp.int bound)) in
let a' = Prop.mk_inequality tenv (Exp.BinOp(Binop.Le, e, Exp.int bound)) in
Some a'
| Some (e, _), [] ->
let bound = widening_top in
let a' = Prop.mk_inequality (Exp.BinOp(Binop.Le, e, Exp.int bound)) in
let a' = Prop.mk_inequality tenv (Exp.BinOp(Binop.Le, e, Exp.int bound)) in
Some a'
| _ ->
begin
@ -1616,7 +1616,7 @@ let pi_partial_join mode
| Some (n, e) ->
let bound =
if IntLit.leq IntLit.minus_one n then IntLit.minus_one else widening_bottom in
let a' = Prop.mk_inequality (Exp.BinOp(Binop.Lt, Exp.int bound, e)) in
let a' = Prop.mk_inequality tenv (Exp.BinOp(Binop.Lt, Exp.int bound, e)) in
Some a'
end in
let is_stronger_le e n a =
@ -1629,21 +1629,21 @@ let pi_partial_join mode
| Some (n', e') -> Exp.equal e e' && IntLit.lt n n' in
let join_atom_check_pre p a =
(* check for atoms in pre mode: fail if the negation is implied by the other side *)
let not_a = Prover.atom_negate a in
if (Prover.check_atom p not_a) then
let not_a = Prover.atom_negate tenv a in
if (Prover.check_atom tenv p not_a) then
(L.d_str "join_atom_check failed on "; Sil.d_atom a; L.d_ln (); raise IList.Fail) in
let join_atom_check_attribute p a =
(* check for attribute: fail if the attribute is not in the other side *)
if not (Prover.check_atom p a) then
if not (Prover.check_atom tenv p a) then
(L.d_str "join_atom_check_attribute failed on "; Sil.d_atom a; L.d_ln (); raise IList.Fail) in
let join_atom side p_op pi_op a =
(* try to find the atom corresponding to a on the other side, and check if it is implied *)
match Rename.get_other_atoms side a with
match Rename.get_other_atoms tenv side a with
| None -> None
| Some (a_res, a_op) ->
if mode = JoinState.Pre then join_atom_check_pre p_op a_op;
if Attribute.is_pred a then join_atom_check_attribute p_op a_op;
if not (Prover.check_atom p_op a_op) then None
if not (Prover.check_atom tenv p_op a_op) then None
else begin
match Prop.atom_exp_le_const a_op with
| None ->
@ -1684,11 +1684,11 @@ let pi_partial_join mode
L.d_str "pi2: "; Prop.d_pi pi2; L.d_ln ()
end;
let atom_list1 =
let p2 = Prop.normalize ep2 in
let p2 = Prop.normalize tenv ep2 in
IList.fold_left (handle_atom_with_widening Lhs p2 pi2) [] pi1 in
if Config.trace_join then (L.d_str "atom_list1: "; Prop.d_pi atom_list1; L.d_ln ());
let atom_list_combined =
let p1 = Prop.normalize ep1 in
let p1 = Prop.normalize tenv ep1 in
IList.fold_left (handle_atom_with_widening Rhs p1 pi1) atom_list1 pi2 in
if Config.trace_join then
(L.d_str "atom_list_combined: "; Prop.d_pi atom_list_combined; L.d_ln ());
@ -1701,7 +1701,7 @@ let pi_partial_join mode
atom_list_res
end
let pi_partial_meet (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop.t) : Prop.normal Prop.t =
let pi_partial_meet tenv (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop.t) : Prop.normal Prop.t =
let sub1 = Rename.to_subst_emb Lhs in
let sub2 = Rename.to_subst_emb Rhs in
@ -1714,21 +1714,21 @@ let pi_partial_meet (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop.t) :
Sil.atom_sub sub atom
else (L.d_str "handle_atom failed on "; Sil.d_atom atom; L.d_ln (); raise IList.Fail) in
let f1 p' atom =
Prop.prop_atom_and p' (handle_atom sub1 dom1 atom) in
Prop.prop_atom_and tenv p' (handle_atom sub1 dom1 atom) in
let f2 p' atom =
Prop.prop_atom_and p' (handle_atom sub2 dom2 atom) in
Prop.prop_atom_and tenv p' (handle_atom sub2 dom2 atom) in
let pi1 = ep1.Prop.pi in
let pi2 = ep2.Prop.pi in
let p_pi1 = IList.fold_left f1 p pi1 in
let p_pi2 = IList.fold_left f2 p_pi1 pi2 in
if (Prover.check_inconsistency_base p_pi2) then (L.d_strln "check_inconsistency_base failed"; raise IList.Fail)
if (Prover.check_inconsistency_base tenv p_pi2) then (L.d_strln "check_inconsistency_base failed"; raise IList.Fail)
else p_pi2
(** {2 Join and Meet for Prop} *)
let eprop_partial_meet (ep1: 'a Prop.t) (ep2: 'b Prop.t) : 'c Prop.t =
let eprop_partial_meet tenv (ep1: 'a Prop.t) (ep2: 'b Prop.t) : 'c Prop.t =
SymOp.pay(); (* pay one symop *)
let sigma1 = ep1.Prop.sigma in
let sigma2 = ep2.Prop.sigma in
@ -1749,19 +1749,19 @@ let eprop_partial_meet (ep1: 'a Prop.t) (ep2: 'b Prop.t) : 'c Prop.t =
else begin
let todos = IList.map (fun x -> (x, x, x)) es in
IList.iter Todo.push todos;
let sigma_new = sigma_partial_meet sigma1 sigma2 in
let sigma_new = sigma_partial_meet tenv sigma1 sigma2 in
let ep = Prop.set ep1 ~sigma:sigma_new in
let ep' = Prop.set ep ~pi:[] in
let p' = Prop.normalize ep' in
let p'' = pi_partial_meet p' ep1 ep2 in
let res = Prop.prop_rename_primed_footprint_vars p'' in
let p' = Prop.normalize tenv ep' in
let p'' = pi_partial_meet tenv p' ep1 ep2 in
let res = Prop.prop_rename_primed_footprint_vars tenv p'' in
res
end
let prop_partial_meet p1 p2 =
let prop_partial_meet tenv p1 p2 =
Rename.init (); FreshVarExp.init (); Todo.init ();
try
let res = eprop_partial_meet p1 p2 in
let res = eprop_partial_meet tenv p1 p2 in
Rename.final (); FreshVarExp.final (); Todo.final ();
Some res
with exn ->
@ -1772,7 +1772,7 @@ let prop_partial_meet p1 p2 =
| _ -> raise exn
end
let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t =
let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t =
SymOp.pay(); (* pay one symop *)
let sigma1 = ep1.Prop.sigma in
let sigma2 = ep2.Prop.sigma in
@ -1809,32 +1809,32 @@ let eprop_partial_join' mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.
end;
let todos = IList.map (fun x -> (x, x, x)) es1 in
IList.iter Todo.push todos;
match sigma_partial_join mode sigma1 sigma2 with
match sigma_partial_join tenv mode sigma1 sigma2 with
| sigma_new, [], [] ->
L.d_strln "sigma_partial_join succeeded";
let ep_sub =
let ep = Prop.set ep1 ~pi:[] in
Prop.set ep ~sub:sub_common in
let p_sub_sigma =
Prop.normalize (Prop.set ep_sub ~sigma:sigma_new) in
Prop.normalize tenv (Prop.set ep_sub ~sigma:sigma_new) in
let p_sub_sigma_pi =
let pi1 = ep1.Prop.pi @ eqs_from_sub1 in
let pi2 = ep2.Prop.pi @ eqs_from_sub2 in
let pi' = pi_partial_join mode ep1 ep2 pi1 pi2 in
let pi' = pi_partial_join tenv mode ep1 ep2 pi1 pi2 in
L.d_strln "pi_partial_join succeeded";
let pi_from_fresh_vars = FreshVarExp.get_induced_pi () in
let pi_from_fresh_vars = FreshVarExp.get_induced_pi tenv () in
let pi_all = pi' @ pi_from_fresh_vars in
IList.fold_left Prop.prop_atom_and p_sub_sigma pi_all in
IList.fold_left (Prop.prop_atom_and tenv) p_sub_sigma pi_all in
p_sub_sigma_pi
| _ ->
L.d_strln "leftovers not empty"; raise IList.Fail
let footprint_partial_join' (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.t) : Prop.normal Prop.t * Prop.normal Prop.t =
let footprint_partial_join' tenv (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.t) : Prop.normal Prop.t * Prop.normal Prop.t =
if not !Config.footprint then p1, p2
else begin
let fp1 = Prop.extract_footprint p1 in
let fp2 = Prop.extract_footprint p2 in
let efp = eprop_partial_join' JoinState.Pre fp1 fp2 in
let efp = eprop_partial_join' tenv JoinState.Pre fp1 fp2 in
let pi_fp =
let pi_fp0 = Prop.get_pure efp in
let f a = Sil.fav_for_all (Sil.atom_fav a) Ident.is_footprint in
@ -1846,7 +1846,7 @@ let footprint_partial_join' (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.t) :
sigma_fp0 in
let ep1' = Prop.set p1 ~pi_fp ~sigma_fp in
let ep2' = Prop.set p2 ~pi_fp ~sigma_fp in
Prop.normalize ep1', Prop.normalize ep2'
Prop.normalize tenv ep1', Prop.normalize tenv ep2'
end
let prop_partial_join pname tenv mode p1 p2 =
@ -1861,10 +1861,10 @@ let prop_partial_join pname tenv mode p1 p2 =
(if !Config.footprint then JoinState.set_footprint true);
Rename.init (); FreshVarExp.init (); Todo.init ();
try
let p1', p2' = footprint_partial_join' p1 p2 in
let p1', p2' = footprint_partial_join' tenv p1 p2 in
let rename_footprint = Rename.reset () in
Todo.reset rename_footprint;
let res = Some (eprop_partial_join' mode (Prop.expose p1') (Prop.expose p2')) in
let res = Some (eprop_partial_join' tenv mode (Prop.expose p1') (Prop.expose p2')) in
(if !Config.footprint then JoinState.set_footprint false);
Rename.final (); FreshVarExp.final (); Todo.final ();
res
@ -1877,10 +1877,10 @@ let prop_partial_join pname tenv mode p1 p2 =
end
| Some _ -> res_by_implication_only
let eprop_partial_join mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t =
let eprop_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t =
Rename.init (); FreshVarExp.init (); Todo.init ();
try
let res = eprop_partial_join' mode ep1 ep2 in
let res = eprop_partial_join' tenv mode ep1 ep2 in
Rename.final (); FreshVarExp.final (); Todo.final ();
res
with exn -> (Rename.final (); FreshVarExp.final (); Todo.final (); raise exn)
@ -1920,16 +1920,16 @@ let pathset_collapse_impl pname tenv pset =
let plist' = list_reduce "JOIN_IMPL" Prop.d_prop f plist in
Paths.PathSet.from_renamed_list plist'
let jprop_partial_join mode jp1 jp2 =
let jprop_partial_join tenv mode jp1 jp2 =
let p1, p2 = Prop.expose (Specs.Jprop.to_prop jp1), Prop.expose (Specs.Jprop.to_prop jp2) in
try
let p = eprop_partial_join mode p1 p2 in
let p_renamed = Prop.prop_rename_primed_footprint_vars p in
let p = eprop_partial_join tenv mode p1 p2 in
let p_renamed = Prop.prop_rename_primed_footprint_vars tenv p in
Some (Specs.Jprop.Joined (0, p_renamed, jp1, jp2))
with IList.Fail -> None
let jplist_collapse mode jplist =
let f = jprop_partial_join mode in
let jplist_collapse tenv mode jplist =
let f = jprop_partial_join tenv mode in
list_reduce "JOIN" Specs.Jprop.d_shallow f jplist
@ -1945,18 +1945,18 @@ let jprop_list_add_ids jplist =
Specs.Jprop.Joined (!seq_number, p, jp1', jp2') in
IList.map (fun (p, path) -> (do_jprop p, path)) jplist
let proplist_collapse mode plist =
let proplist_collapse tenv mode plist =
let jplist = IList.map (fun (p, path) -> (Specs.Jprop.Prop (0, p), path)) plist in
let jplist_joined = jplist_collapse mode (jplist_collapse mode jplist) in
let jplist_joined = jplist_collapse tenv mode (jplist_collapse tenv mode jplist) in
jprop_list_add_ids jplist_joined
let proplist_collapse_pre plist =
let proplist_collapse_pre tenv plist =
let plist' = IList.map (fun p -> (p, ())) plist in
IList.map fst (proplist_collapse JoinState.Pre plist')
IList.map fst (proplist_collapse tenv JoinState.Pre plist')
let pathset_collapse pset =
let pathset_collapse tenv pset =
let plist = Paths.PathSet.elements pset in
let plist' = proplist_collapse JoinState.Post plist in
let plist' = proplist_collapse tenv JoinState.Post plist in
Paths.PathSet.from_renamed_list (IList.map (fun (p, path) -> (Specs.Jprop.to_prop p, path)) plist')
let join_time = ref 0.0
@ -1994,7 +1994,7 @@ let pathset_join
let (ppa2_new, ppalist1_cur') = join_proppath_plist [] ppa2'' ppalist1_cur in
join ppalist1_cur' (ppa2_new:: ppalist2_acc') ppalist2_rest' in
let _ppalist1_res, _ppalist2_res = join ppalist1 [] ppalist2 in
let ren l = IList.map (fun (p, x) -> (Prop.prop_rename_primed_footprint_vars p, x)) l in
let ren l = IList.map (fun (p, x) -> (Prop.prop_rename_primed_footprint_vars tenv p, x)) l in
let ppalist1_res, ppalist2_res = ren _ppalist1_res, ren _ppalist2_res in
let res = (Paths.PathSet.from_renamed_list ppalist1_res, Paths.PathSet.from_renamed_list ppalist2_res) in
join_time := !join_time +. (Unix.gettimeofday () -. initial_time);
@ -2010,14 +2010,14 @@ let pathset_join
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 proplist_meet_generate tenv plist =
let props_done = ref Propset.empty in
let combine p (porig, pcombined) =
SymOp.pay (); (* pay one symop *)
L.d_strln ".... MEET ....";
L.d_strln "MEET SYM HEAP1: "; Prop.d_prop p; L.d_ln ();
L.d_strln "MEET SYM HEAP2: "; Prop.d_prop pcombined; L.d_ln ();
match prop_partial_meet p pcombined with
match prop_partial_meet tenv p pcombined with
| None ->
L.d_strln_color Red ".... MEET FAILED ...."; L.d_ln ();
(porig, pcombined)
@ -2032,17 +2032,17 @@ let proplist_meet_generate plist =
(* 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' = IList.map (combine porig) pplist in
props_done := Propset.add pcombined !props_done;
props_done := Propset.add tenv pcombined !props_done;
proplist_meet pplist' in
proplist_meet (IList.map (fun p -> (p, p)) plist);
!props_done
let propset_meet_generate_pre pset =
let propset_meet_generate_pre tenv pset =
let plist = Propset.to_proplist pset in
if Config.meet_level = 0 then plist
else
let pset1 = proplist_meet_generate plist in
let pset1 = proplist_meet_generate tenv plist in
let pset_new = Propset.diff pset1 pset in
let plist_old = Propset.to_proplist pset in
let plist_new = Propset.to_proplist pset_new in

@ -20,9 +20,9 @@ val pathset_join :
val join_time : float ref
val proplist_collapse_pre : Prop.normal Prop.t list -> Prop.normal Specs.Jprop.t list
val proplist_collapse_pre : Tenv.t -> Prop.normal Prop.t list -> Prop.normal Specs.Jprop.t list
val pathset_collapse : Paths.PathSet.t -> Paths.PathSet.t
val pathset_collapse : Tenv.t -> Paths.PathSet.t -> Paths.PathSet.t
(** reduce the pathset only based on implication checking. *)
val pathset_collapse_impl : Procname.t -> Tenv.t -> Paths.PathSet.t -> Paths.PathSet.t
@ -33,4 +33,4 @@ val pathset_collapse_impl : Procname.t -> Tenv.t -> Paths.PathSet.t -> Paths.Pat
by applying the partial meet operator, adds the generated heaps
to the argument propset, and returns the resulting propset. This function
is tuned for combining preconditions. *)
val propset_meet_generate_pre : Propset.t -> Prop.normal Prop.t list
val propset_meet_generate_pre : Tenv.t -> Propset.t -> Prop.normal Prop.t list

@ -377,7 +377,7 @@ let compute_struct_exp_nodes sigma =
let get_node_exp n = snd (get_coordinate_and_exp n)
let is_nil e prop =
(Exp.equal e Exp.zero) || (Prover.check_equal prop e Exp.zero)
(Exp.equal e Exp.zero) || (Prover.check_equal (Tenv.create ()) prop e Exp.zero)
(* an edge is in cycle *)
let in_cycle cycle edge =
@ -726,7 +726,8 @@ and print_sll f pe nesting k e1 coo =
F.fprintf f "state%iL%i [label=\" \"] \n" (n + 1) lambda ;
F.fprintf f "state%iL%i -> state%iL%i [label=\" \"] }" n' lambda (n + 1) lambda ;
incr lambda_counter;
pp_dotty f (Lambda_pred(n + 1, lambda, false)) (Prop.normalize (Prop.from_sigma nesting)) None
pp_dotty f (Lambda_pred(n + 1, lambda, false))
(Prop.normalize (Tenv.create ()) (Prop.from_sigma nesting)) None
and print_dll f pe nesting k e1 e4 coo =
let n = coo.id in
@ -748,7 +749,8 @@ and print_dll f pe nesting k e1 e4 coo =
F.fprintf f "state%iL%i -> state%iL%i [label=\" \"]\n" (n + 1) lambda n' lambda;
F.fprintf f "state%iL%i -> state%iL%i [label=\" \"]}\n" n' lambda (n + 1) lambda ;
incr lambda_counter;
pp_dotty f (Lambda_pred(n', lambda, false)) (Prop.normalize (Prop.from_sigma nesting)) None
pp_dotty f (Lambda_pred(n', lambda, false))
(Prop.normalize (Tenv.create ()) (Prop.from_sigma nesting)) None
and dotty_pp_state f pe cycle dotnode =
let dotty_exp coo e c is_dangling =
@ -826,7 +828,7 @@ and pp_dotty f kind (_prop: Prop.normal Prop.t) cycle =
(* add stack vars from pre *)
let pre_stack = fst (Prop.sigma_get_stack_nonstack true pre.Prop.sigma) in
let prop = Prop.set _prop ~sigma:(pre_stack @ _prop.Prop.sigma) in
pe, Prop.normalize prop
pe, Prop.normalize (Tenv.create ()) prop
| _ ->
let pe = Prop.prop_update_obj_sub pe_text _prop in
pe, _prop in
@ -862,7 +864,7 @@ let pp_dotty_one_spec f pre posts =
F.fprintf f "\n state%iL0 [label=\"SPEC %i \", style=filled, color= lightblue]\n" !dotty_state_count !spec_counter;
spec_id:=!dotty_state_count;
invisible_arrows:= true;
pp_dotty f (Spec_precondition) pre None;
pp_dotty f Spec_precondition pre None;
invisible_arrows:= false;
IList.iter (fun (po, _) -> incr post_counter ; pp_dotty f (Spec_postcondition pre) po None;
for j = 1 to 4 do
@ -885,7 +887,7 @@ let pp_dotty_prop_list_in_path f plist prev_n curr_n =
incr dotty_state_count;
F.fprintf f "\n state%iN [label=\"NODE %i \", style=filled, color= lightblue]\n" curr_n curr_n;
IList.iter (fun po -> incr proposition_counter ;
pp_dotty f (Generic_proposition) po None) plist;
pp_dotty f Generic_proposition po None) plist;
if prev_n <> - 1 then F.fprintf f "\n state%iN ->state%iN\n" prev_n curr_n;
F.fprintf f "\n } \n"
with exn when SymOp.exn_not_failure exn ->
@ -900,7 +902,7 @@ let pp_dotty_prop fmt (prop, cycle) =
let dotty_prop_to_str prop cycle =
try
Some (pp_to_string pp_dotty_prop (prop, cycle))
Some (pp_to_string (pp_dotty_prop) (prop, cycle))
with exn when SymOp.exn_not_failure exn -> None
(* create a dotty file with a single proposition *)
@ -1070,7 +1072,7 @@ let pp_speclist_to_file (filename : DB.filename) spec_list =
Config.pp_simple := true;
let outc = open_out (DB.filename_to_string (DB.filename_add_suffix filename ".dot")) in
let fmt = F.formatter_of_out_channel outc in
let () = F.fprintf fmt "#### Dotty version: ####@\n%a@\n@\n" pp_speclist_dotty spec_list in
let () = F.fprintf fmt "#### Dotty version: ####@\n%a@\n@\n" (pp_speclist_dotty) spec_list in
close_out outc;
Config.pp_simple := pp_simple_saved
@ -1390,7 +1392,7 @@ let print_specs_xml signature specs loc fmt =
(* add stack vars from pre *)
let pre_stack = fst (Prop.sigma_get_stack_nonstack true pre.Prop.sigma) in
let _prop' = Prop.set _prop ~sigma:(pre_stack @ _prop.Prop.sigma) in
Prop.normalize _prop' in
Prop.normalize (Tenv.create ()) _prop' in
let jj = ref 0 in
let xml_pre = prop_to_xml pre "precondition" !jj in
let xml_spec =

@ -43,9 +43,9 @@ let is_special_field class_names field_name_opt field =
is_one_of_classes complete_fieldname class_names && field_ok
(** Check whether the hpred is a |-> representing a resource in the Racquire state *)
let hpred_is_open_resource prop = function
let hpred_is_open_resource tenv prop = function
| Sil.Hpointsto(e, _, _) ->
(match Attribute.get_resource prop e with
(match Attribute.get_resource tenv prop e with
| Some (Apred (Aresource { ra_kind = Racquire; ra_res = res }, _)) -> Some res
| _ -> None)
| _ ->
@ -209,7 +209,7 @@ let rec find_boolean_assignment node pvar true_branch : Cfg.Node.t option =
(** Find the Load instruction used to declare normal variable [id],
and return the expression dereferenced to initialize [id] *)
let rec _find_normal_variable_load (seen : Exp.Set.t) node id : DExp.t option =
let rec _find_normal_variable_load tenv (seen : Exp.Set.t) node id : DExp.t option =
let is_infer = not (Config.checkers || Config.eradicate) in
let find_declaration node = function
| Sil.Load (id0, e, _, _) when Ident.equal id id0 ->
@ -217,14 +217,14 @@ let rec _find_normal_variable_load (seen : Exp.Set.t) node id : DExp.t option =
then
(L.d_str "find_normal_variable_load defining ";
Sil.d_exp e; L.d_ln ());
_exp_lv_dexp seen node e
_exp_lv_dexp tenv seen node e
| Sil.Call ([id0], Exp.Const (Const.Cfun pn), (e, _):: _, _, _)
when Ident.equal id id0 && Procname.equal pn (Procname.from_string_c_fun "__cast") ->
if verbose
then
(L.d_str "find_normal_variable_load cast on ";
Sil.d_exp e; L.d_ln ());
_exp_rv_dexp seen node e
_exp_rv_dexp tenv seen node e
| Sil.Call ([id0], (Exp.Const (Const.Cfun pname) as fun_exp), args, loc, call_flags)
when Ident.equal id id0 ->
if verbose
@ -234,7 +234,7 @@ let rec _find_normal_variable_load (seen : Exp.Set.t) node id : DExp.t option =
let fun_dexp = DExp.Dconst (Const.Cfun pname) in
let args_dexp =
let args_dexpo = IList.map (fun (e, _) -> _exp_rv_dexp seen node e) args in
let args_dexpo = IList.map (fun (e, _) -> _exp_rv_dexp tenv seen node e) args in
if IList.exists (fun x -> x = None) args_dexpo
then []
else
@ -262,23 +262,23 @@ let rec _find_normal_variable_load (seen : Exp.Set.t) node id : DExp.t option =
res
(** describe lvalue [e] as a dexp *)
and _exp_lv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
and _exp_lv_dexp tenv (_seen : Exp.Set.t) node e : DExp.t option =
if Exp.Set.mem e _seen then
(L.d_str "exp_lv_dexp: cycle detected"; Sil.d_exp e; L.d_ln (); None)
else
let seen = Exp.Set.add e _seen in
match Prop.exp_normalize_noabs Sil.sub_empty e with
match Prop.exp_normalize_noabs tenv Sil.sub_empty e with
| Exp.Const c ->
if verbose then (L.d_str "exp_lv_dexp: constant "; Sil.d_exp e; L.d_ln ());
Some (DExp.Dderef (DExp.Dconst c))
| Exp.BinOp(Binop.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
(match _exp_lv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2 with
| Some de1, Some de2 -> Some (DExp.Dbinop(Binop.PlusPI, de1, de2))
| _ -> None)
| Exp.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_load seen node id with
(match _find_normal_variable_load tenv seen node id with
| None -> None
| Some de -> Some (DExp.Dderef de))
| Exp.Lvar pvar ->
@ -298,15 +298,15 @@ and _exp_lv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
begin
match find_normal_variable_funcall node' id with
| Some (fun_exp, eargs, loc, call_flags) ->
let fun_dexpo = _exp_rv_dexp seen node' fun_exp in
let blame_args = IList.map (_exp_rv_dexp seen node') eargs in
let fun_dexpo = _exp_rv_dexp tenv seen node' fun_exp in
let blame_args = IList.map (_exp_rv_dexp tenv seen node') eargs in
if IList.exists (fun x -> x = None) (fun_dexpo:: blame_args) then None
else
let unNone = function Some x -> x | None -> assert false in
let args = IList.map unNone blame_args in
Some (DExp.Dfcall (unNone fun_dexpo, args, loc, call_flags))
| None ->
_exp_rv_dexp seen node' (Exp.Var id)
_exp_rv_dexp tenv seen node' (Exp.Var id)
end
end
else Some (DExp.Dpvar pvar)
@ -318,7 +318,7 @@ and _exp_lv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
L.d_str (" " ^ Ident.fieldname_to_string f);
L.d_ln ()
end;
(match _find_normal_variable_load seen node id with
(match _find_normal_variable_load tenv seen node id with
| None -> None
| Some de -> Some (DExp.Darrow (de, f)))
| Exp.Lfield (e1, f, _) ->
@ -329,7 +329,7 @@ and _exp_lv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
L.d_str (" " ^ Ident.fieldname_to_string f);
L.d_ln ()
end;
(match _exp_lv_dexp seen node e1 with
(match _exp_lv_dexp tenv seen node e1 with
| None -> None
| Some de -> Some (DExp.Ddot (de, f)))
| Exp.Lindex (e1, e2) ->
@ -341,7 +341,7 @@ and _exp_lv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
Sil.d_exp e2;
L.d_ln ()
end;
(match _exp_lv_dexp seen node e1, _exp_rv_dexp seen node e2 with
(match _exp_lv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2 with
| None, _ -> None
| Some de1, None ->
(* even if the index is unknown, the array info is useful for bound errors *)
@ -352,7 +352,7 @@ and _exp_lv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
None
(** describe rvalue [e] as a dexp *)
and _exp_rv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
and _exp_rv_dexp tenv (_seen : Exp.Set.t) node e : DExp.t option =
if Exp.Set.mem e _seen then
(L.d_str "exp_rv_dexp: cycle detected"; Sil.d_exp e; L.d_ln (); None)
else
@ -364,11 +364,11 @@ and _exp_rv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
| Exp.Lvar pv ->
if verbose then (L.d_str "exp_rv_dexp: program var "; Sil.d_exp e; L.d_ln ());
if Pvar.is_frontend_tmp pv
then _exp_lv_dexp _seen (* avoid spurious cycle detection *) node e
then _exp_lv_dexp tenv _seen (* avoid spurious cycle detection *) node e
else Some (DExp.Dpvaraddr pv)
| Exp.Var id when Ident.is_normal id ->
if verbose then (L.d_str "exp_rv_dexp: normal var "; Sil.d_exp e; L.d_ln ());
_find_normal_variable_load seen node id
_find_normal_variable_load tenv seen node id
| Exp.Lfield (e1, f, _) ->
if verbose then
begin
@ -377,7 +377,7 @@ and _exp_rv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
L.d_str (" " ^ Ident.fieldname_to_string f);
L.d_ln ()
end;
(match _exp_rv_dexp seen node e1 with
(match _exp_rv_dexp tenv seen node e1 with
| None -> None
| Some de -> Some (DExp.Ddot(de, f)))
| Exp.Lindex (e1, e2) ->
@ -389,32 +389,32 @@ and _exp_rv_dexp (_seen : Exp.Set.t) node e : DExp.t option =
Sil.d_exp e2;
L.d_ln ()
end;
(match _exp_rv_dexp seen node e1, _exp_rv_dexp seen node e2 with
(match _exp_rv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2 with
| None, _ | _, None -> None
| Some de1, Some de2 -> Some (DExp.Darray(de1, de2)))
| Exp.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
(match _exp_rv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2 with
| None, _ | _, None -> None
| Some de1, Some de2 -> Some (DExp.Dbinop (op, de1, de2)))
| Exp.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
(match _exp_rv_dexp tenv seen node e1 with
| None -> None
| Some de1 -> Some (DExp.Dunop (op, de1)))
| Exp.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
_exp_rv_dexp tenv seen node e1
| Exp.Sizeof (typ, len, sub) ->
if verbose then (L.d_str "exp_rv_dexp: type "; Sil.d_exp e; L.d_ln ());
Some (DExp.Dsizeof (typ, Option.map_default (_exp_rv_dexp seen node) None len, sub))
Some (DExp.Dsizeof (typ, Option.map_default (_exp_rv_dexp tenv seen node) None len, sub))
| _ ->
if verbose then (L.d_str "exp_rv_dexp: no match for "; Sil.d_exp e; L.d_ln ());
None
let find_normal_variable_load = _find_normal_variable_load Exp.Set.empty
let exp_lv_dexp = _exp_lv_dexp Exp.Set.empty
let exp_rv_dexp = _exp_rv_dexp Exp.Set.empty
let find_normal_variable_load tenv = _find_normal_variable_load tenv Exp.Set.empty
let exp_lv_dexp tenv = _exp_lv_dexp tenv Exp.Set.empty
let exp_rv_dexp tenv = _exp_rv_dexp tenv Exp.Set.empty
(** Produce a description of a mismatch between an allocation function
and a deallocation function *)
@ -527,7 +527,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
then
(L.d_str "explain_leak: current instruction is Nullify for pvar ";
Pvar.d pvar; L.d_ln ());
(match exp_lv_dexp (State.get_node ()) (Exp.Lvar pvar) with
(match exp_lv_dexp tenv (State.get_node ()) (Exp.Lvar pvar) with
| Some de when not (DExp.has_tmp_var de)-> Some (DExp.to_string de)
| _ -> None)
| Some (Sil.Abstract _) ->
@ -549,7 +549,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
then
(L.d_str "explain_leak: current instruction Set for ";
Sil.d_exp lexp; L.d_ln ());
(match exp_lv_dexp node lexp with
(match exp_lv_dexp tenv node lexp with
| Some dexp when not (DExp.has_tmp_var dexp) -> Some (DExp.to_string dexp)
| _ -> None)
| Some instr ->
@ -573,7 +573,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket =
(** find the dexp, if any, where the given value is stored
also return the type of the value if found *)
let vpath_find prop _exp : DExp.t option * Typ.t option =
let vpath_find _tenv prop _exp : DExp.t option * Typ.t 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 =
let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) = match se with
@ -810,7 +810,7 @@ let explain_dereference_access outermost_array is_nullable _de_opt prop =
(value_str, access_opt)
(** Create a description of a dereference operation *)
let create_dereference_desc
let create_dereference_desc tenv
?use_buckets: (use_buckets = false)
?outermost_array: (outermost_array = false)
?is_nullable: (is_nullable = false)
@ -828,7 +828,7 @@ let create_dereference_desc
match de_opt with
| Some (DExp.Dpvar pvar)
| Some (DExp.Dpvaraddr pvar) ->
(match Attribute.get_objc_null prop (Exp.Lvar pvar) with
(match Attribute.get_objc_null tenv prop (Exp.Lvar pvar) with
| Some (Apred (Aobjc_null, [_; vfs])) ->
Localise.parameter_field_not_null_checked_desc desc vfs
| _ ->
@ -848,7 +848,7 @@ let create_dereference_desc
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
let _explain_access tenv
?(use_buckets = false)
?(outermost_array = false)
?(outermost_dereference = false)
@ -858,13 +858,13 @@ let _explain_access
let rec find_outermost_dereference node e = match e with
| Exp.Const _ ->
if verbose then (L.d_str "find_outermost_dereference: constant "; Sil.d_exp e; L.d_ln ());
exp_lv_dexp node e
exp_lv_dexp tenv node e
| Exp.Var id when Ident.is_normal id -> (* look up the normal variable declaration *)
if verbose
then
(L.d_str "find_outermost_dereference: normal var ";
Sil.d_exp e; L.d_ln ());
find_normal_variable_load node id
find_normal_variable_load tenv node id
| Exp.Lfield (e', _, _) ->
if verbose then (L.d_str "find_outermost_dereference: Lfield "; Sil.d_exp e; L.d_ln ());
find_outermost_dereference node e'
@ -873,13 +873,13 @@ let _explain_access
find_outermost_dereference node e'
| Exp.Lvar _ ->
if verbose then (L.d_str "find_outermost_dereference: Lvar "; Sil.d_exp e; L.d_ln ());
exp_lv_dexp node e
exp_lv_dexp tenv node e
| Exp.BinOp(Binop.PlusPI, Exp.Lvar _, _) ->
if verbose
then
(L.d_str "find_outermost_dereference: Lvar+index ";
Sil.d_exp e; L.d_ln ());
exp_lv_dexp node e
exp_lv_dexp tenv node e
| Exp.Cast (_, e') ->
if verbose then (L.d_str "find_outermost_dereference: cast "; Sil.d_exp e; L.d_ln ());
find_outermost_dereference node e'
@ -916,30 +916,30 @@ let _explain_access
L.d_strln "Finding deref'd exp";
let de_opt =
if outermost_dereference then find_outermost_dereference node e
else exp_lv_dexp node e in
create_dereference_desc
else exp_lv_dexp tenv node e in
create_dereference_desc tenv
~use_buckets ~outermost_array ~is_nullable ~is_premature_nil
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. *)
let explain_dereference
let explain_dereference tenv
?(use_buckets = false)
?(is_nullable = false)
?(is_premature_nil = false)
deref_str prop loc =
_explain_access
_explain_access tenv
~use_buckets ~outermost_array: false ~outermost_dereference: true ~is_nullable ~is_premature_nil
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. *)
let explain_array_access deref_str prop loc =
_explain_access ~outermost_array: true deref_str prop loc
let explain_array_access tenv deref_str prop loc =
_explain_access tenv ~outermost_array: true deref_str prop loc
(** Produce a description of the memory access performed in the current instruction, if any. *)
let explain_memory_access deref_str prop loc =
_explain_access deref_str prop loc
let explain_memory_access tenv deref_str prop loc =
_explain_access tenv deref_str prop loc
(* offset of an expression found following a program variable *)
type pvar_off =
@ -961,19 +961,19 @@ let dexp_apply_pvar_off dexp pvar_off =
(** Produce a description of the nth parameter of the function call, if the current instruction
is a function call with that parameter *)
let explain_nth_function_parameter use_buckets deref_str prop n pvar_off =
let explain_nth_function_parameter tenv 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 (IList.nth args (n - 1)) in
let dexp_opt = exp_rv_dexp node arg in
let dexp_opt = exp_rv_dexp tenv 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
create_dereference_desc tenv ~use_buckets dexp_opt' deref_str prop loc
with exn when SymOp.exn_not_failure exn -> Localise.no_desc)
| _ -> Localise.no_desc
@ -1005,7 +1005,7 @@ let find_with_exp prop exp =
(** return a description explaining value [exp] in [prop] in terms of a source expression
using the formal parameters of the call *)
let explain_dereference_as_caller_expression
let explain_dereference_as_caller_expression tenv
?use_buckets: (use_buckets = false)
deref_str actual_pre spec_pre exp node loc formal_params =
let find_formal_param_number name =
@ -1021,14 +1021,14 @@ let explain_dereference_as_caller_expression
let pv_name = Pvar.get_name pv in
if Pvar.is_global pv
then
let dexp = exp_lv_dexp node (Exp.Lvar pv) in
create_dereference_desc ~use_buckets dexp deref_str actual_pre loc
let dexp = exp_lv_dexp tenv node (Exp.Lvar pv) in
create_dereference_desc tenv ~use_buckets dexp deref_str actual_pre loc
else if Pvar.is_callee pv then
let position = find_formal_param_number pv_name in
if verbose then L.d_strln ("parameter number: " ^ string_of_int position);
explain_nth_function_parameter use_buckets deref_str actual_pre position pvar_off
explain_nth_function_parameter tenv use_buckets deref_str actual_pre position pvar_off
else
if Attribute.has_dangling_uninit spec_pre exp then
if Attribute.has_dangling_uninit tenv spec_pre exp then
Localise.desc_uninitialized_dangling_pointer_deref deref_str (Pvar.to_string pv) loc
else Localise.no_desc
| None ->
@ -1038,11 +1038,11 @@ let explain_dereference_as_caller_expression
Localise.no_desc
(** explain a class cast exception *)
let explain_class_cast_exception pname_opt typ1 typ2 exp node loc =
let exp_str_opt = match exp_rv_dexp node exp with
let explain_class_cast_exception tenv pname_opt typ1 typ2 exp node loc =
let exp_str_opt = match exp_rv_dexp tenv node exp with
| Some dexp -> Some (DExp.to_string dexp)
| None -> None in
match exp_rv_dexp node typ1, exp_rv_dexp node typ2 with
match exp_rv_dexp tenv node typ1, exp_rv_dexp tenv node typ2 with
| Some de1, Some de2 ->
let typ_str1 = DExp.to_string de1 in
let typ_str2 = DExp.to_string de2 in
@ -1050,8 +1050,8 @@ let explain_class_cast_exception pname_opt typ1 typ2 exp node loc =
| _ -> Localise.no_desc
(** explain a division by zero *)
let explain_divide_by_zero exp node loc =
match exp_rv_dexp node exp with
let explain_divide_by_zero tenv exp node loc =
match exp_rv_dexp tenv node exp with
| Some de ->
let exp_str = DExp.to_string de in
Localise.desc_divide_by_zero exp_str loc
@ -1106,8 +1106,8 @@ let explain_condition_is_assignment loc =
Localise.desc_condition_is_assignment loc
(** explain a condition which is always true or false *)
let explain_condition_always_true_false i cond node loc =
let cond_str_opt = match exp_rv_dexp node cond with
let explain_condition_always_true_false tenv i cond node loc =
let cond_str_opt = match exp_rv_dexp tenv node cond with
| Some de ->
Some (DExp.to_string de)
| None -> None in
@ -1125,8 +1125,8 @@ let explain_stack_variable_address_escape loc pvar addr_dexp_opt =
Localise.desc_stack_variable_address_escape (Pvar.to_string pvar) addr_dexp_str loc
(** explain unary minus applied to unsigned expression *)
let explain_unary_minus_applied_to_unsigned_expression exp typ node loc =
let exp_str_opt = match exp_rv_dexp node exp with
let explain_unary_minus_applied_to_unsigned_expression tenv exp typ node loc =
let exp_str_opt = match exp_rv_dexp tenv node exp with
| Some de -> Some (DExp.to_string de)
| None -> None in
let typ_str =
@ -1135,8 +1135,8 @@ let explain_unary_minus_applied_to_unsigned_expression exp typ node loc =
Localise.desc_unary_minus_applied_to_unsigned_expression exp_str_opt typ_str loc
(** explain a test for NULL of a dereferenced pointer *)
let explain_null_test_after_dereference exp node line loc =
match exp_rv_dexp node exp with
let explain_null_test_after_dereference tenv exp node line loc =
match exp_rv_dexp tenv node exp with
| Some de ->
let expr_str = DExp.to_string de in
Localise.desc_null_test_after_dereference expr_str line loc

@ -14,13 +14,13 @@ open! Utils
(** find the dexp, if any, where the given value is stored
also return the type of the value if found *)
val vpath_find : 'a Prop.t -> Exp.t -> DecompiledExp.vpath * Typ.t option
val vpath_find : Tenv.t -> 'a Prop.t -> Exp.t -> DecompiledExp.vpath * Typ.t option
(** Return true if [id] is assigned to a program variable which is then nullified *)
val id_is_assigned_then_dead : Cfg.Node.t -> Ident.t -> bool
(** Check whether the hpred is a |-> representing a resource in the Racquire state *)
val hpred_is_open_resource : 'a Prop.t -> Sil.hpred -> PredSymb.resource option
val hpred_is_open_resource : Tenv.t -> 'a Prop.t -> Sil.hpred -> PredSymb.resource option
(** Find the function call instruction used to initialize normal variable [id],
and return the function name and arguments *)
@ -38,7 +38,7 @@ val find_ident_assignment : Cfg.Node.t -> Ident.t -> (Cfg.Node.t * Exp.t) option
val find_boolean_assignment : Cfg.Node.t -> Pvar.t -> bool -> Cfg.Node.t option
(** describe rvalue [e] as a dexp *)
val exp_rv_dexp : Cfg.Node.t -> Exp.t -> DecompiledExp.t option
val exp_rv_dexp : Tenv.t -> Cfg.Node.t -> Exp.t -> DecompiledExp.t option
(** Produce a description of a persistent reference to an Android Context *)
val explain_context_leak : Procname.t -> Typ.t -> Ident.fieldname ->
@ -49,11 +49,11 @@ val explain_allocation_mismatch :
PredSymb.res_action -> PredSymb.res_action -> Localise.error_desc
(** Produce a description of the array access performed in the current instruction, if any. *)
val explain_array_access : Localise.deref_str -> 'a Prop.t -> Location.t -> Localise.error_desc
val explain_array_access : Tenv.t -> Localise.deref_str -> 'a Prop.t -> Location.t -> Localise.error_desc
(** explain a class cast exception *)
val explain_class_cast_exception :
Procname.t option -> Exp.t -> Exp.t -> Exp.t ->
Tenv.t -> Procname.t option -> Exp.t -> Exp.t -> Exp.t ->
Cfg.Node.t -> Location.t -> Localise.error_desc
(** Explain a deallocate stack variable error *)
@ -64,18 +64,18 @@ val explain_deallocate_constant_string : string -> PredSymb.res_action -> Locali
(** Produce a description of which expression is dereferenced in the current instruction, if any. *)
val explain_dereference :
?use_buckets:bool -> ?is_nullable:bool -> ?is_premature_nil:bool ->
Tenv.t -> ?use_buckets:bool -> ?is_nullable:bool -> ?is_premature_nil:bool ->
Localise.deref_str -> 'a Prop.t -> Location.t -> Localise.error_desc
(** return a description explaining value [exp] in [prop] in terms of a source expression
using the formal parameters of the call *)
val explain_dereference_as_caller_expression :
?use_buckets:bool ->
Tenv.t -> ?use_buckets:bool ->
Localise.deref_str -> 'a Prop.t -> 'b Prop.t -> Exp.t ->
Cfg.Node.t -> Location.t -> Pvar.t list -> Localise.error_desc
(** explain a division by zero *)
val explain_divide_by_zero : Exp.t -> Cfg.Node.t -> Location.t -> Localise.error_desc
val explain_divide_by_zero : Tenv.t -> Exp.t -> Cfg.Node.t -> Location.t -> Localise.error_desc
(** explain a return expression required *)
val explain_return_expression_required : Location.t -> Typ.t -> Localise.error_desc
@ -88,7 +88,7 @@ val explain_condition_is_assignment : Location.t -> Localise.error_desc
(** explain a condition which is always true or false *)
val explain_condition_always_true_false :
IntLit.t -> Exp.t -> Cfg.Node.t -> Location.t -> Localise.error_desc
Tenv.t -> IntLit.t -> Exp.t -> Cfg.Node.t -> Location.t -> Localise.error_desc
(** explain the escape of a stack variable address from its scope *)
val explain_stack_variable_address_escape :
@ -107,7 +107,7 @@ val explain_retain_cycle :
(** explain unary minus applied to unsigned expression *)
val explain_unary_minus_applied_to_unsigned_expression :
Exp.t -> Typ.t -> Cfg.Node.t -> Location.t -> Localise.error_desc
Tenv.t -> Exp.t -> Typ.t -> Cfg.Node.t -> Location.t -> Localise.error_desc
(** Explain a tainted value error *)
val explain_tainted_value_reaching_sensitive_function :
@ -123,11 +123,11 @@ val explain_leak :
Exceptions.exception_visibility * Localise.error_desc
(** Produce a description of the memory access performed in the current instruction, if any. *)
val explain_memory_access : Localise.deref_str -> 'a Prop.t -> Location.t -> Localise.error_desc
val explain_memory_access : Tenv.t -> Localise.deref_str -> 'a Prop.t -> Location.t -> Localise.error_desc
(** explain a test for NULL of a dereferenced pointer *)
val explain_null_test_after_dereference :
Exp.t -> Cfg.Node.t -> int -> Location.t -> Localise.error_desc
Tenv.t -> Exp.t -> Cfg.Node.t -> int -> Location.t -> Localise.error_desc
(** Print a warning to the err stream at the given location (note: only prints in developer mode) *)
val warning_err : Location.t -> ('a, Format.formatter, unit) format -> 'a

@ -147,18 +147,24 @@ let file_data_to_cfg file_data =
file_data.cfg
(** return the type environment associated to the procedure *)
let get_tenv exe_env proc_name : Tenv.t =
let get_tenv ?(create=false) exe_env proc_name : Tenv.t =
let not_found () =
(* ToDo: a tenv should always be found, it should not be necessary to create one here *)
if create then
Tenv.create ()
else
failwith ("get_tenv: file_data not found for" ^ Procname.to_string proc_name) in
match get_file_data exe_env proc_name with
| None ->
failwith ("get_tenv: file_data not found for" ^ Procname.to_string proc_name)
| Some file_data ->
begin
match file_data_to_tenv file_data with
| Some tenv ->
tenv
| None ->
failwith ("get_tenv: tenv not found for" ^ Procname.to_string proc_name)
not_found ()
end
| None ->
not_found ()
(** return the cfg associated to the procedure *)
let get_cfg exe_env pname =

@ -35,7 +35,7 @@ val get_cg : t -> Cg.t
val get_source : t -> Procname.t -> DB.source_file option
(** return the type environment associated to the procedure *)
val get_tenv : t -> Procname.t -> Tenv.t
val get_tenv : ?create:bool -> t -> Procname.t -> Tenv.t
(** return the cfg associated to the procedure *)
val get_cfg : t -> Procname.t -> Cfg.cfg option

@ -175,7 +175,7 @@ let collect_do_abstract_pre pname tenv (pset : Propset.t) : Propset.t =
let collect_do_abstract_post pname tenv (pathset : Paths.PathSet.t) : Paths.PathSet.t =
let abs_option p =
if Prover.check_inconsistency p then None
if Prover.check_inconsistency tenv p then None
else Some (Abs.abstract pname tenv p) in
if !Config.footprint
then
@ -190,13 +190,13 @@ let do_join_pre plist =
let do_join_post pname tenv (pset: Paths.PathSet.t) =
if Config.spec_abs_level <= 0 then
Dom.pathset_collapse pset
Dom.pathset_collapse tenv pset
else
Dom.pathset_collapse (Dom.pathset_collapse_impl pname tenv pset)
Dom.pathset_collapse tenv (Dom.pathset_collapse_impl pname tenv pset)
let do_meet_pre pset =
let do_meet_pre tenv pset =
if Config.meet_level > 0 then
Dom.propset_meet_generate_pre pset
Dom.propset_meet_generate_pre tenv pset
else
Propset.to_proplist pset
@ -215,31 +215,31 @@ let collect_preconditions tenv proc_name : Prop.normal Specs.Jprop.t list =
IList.map
(fun spec -> Specs.Jprop.to_prop spec.Specs.pre)
(Specs.get_specs proc_name) in
let pset = Propset.from_proplist pres in
let pset = Propset.from_proplist tenv pres in
let pset' =
let f p = Prop.prop_normal_vars_to_primed_vars p in
Propset.map f pset in
let f p = Prop.prop_normal_vars_to_primed_vars tenv p in
Propset.map tenv f pset in
L.d_strln ("#### Extracted footprint of " ^ Procname.to_string proc_name ^ ": ####");
L.d_increase_indent 1; Propset.d Prop.prop_emp pset'; L.d_decrease_indent 1; L.d_ln ();
L.d_ln ();
let pset'' = collect_do_abstract_pre proc_name tenv pset' in
let plist_meet = do_meet_pre pset'' in
let plist_meet = do_meet_pre tenv pset'' in
L.d_strln ("#### Footprint of " ^ Procname.to_string proc_name ^ " after Meet ####");
L.d_increase_indent 1; Propgraph.d_proplist Prop.prop_emp plist_meet;
L.d_decrease_indent 1; L.d_ln ();
L.d_ln ();
L.d_increase_indent 2; (* Indent for the join output *)
let jplist = do_join_pre plist_meet in
let jplist = do_join_pre tenv plist_meet in
L.d_decrease_indent 2; L.d_ln ();
L.d_strln ("#### Footprint of " ^ Procname.to_string proc_name ^ " after Join ####");
L.d_increase_indent 1; Specs.Jprop.d_list false jplist; L.d_decrease_indent 1; L.d_ln ();
let jplist' = IList.map (Specs.Jprop.map Prop.prop_rename_primed_footprint_vars) jplist in
let jplist' = IList.map (Specs.Jprop.map (Prop.prop_rename_primed_footprint_vars tenv)) jplist in
L.d_strln ("#### Renamed footprint of " ^ Procname.to_string proc_name ^ ": ####");
L.d_increase_indent 1; Specs.Jprop.d_list false jplist'; L.d_decrease_indent 1; L.d_ln ();
let jplist'' =
let f p =
Prop.prop_primed_vars_to_normal_vars
Prop.prop_primed_vars_to_normal_vars tenv
(collect_do_abstract_one proc_name tenv p) in
IList.map (Specs.Jprop.map f) jplist' in
L.d_strln ("#### Abstracted footprint of " ^ Procname.to_string proc_name ^ ": ####");
@ -282,7 +282,7 @@ let propagate_nodes_divergence
let mk_incons prop =
let p_abs = Abs.abstract pname tenv prop in
let p_zero = Prop.set p_abs ~sub:Sil.sub_empty ~sigma:[] in
Prop.normalize (Prop.set p_zero ~pi:[Sil.Aneq (Exp.zero, Exp.zero)]) in
Prop.normalize tenv (Prop.set p_zero ~pi:[Sil.Aneq (Exp.zero, Exp.zero)]) in
Paths.PathSet.map mk_incons diverging_states in
(L.d_strln_color Orange) "Propagating Divergence -- diverging states:";
Propgraph.d_proplist Prop.prop_emp (Paths.PathSet.to_proplist prop_incons); L.d_ln ();
@ -480,7 +480,7 @@ let do_symbolic_execution handle_exn tenv
Ident.update_name_generator (instrs_get_normal_vars instrs);
let pset = SymExec.node handle_exn tenv node (Paths.PathSet.from_renamed_list [(prop, path)]) in
L.d_strln ".... After Symbolic Execution ....";
Propset.d prop (Paths.PathSet.to_propset pset);
Propset.d prop (Paths.PathSet.to_propset tenv pset);
L.d_ln (); L.d_ln();
State.mark_execution_end node;
pset
@ -553,7 +553,7 @@ let forward_tabulate tenv wl =
(fun prop_acc (param, taint_kind) ->
let attr =
PredSymb.Ataint { taint_source = proc_name; taint_kind; } in
Taint.add_tainting_attribute attr param prop_acc)
Taint.add_tainting_attribute tenv attr param prop_acc)
prop in
let doit () =
handled_some_exception := false;
@ -564,7 +564,7 @@ let forward_tabulate tenv wl =
"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);
Propset.d Prop.prop_emp (Paths.PathSet.to_propset tenv pathset_todo);
L.d_strln ".... Instructions: .... ";
Cfg.Node.d_instrs ~sub_instrs: true (State.get_instr ()) curr_node;
L.d_ln (); L.d_ln ();
@ -695,12 +695,12 @@ let report_context_leaks pname sigma tenv =
(** Remove locals and formals,
and check if the address of a stack variable is left in the result *)
let remove_locals_formals_and_check pdesc p =
let remove_locals_formals_and_check tenv pdesc p =
let pname = Cfg.Procdesc.get_proc_name pdesc in
let pvars, p' = Cfg.remove_locals_formals pdesc p in
let pvars, p' = Cfg.remove_locals_formals tenv pdesc p in
let check_pvar pvar =
let loc = Cfg.Node.get_loc (Cfg.Procdesc.get_exit_node pdesc) in
let dexp_opt, _ = Errdesc.vpath_find p (Exp.Lvar pvar) in
let dexp_opt, _ = Errdesc.vpath_find tenv p (Exp.Lvar pvar) in
let desc = Errdesc.explain_stack_variable_address_escape loc pvar dexp_opt in
let exn = Exceptions.Stack_variable_address_escape (desc, __POS__) in
Reporting.log_warning pname exn in
@ -708,11 +708,11 @@ let remove_locals_formals_and_check pdesc p =
p'
(** Collect the analysis results for the exit node. *)
let collect_analysis_result wl pdesc : Paths.PathSet.t =
let collect_analysis_result tenv wl pdesc : Paths.PathSet.t =
let exit_node = Cfg.Procdesc.get_exit_node pdesc in
let exit_node_id = Cfg.Node.get_id exit_node in
let pathset = htable_retrieve wl.Worklist.path_set_visited exit_node_id in
Paths.PathSet.map (remove_locals_formals_and_check pdesc) pathset
Paths.PathSet.map (remove_locals_formals_and_check tenv pdesc) pathset
module Pmap = Map.Make
(struct
@ -757,16 +757,16 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
let pre_post_visited_list =
let pplist = Paths.PathSet.elements pathset in
let f (prop, path) =
let _, prop' = Cfg.remove_locals_formals pdesc prop in
let _, prop' = Cfg.remove_locals_formals tenv pdesc prop in
let prop'' = Abs.abstract pname tenv prop' in
let pre, post = Prop.extract_spec prop'' in
let pre' = Prop.normalize (Prop.prop_sub sub pre) in
let pre' = Prop.normalize tenv (Prop.prop_sub sub pre) in
if !Config.curr_language =
Config.Java && Cfg.Procdesc.get_access pdesc <> PredSymb.Private then
report_context_leaks pname post.Prop.sigma tenv;
let post' =
if Prover.check_inconsistency_base prop then None
else Some (Prop.normalize (Prop.prop_sub sub post), path) in
if Prover.check_inconsistency_base tenv prop then None
else Some (Prop.normalize tenv (Prop.prop_sub sub post), path) in
let visited =
let vset_ref = ref Cfg.NodeSet.empty in
vset_ref_add_path vset_ref path;
@ -789,7 +789,7 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
let add_spec pre ((posts : Paths.PathSet.t), visited) =
let posts' =
IList.map
(fun (p, path) -> (Cfg.remove_seed_vars p, path))
(fun (p, path) -> (Cfg.remove_seed_vars tenv p, path))
(Paths.PathSet.elements (do_join_post pname tenv posts)) in
let spec =
{ Specs.pre = Specs.Jprop.Prop (1, pre);
@ -801,23 +801,23 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list =
let collect_postconditions wl tenv pdesc : Paths.PathSet.t * Specs.Visitedset.t =
let pname = Cfg.Procdesc.get_proc_name pdesc in
let pathset = collect_analysis_result wl pdesc in
let pathset = collect_analysis_result tenv wl pdesc in
(* Assuming C++ developers use RAII, remove resources from the constructor posts *)
let pathset = match pname with
| Procname.ObjC_Cpp _ ->
if (Procname.is_constructor pname) then
Paths.PathSet.map (fun prop ->
Attribute.remove_resource Racquire (Rmemory Mobjc)
(Attribute.remove_resource Racquire (Rmemory Mmalloc)
(Attribute.remove_resource Racquire Rfile prop))
Attribute.remove_resource tenv Racquire (Rmemory Mobjc)
(Attribute.remove_resource tenv Racquire (Rmemory Mmalloc)
(Attribute.remove_resource tenv Racquire Rfile prop))
) pathset
else pathset
| _ -> pathset in
L.d_strln
("#### [FUNCTION " ^ Procname.to_string pname ^ "] Analysis result ####");
Propset.d Prop.prop_emp (Paths.PathSet.to_propset pathset);
Propset.d Prop.prop_emp (Paths.PathSet.to_propset tenv pathset);
L.d_ln ();
let res =
try
@ -835,7 +835,7 @@ let collect_postconditions wl tenv pdesc : Paths.PathSet.t * Specs.Visitedset.t
L.d_strln
("#### [FUNCTION " ^ Procname.to_string pname ^ "] Postconditions after join ####");
L.d_increase_indent 1;
Propset.d Prop.prop_emp (Paths.PathSet.to_propset (fst res));
Propset.d Prop.prop_emp (Paths.PathSet.to_propset tenv (fst res));
L.d_decrease_indent 1;
L.d_ln ();
res
@ -857,7 +857,7 @@ let prop_init_formals_seed tenv new_formals (prop : 'a Prop.t) : Prop.exposed Pr
let texp = match !Config.curr_language with
| Config.Clang -> Exp.Sizeof (typ, None, Subtype.exact)
| Config.Java -> Exp.Sizeof (typ, None, Subtype.subtypes) in
Prop.mk_ptsto_lvar (Some tenv) Prop.Fld_init Sil.inst_formal (pv, texp, None) in
Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_formal (pv, texp, None) in
IList.map do_formal new_formals in
let sigma_seed =
create_seed_vars
@ -887,7 +887,7 @@ let initial_prop
prop in
let prop2 =
prop_init_formals_seed tenv new_formals prop1 in
Prop.prop_rename_primed_footprint_vars (Prop.normalize prop2)
Prop.prop_rename_primed_footprint_vars tenv (Prop.normalize tenv prop2)
(** Construct an initial prop from the empty prop *)
let initial_prop_from_emp tenv curr_f =
@ -939,11 +939,11 @@ let execute_filter_prop wl tenv pdesc init_node (precondition : Prop.normal Spec
let pset, visited = collect_postconditions wl tenv pdesc in
let plist =
IList.map
(fun (p, path) -> (Cfg.remove_seed_vars p, path))
(fun (p, path) -> (Cfg.remove_seed_vars tenv p, path))
(Paths.PathSet.elements pset) in
plist, visited in
let pre =
let p = Cfg.remove_locals_ret pdesc (Specs.Jprop.to_prop precondition) in
let p = Cfg.remove_locals_ret tenv pdesc (Specs.Jprop.to_prop precondition) in
match precondition with
| Specs.Jprop.Prop (n, _) -> Specs.Jprop.Prop (n, p)
| Specs.Jprop.Joined (n, _, jp1, jp2) -> Specs.Jprop.Joined (n, p, jp1, jp2) in
@ -1010,7 +1010,7 @@ let perform_analysis_phase tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t)
let mk_init precondition =
initial_prop_from_pre tenv pdesc (Specs.Jprop.to_prop precondition) in
IList.map (fun spec -> mk_init spec.Specs.pre) specs in
let init_props = Propset.from_proplist (init_prop :: init_props_from_pres) in
let init_props = Propset.from_proplist tenv (init_prop :: init_props_from_pres) in
let init_edgeset =
let add pset prop =
Paths.PathSet.add_renamed_prop prop (Paths.Path.start start_node) pset in
@ -1030,7 +1030,7 @@ let perform_analysis_phase tenv (pname : Procname.t) (pdesc : Cfg.Procdesc.t)
forward_tabulate tenv wl in
let get_results (wl : Worklist.t) () =
State.process_execution_failures Reporting.log_warning pname;
let results = collect_analysis_result wl pdesc in
let results = collect_analysis_result tenv wl pdesc in
L.out "#### [FUNCTION %a] ... OK #####@\n" Procname.pp pname;
L.out "#### Finished: Footprint Computation for %a %a ####@."
Procname.pp pname
@ -1143,7 +1143,7 @@ let custom_error_preconditions summary =
(* Remove the constrain of the form this != null which is true for all Java virtual calls *)
let remove_this_not_null prop =
let remove_this_not_null tenv prop =
let collect_hpred (var_option, hpreds) = function
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (Exp.Var var, _), _)
when !Config.curr_language = Config.Java && Pvar.is_this pvar ->
@ -1159,14 +1159,14 @@ let remove_this_not_null prop =
let filtered_atoms =
IList.fold_left (collect_atom var) [] prop.Prop.pi in
let prop' = Prop.set Prop.prop_emp ~pi:filtered_atoms ~sigma:filtered_hpreds in
Prop.normalize prop'
Prop.normalize tenv prop'
(** Is true when the precondition does not contain constrains that can be false at call site.
This means that the post-conditions associated with this precondition cannot be prevented
by the calling context. *)
let is_unavoidable pre =
let prop = remove_this_not_null (Specs.Jprop.to_prop pre) in
let is_unavoidable tenv pre =
let prop = remove_this_not_null tenv (Specs.Jprop.to_prop pre) in
match Prop.CategorizePreconditions.categorize [prop] with
| Prop.CategorizePreconditions.NoPres
| Prop.CategorizePreconditions.Empty -> true
@ -1197,7 +1197,7 @@ let report_runtime_exceptions tenv pdesc summary =
let (exn_preconditions, all_post_exn) =
exception_preconditions tenv pname summary in
let should_report pre =
all_post_exn || is_main || is_annotated || is_unavoidable pre in
all_post_exn || is_main || is_annotated || is_unavoidable tenv pre in
let report (pre, runtime_exception) =
if should_report pre then
let pre_str =
@ -1208,12 +1208,12 @@ let report_runtime_exceptions tenv pdesc summary =
IList.iter report exn_preconditions
let report_custom_errors summary =
let report_custom_errors tenv summary =
let pname = Specs.get_proc_name summary in
let error_preconditions, all_post_error =
custom_error_preconditions summary in
let report (pre, custom_error) =
if all_post_error || is_unavoidable pre then
if all_post_error || is_unavoidable tenv pre then
let loc = summary.Specs.attributes.ProcAttributes.loc in
let err_desc = Localise.desc_custom_error loc in
let exn = Exceptions.Custom_error (custom_error, err_desc) in
@ -1226,7 +1226,7 @@ module SpecMap = Map.Make (struct
end)
(** Update the specs of the current proc after the execution of one phase *)
let update_specs proc_name phase (new_specs : Specs.NormSpec.t list)
let update_specs tenv proc_name phase (new_specs : Specs.NormSpec.t list)
: Specs.NormSpec.t list * bool =
let new_specs = Specs.normalized_specs_to_specs new_specs in
let old_specs = Specs.get_specs proc_name in
@ -1262,7 +1262,7 @@ let update_specs proc_name phase (new_specs : Specs.NormSpec.t list)
changed := true;
L.out "Specs changed: added new post@\n%a@."
(Propset.pp pe_text (Specs.Jprop.to_prop spec.Specs.pre))
(Paths.PathSet.to_propset new_post);
(Paths.PathSet.to_propset tenv new_post);
current_specs :=
SpecMap.add spec.Specs.pre (new_post, new_visited)
(SpecMap.remove spec.Specs.pre !current_specs) end
@ -1279,7 +1279,7 @@ let update_specs proc_name phase (new_specs : Specs.NormSpec.t list)
let res = ref [] in
let convert pre (post_set, visited) =
res :=
Specs.spec_normalize
Specs.spec_normalize tenv
{ Specs.pre = pre;
Specs.posts = Paths.PathSet.elements post_set;
Specs.visited = visited }:: !res in
@ -1289,9 +1289,9 @@ let update_specs proc_name phase (new_specs : Specs.NormSpec.t list)
!res,!changed
(** update a summary after analysing a procedure *)
let update_summary prev_summary specs phase proc_name elapsed res =
let normal_specs = IList.map Specs.spec_normalize specs in
let new_specs, changed = update_specs proc_name phase normal_specs in
let update_summary tenv prev_summary specs phase proc_name elapsed res =
let normal_specs = IList.map (Specs.spec_normalize tenv) specs in
let new_specs, changed = update_specs tenv proc_name phase normal_specs in
let timestamp = max 1 (prev_summary.Specs.timestamp + if changed then 1 else 0) in
let stats_time = prev_summary.Specs.stats.Specs.stats_time +. elapsed in
let symops = prev_summary.Specs.stats.Specs.symops + SymOp.get_total () in
@ -1328,15 +1328,15 @@ let analyze_proc exe_env proc_desc : Specs.summary =
let elapsed = Unix.gettimeofday () -. init_time in
let prev_summary = Specs.get_summary_unsafe "analyze_proc" proc_name in
let updated_summary =
update_summary prev_summary specs phase proc_name elapsed res in
update_summary tenv prev_summary specs phase proc_name elapsed res in
if !Config.curr_language == Config.Clang && Config.report_custom_error then
report_custom_errors updated_summary;
report_custom_errors tenv updated_summary;
if !Config.curr_language == Config.Java && Config.report_runtime_exceptions then
report_runtime_exceptions tenv proc_desc updated_summary;
updated_summary
(** Perform the transition from [FOOTPRINT] to [RE_EXECUTION] in spec table *)
let transition_footprint_re_exe proc_name joined_pres =
let transition_footprint_re_exe tenv proc_name joined_pres =
L.out "Transition %a from footprint to re-exe@." Procname.pp proc_name;
let summary = Specs.get_summary_unsafe "transition_footprint_re_exe" proc_name in
let summary' =
@ -1348,7 +1348,7 @@ let transition_footprint_re_exe proc_name joined_pres =
let specs =
IList.map
(fun jp ->
Specs.spec_normalize
Specs.spec_normalize tenv
{ Specs.pre = jp;
posts = [];
visited = Specs.Visitedset.empty })
@ -1397,7 +1397,7 @@ let perform_transition exe_env tenv proc_name =
let err_str = "exception raised " ^ (Localise.to_string err_name) in
L.err "Error: %s %a@." err_str L.pp_ml_loc_opt ml_loc_opt;
[] in
transition_footprint_re_exe proc_name joined_pres in
transition_footprint_re_exe tenv proc_name joined_pres in
if Specs.get_phase proc_name == Specs.FOOTPRINT
then transition ()
@ -1428,7 +1428,8 @@ let interprocedural_algorithm exe_env : unit =
let process_one_proc proc_name =
match to_analyze proc_name with
| Some pdesc ->
Ondemand.analyze_proc_name ~propagate_exceptions:false pdesc proc_name
let tenv = Exe_env.get_tenv ~create:true exe_env proc_name in
Ondemand.analyze_proc_name tenv ~propagate_exceptions:false pdesc proc_name
| None ->
() in
IList.iter process_one_proc procs_to_analyze

@ -210,7 +210,7 @@ let rec instantiate_to_emp p condition sub vars = function
(* This function has to be changed in order to
* 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 =
let rec iter_match_with_impl tenv iter condition sub vars hpat hpats =
(*
L.out "@[.... iter_match_with_impl ....@.";
@ -222,13 +222,13 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let do_next iter_cur _ = match Prop.prop_iter_next iter_cur with
| None -> None
| Some iter_next -> iter_match_with_impl iter_next condition sub vars hpat hpats
| Some iter_next -> iter_match_with_impl tenv iter_next condition sub vars hpat hpats
in
let do_empty_hpats iter_cur _ =
let (sub_new, vars_leftover) = match Prop.prop_iter_current iter_cur with
let (sub_new, vars_leftover) = match Prop.prop_iter_current tenv iter_cur with
| _, (sub_new, vars_leftover) -> (sub_new, vars_leftover) in
let sub_res = sub_extend_with_ren sub_new vars_leftover in
let p_leftover = Prop.prop_iter_remove_curr_then_to_prop iter_cur in
let p_leftover = Prop.prop_iter_remove_curr_then_to_prop tenv iter_cur in
(*
L.out "@[.... iter_match_with_impl (final condtion check) ....@\n@.";
L.out "@[<4> sub_res : %a@\n@." pp_sub sub_res;
@ -237,13 +237,13 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
if condition p_leftover sub_res then Some (sub_res, p_leftover) else None
in
let do_nonempty_hpats iter_cur _ =
let (sub_new, vars_leftover) = match Prop.prop_iter_current iter_cur with
let (sub_new, vars_leftover) = match Prop.prop_iter_current tenv iter_cur with
| _, (sub_new, vars_leftover) -> (sub_new, vars_leftover) in
let (hpat_next, hpats_rest) = match hpats with
| [] -> assert false
| hpat_next :: hpats_rest -> (hpat_next, hpats_rest) in
let p_rest = Prop.prop_iter_remove_curr_then_to_prop iter_cur
in prop_match_with_impl_sub p_rest condition sub_new vars_leftover hpat_next hpats_rest
let p_rest = Prop.prop_iter_remove_curr_then_to_prop tenv iter_cur
in prop_match_with_impl_sub tenv p_rest condition sub_new vars_leftover hpat_next hpats_rest
in
let gen_filter_pointsto lexp2 strexp2 te2 = function
| Sil.Hpointsto (lexp1, strexp1, te1) when Exp.equal te1 te2 ->
@ -258,8 +258,8 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let do_kinds_match = match k1, k2 with
| Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE -> true
| Sil.Lseg_PE, Sil.Lseg_NE -> false in
(* let do_paras_match = hpara_match_with_impl hpat.flag para1 para2 *)
let do_paras_match = hpara_match_with_impl true para1 para2
(* let do_paras_match = hpara_match_with_impl tenv hpat.flag para1 para2 *)
let do_paras_match = hpara_match_with_impl tenv true para1 para2
in if not (do_kinds_match && do_paras_match) then None
else
let es1 = [e_start1; e_end1]@es_shared1 in
@ -273,8 +273,8 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
let do_kinds_match = match k1, k2 with
| Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE -> true
| Sil.Lseg_PE, Sil.Lseg_NE -> false in
(* let do_paras_match = hpara_dll_match_with_impl hpat.flag para1 para2 *)
let do_paras_match = hpara_dll_match_with_impl true para1 para2
(* let do_paras_match = hpara_dll_match_with_impl tenv hpat.flag para1 para2 *)
let do_paras_match = hpara_dll_match_with_impl tenv true para1 para2
in if not (do_kinds_match && do_paras_match) then None
else
let es1 = [iF1; oB1; oF1; iB1]@es_shared1 in
@ -309,11 +309,11 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
None
| Some (sub_new, vars_leftover), [] ->
let sub_res = sub_extend_with_ren sub_new vars_leftover in
let p_leftover = Prop.prop_iter_to_prop iter in
let p_leftover = Prop.prop_iter_to_prop tenv iter in
if condition p_leftover sub_res then Some(sub_res, p_leftover) else None
| Some (sub_new, vars_leftover), hpat_next:: hpats_rest ->
let p = Prop.prop_iter_to_prop iter in
prop_match_with_impl_sub p condition sub_new vars_leftover hpat_next hpats_rest in
let p = Prop.prop_iter_to_prop tenv iter in
prop_match_with_impl_sub tenv p condition sub_new vars_leftover hpat_next hpats_rest in
let do_para_lseg _ =
let (para2_exist_vars, para2_inst) = Sil.hpara_instantiate para2 e_start2 e_end2 es_shared2 in
(* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *)
@ -323,7 +323,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| para2_pat :: para2_pats -> (para2_pat, para2_pats) in
let new_vars = para2_exist_vars @ vars in
let new_hpats = para2_hpats @ hpats
in match (iter_match_with_impl iter condition sub new_vars para2_hpat new_hpats) with
in match (iter_match_with_impl tenv iter condition sub new_vars para2_hpat new_hpats) with
| None -> None
| Some (sub_res, p_leftover) when condition p_leftover sub_res ->
let not_in_para2_exist_vars id =
@ -360,11 +360,11 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| None, _ -> None
| Some (sub_new, vars_leftover), [] ->
let sub_res = sub_extend_with_ren sub_new vars_leftover in
let p_leftover = Prop.prop_iter_to_prop iter
let p_leftover = Prop.prop_iter_to_prop tenv iter
in if condition p_leftover sub_res then Some(sub_res, p_leftover) else None
| Some (sub_new, vars_leftover), hpat_next:: hpats_rest ->
let p = Prop.prop_iter_to_prop iter
in prop_match_with_impl_sub p condition sub_new vars_leftover hpat_next hpats_rest in
let p = Prop.prop_iter_to_prop tenv iter
in prop_match_with_impl_sub tenv p condition sub_new vars_leftover hpat_next hpats_rest in
let do_para_dllseg _ =
let fully_instantiated_iF2 = not (IList.exists (fun id -> Sil.ident_in_exp id iF2) vars)
in if (not fully_instantiated_iF2) then None else
@ -380,7 +380,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| para2_pat :: para2_pats -> (para2_pat, para2_pats) in
let new_vars = para2_exist_vars @ vars_leftover in
let new_hpats = para2_hpats @ hpats
in match (iter_match_with_impl iter condition sub_new new_vars para2_hpat new_hpats) with
in match (iter_match_with_impl tenv iter condition sub_new new_vars para2_hpat new_hpats) with
| None -> None
| Some (sub_res, p_leftover) when condition p_leftover sub_res ->
let not_in_para2_exist_vars id =
@ -396,7 +396,7 @@ let rec iter_match_with_impl iter condition sub vars hpat hpats =
| (Some iter_cur, _) -> execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur]
end
and prop_match_with_impl_sub p condition sub vars hpat hpats =
and prop_match_with_impl_sub tenv p condition sub vars hpat hpats =
(*
L.out "@[.... prop_match_with_impl_sub ....@.";
L.out "@[<4> sub: %a@\n@." pp_sub sub;
@ -408,9 +408,9 @@ and prop_match_with_impl_sub p condition sub vars hpat hpats =
| None ->
instantiate_to_emp p condition sub vars (hpat:: hpats)
| Some iter ->
iter_match_with_impl iter condition sub vars hpat hpats
iter_match_with_impl tenv iter condition sub vars hpat hpats
and hpara_common_match_with_impl impl_ok ids1 sigma1 eids2 ids2 sigma2 =
and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 =
try
let sub_ids =
let ren_ids = IList.combine ids2 ids1 in
@ -431,9 +431,9 @@ and hpara_common_match_with_impl impl_ok ids1 sigma1 eids2 ids2 sigma2 =
let allow_impl hpred = { hpred = hpred; flag = impl_ok } in
(allow_impl hpred2_ren, IList.map allow_impl sigma2_ren) in
let condition _ _ = true in
let p1 = Prop.normalize (Prop.from_sigma sigma1) in
let p1 = Prop.normalize tenv (Prop.from_sigma sigma1) in
begin
match (prop_match_with_impl_sub p1 condition Sil.sub_empty eids_fresh hpat2 hpats2) with
match (prop_match_with_impl_sub tenv p1 condition Sil.sub_empty eids_fresh hpat2 hpats2) with
| None -> false
| Some (_, p1') when Prop.prop_is_emp p1' -> true
| _ -> false
@ -441,7 +441,7 @@ and hpara_common_match_with_impl impl_ok ids1 sigma1 eids2 ids2 sigma2 =
with
| Invalid_argument _ -> false
and hpara_match_with_impl impl_ok para1 para2 : bool =
and hpara_match_with_impl tenv impl_ok para1 para2 : bool =
(*
L.out "@[.... hpara_match_with_impl_sub ....@.";
L.out "@[<4> HPARA1: %a@\n@." pp_hpara para1;
@ -450,9 +450,9 @@ and hpara_match_with_impl impl_ok para1 para2 : bool =
let ids1 = para1.Sil.root :: para1.Sil.next :: para1.Sil.svars in
let ids2 = para2.Sil.root :: para2.Sil.next :: para2.Sil.svars in
let eids2 = para2.Sil.evars
in hpara_common_match_with_impl impl_ok ids1 para1.Sil.body eids2 ids2 para2.Sil.body
in hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body eids2 ids2 para2.Sil.body
and hpara_dll_match_with_impl impl_ok para1 para2 : bool =
and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool =
(*
L.out "@[.... hpara_dll_match_with_impl_sub ....@.";
L.out "@[<4> HPARA1: %a@\n@." pp_hpara_dll para1;
@ -461,7 +461,7 @@ and hpara_dll_match_with_impl impl_ok para1 para2 : bool =
let ids1 = para1.Sil.cell :: para1.Sil.blink :: para1.Sil.flink :: para1.Sil.svars_dll in
let ids2 = para2.Sil.cell :: para2.Sil.blink :: para2.Sil.flink :: para2.Sil.svars_dll in
let eids2 = para2.Sil.evars_dll in
hpara_common_match_with_impl impl_ok ids1 para1.Sil.body_dll eids2 ids2 para2.Sil.body_dll
hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body_dll eids2 ids2 para2.Sil.body_dll
(** [prop_match_with_impl p condition vars hpat hpats]
@ -469,8 +469,8 @@ and hpara_dll_match_with_impl impl_ok para1 para2 : bool =
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
let prop_match_with_impl tenv p condition vars hpat hpats =
prop_match_with_impl_sub tenv p condition Sil.sub_empty vars hpat hpats
let sigma_remove_hpred eq sigma e =
let filter = function
@ -568,11 +568,11 @@ let corres_related corres e1 e2 =
| _ -> false
(* TO DO. Perhaps OK. Need to implemenet a better isomorphism check later.*)
let hpara_iso para1 para2 =
hpara_match_with_impl false para1 para2 && hpara_match_with_impl false para2 para1
let hpara_iso tenv para1 para2 =
hpara_match_with_impl tenv false para1 para2 && hpara_match_with_impl tenv false para2 para1
let hpara_dll_iso para1 para2 =
hpara_dll_match_with_impl false para1 para2 && hpara_dll_match_with_impl false para2 para1
let hpara_dll_iso tenv para1 para2 =
hpara_dll_match_with_impl tenv false para1 para2 && hpara_dll_match_with_impl tenv false para2 para1
(** [generic_find_partial_iso] finds isomorphic subsigmas of [sigma_todo].
@ -580,7 +580,7 @@ let hpara_dll_iso para1 para2 =
[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 =
let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigma_todo =
match todos with
| [] ->
let sigma1, sigma2 = sigma_corres in
@ -589,7 +589,7 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
begin
match corres_extend_front e1 e2 corres with
| None -> assert false
| Some new_corres -> generic_find_partial_iso mode update new_corres sigma_corres todos' sigma_todo
| Some new_corres -> generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo
end
| (e1, e2) :: todos' when corres_extensible corres e1 e2 ->
let hpredo1, hpredo2, new_sigma_todo = update e1 e2 sigma_todo in
@ -599,7 +599,7 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
begin
match corres_extend_front e1 e2 corres with
| None -> assert false
| Some new_corres -> generic_find_partial_iso mode update new_corres sigma_corres todos' sigma_todo
| Some new_corres -> generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo
end
| None, _ | _, None ->
None
@ -621,12 +621,12 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
let new_sigma2 = hpred2 :: sigma2 in
(new_sigma1, new_sigma2) in
let new_todos = todos'' @ todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo
end
| Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1),
Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ->
if k1 <> k2 || not (hpara_iso para1 para2) then None
if k1 <> k2 || not (hpara_iso tenv para1 para2) then None
else
(try
let new_corres = match corres_extend_front e1 e2 corres with
@ -640,11 +640,11 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
let new_todos =
let shared12 = IList.combine shared1 shared2 in
(root1, root2) :: (next1, next2) :: shared12 @ todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
generic_find_partial_iso tenv 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) ->
if k1 <> k2 || not (hpara_dll_iso para1 para2) then None
if k1 <> k2 || not (hpara_dll_iso tenv para1 para2) then None
else
(try
let new_corres = match corres_extend_front e1 e2 corres with
@ -658,7 +658,7 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
let new_todos =
let shared12 = IList.combine shared1 shared2 in
(iF1, iF2):: (oB1, oB2):: (oF1, oF2):: (iB1, iB2):: shared12@todos' in
generic_find_partial_iso mode update new_corres new_sigma_corres new_todos new_sigma_todo
generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo
with Invalid_argument _ -> None)
| _ -> None
end
@ -670,14 +670,14 @@ let rec generic_find_partial_iso mode update corres sigma_corres todos sigma_tod
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 find_partial_iso tenv eq corres todos sigma =
let update e1 e2 sigma0 =
let (hpredo1, sigma0_no_e1) = sigma_remove_hpred eq sigma0 e1 in
let (hpredo2, sigma0_no_e12) = sigma_remove_hpred eq sigma0_no_e1 e2 in
(hpredo1, hpredo2, sigma0_no_e12) in
let init_sigma_corres = ([], []) in
let init_sigma_todo = sigma in
generic_find_partial_iso Exact update corres init_sigma_corres todos init_sigma_todo
generic_find_partial_iso tenv 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
@ -685,7 +685,7 @@ let find_partial_iso eq corres todos sigma =
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 find_partial_iso_from_two_sigmas tenv mode eq corres todos sigma1 sigma2 =
let update e1 e2 sigma_todo =
let sigma_todo1, sigma_todo2 = sigma_todo in
let hpredo1, sigma_todo1_no_e1 = sigma_remove_hpred eq sigma_todo1 e1 in
@ -694,7 +694,7 @@ let find_partial_iso_from_two_sigmas mode eq corres todos sigma1 sigma2 =
(hpredo1, hpredo2, new_sigma_todo) in
let init_sigma_corres = ([], []) in
let init_sigma_todo = (sigma1, sigma2) in
generic_find_partial_iso mode update corres init_sigma_corres todos init_sigma_todo
generic_find_partial_iso tenv mode update corres init_sigma_corres todos init_sigma_todo
(** Lift the kind of list segment predicates to PE *)
let hpred_lift_to_pe hpred =
@ -714,7 +714,7 @@ let sigma_lift_to_pe sigma =
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 generic_para_create tenv corres sigma1 elist1 =
let corres_ids =
let not_same_consts = function
| Exp.Const c1, Exp.Const c2 -> not (Const.equal c1 c2)
@ -733,16 +733,16 @@ let generic_para_create corres sigma1 elist1 =
let body =
let sigma1' = sigma_lift_to_pe sigma1 in
let renaming_exp = IList.map (fun (e1, id) -> (e1, Exp.Var id)) renaming in
Prop.sigma_replace_exp renaming_exp sigma1' in
Prop.sigma_replace_exp tenv renaming_exp sigma1' in
(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. *)
let hpara_create corres sigma1 root1 next1 =
let hpara_create tenv corres sigma1 root1 next1 =
let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; next1] in
generic_para_create tenv corres sigma1 [root1; next1] in
let get_id1 e1 =
try
let is_equal_to_e1 (e1', _) = Exp.equal e1 e1' in
@ -763,9 +763,9 @@ let hpara_create corres sigma1 root1 next1 =
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 hpara_dll_create tenv corres sigma1 root1 blink1 flink1 =
let renaming, body, ids_exists, ids_shared, es_shared =
generic_para_create corres sigma1 [root1; blink1; flink1] in
generic_para_create tenv corres sigma1 [root1; blink1; flink1] in
let get_id1 e1 =
try
let is_equal_to_e1 (e1', _) = Exp.equal e1 e1' in

@ -17,8 +17,8 @@ open! Utils
*)
(* TODO: missing documentation *)
val hpara_match_with_impl : bool -> Sil.hpara -> Sil.hpara -> bool
val hpara_dll_match_with_impl : bool -> Sil.hpara_dll -> Sil.hpara_dll -> bool
val hpara_match_with_impl : Tenv.t -> bool -> Sil.hpara -> Sil.hpara -> bool
val hpara_dll_match_with_impl : Tenv.t -> bool -> Sil.hpara_dll -> Sil.hpara_dll -> bool
(** Type for a hpred pattern. [flag=false] means that the implication
between hpreds is not considered, and [flag = true] means that it is
@ -36,7 +36,7 @@ type sidecondition = Prop.normal Prop.t -> Sil.subst -> bool
1) [dom(subst) = vars]
2) [p |- (hpat.hpred * hpats.hpred)[subst] * p_leftover].
Using the flag [field], we can control the strength of |-. *)
val prop_match_with_impl : Prop.normal Prop.t -> sidecondition -> Ident.t list -> hpred_pat -> hpred_pat list -> (Sil.subst * Prop.normal Prop.t) option
val prop_match_with_impl : Tenv.t -> Prop.normal Prop.t -> sidecondition -> Ident.t list -> hpred_pat -> hpred_pat list -> (Sil.subst * Prop.normal Prop.t) option
(** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma.
The first argument is an equality checker.
@ -45,7 +45,7 @@ val prop_match_with_impl : Prop.normal Prop.t -> sidecondition -> Ident.t list -
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. *)
val find_partial_iso :
val find_partial_iso : Tenv.t ->
(Exp.t -> Exp.t -> bool) ->
(Exp.t * Exp.t) list ->
(Exp.t * Exp.t) list ->
@ -62,7 +62,7 @@ type iso_mode = Exact | LFieldForget | RFieldForget
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. *)
val find_partial_iso_from_two_sigmas :
val find_partial_iso_from_two_sigmas : Tenv.t ->
iso_mode ->
(Exp.t -> Exp.t -> bool) ->
(Exp.t * Exp.t) list ->
@ -73,17 +73,17 @@ val find_partial_iso_from_two_sigmas :
option
(** [hpara_iso] soundly checks whether two hparas are isomorphic. *)
val hpara_iso : Sil.hpara -> Sil.hpara -> bool
val hpara_iso : Tenv.t -> Sil.hpara -> Sil.hpara -> bool
(** [hpara_dll_iso] soundly checks whether two hpara_dlls are isomorphic. *)
val hpara_dll_iso : Sil.hpara_dll -> Sil.hpara_dll -> bool
val hpara_dll_iso : Tenv.t -> Sil.hpara_dll -> Sil.hpara_dll -> bool
(** [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. *)
val hpara_create :
val hpara_create : Tenv.t ->
(Exp.t * Exp.t) list ->
Sil.hpred list ->
Exp.t ->
@ -94,7 +94,7 @@ val hpara_create :
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. *)
val hpara_dll_create :
val hpara_dll_create : Tenv.t ->
(Exp.t * Exp.t) list ->
Sil.hpred list ->
Exp.t ->

@ -49,17 +49,17 @@ let extract_array_type typ =
| _ -> None
(** Return a result from a procedure call. *)
let return_result e prop ret_ids =
let return_result tenv e prop ret_ids =
match ret_ids with
| [ret_id] -> Prop.conjoin_eq e (Exp.Var ret_id) prop
| [ret_id] -> Prop.conjoin_eq tenv e (Exp.Var ret_id) prop
| _ -> prop
(* Add an array of typ pointed to by lexp to prop_ if it doesn't already exist *)
(* Return the new prop and the array length *)
(* Return None if it fails to add the array *)
let add_array_to_prop pdesc prop_ lexp typ =
let add_array_to_prop tenv pdesc prop_ lexp typ =
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
begin
try
let hpred = IList.find (function
@ -74,45 +74,45 @@ let add_array_to_prop pdesc prop_ lexp typ =
| Some arr_typ ->
let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let s = mk_empty_array_rearranged len in
let hpred = Prop.mk_ptsto n_lexp s (Exp.Sizeof (arr_typ, Some len, Subtype.exact)) in
let hpred = Prop.mk_ptsto tenv n_lexp s (Exp.Sizeof (arr_typ, Some len, Subtype.exact)) in
let sigma = prop.Prop.sigma in
let sigma_fp = prop.Prop.sigma_fp in
let prop'= Prop.set prop ~sigma:(hpred:: sigma) in
let prop''= Prop.set prop' ~sigma_fp:(hpred:: sigma_fp) in
let prop''= Prop.normalize prop'' in
let prop''= Prop.normalize tenv prop'' in
Some (len, prop'')
| _ -> None
end
(* Add an array in prop if it is not allocated.*)
let execute___require_allocated_array { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute___require_allocated_array { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args with
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
(match add_array_to_prop pdesc prop_ lexp typ with
(match add_array_to_prop tenv pdesc prop_ lexp typ with
| None -> []
| Some (_, prop) -> [(prop, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___get_array_length { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute___get_array_length { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args with
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
(match add_array_to_prop pdesc prop_ lexp typ with
(match add_array_to_prop tenv pdesc prop_ lexp typ with
| None -> []
| Some (len, prop) -> [(return_result len prop ret_ids, path)])
| Some (len, prop) -> [(return_result tenv len prop ret_ids, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___set_array_length { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute___set_array_length { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args, ret_ids with
| [(lexp, typ); (len, _)], []->
(match add_array_to_prop pdesc prop_ lexp typ with
(match add_array_to_prop tenv pdesc prop_ lexp typ with
| None -> []
| Some (_, prop_a) -> (* Invariant: prop_a has an array pointed to by lexp *)
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop__ = check_arith_norm_exp pname lexp prop_a in
let n_len, prop = check_arith_norm_exp pname len prop__ in
let n_lexp, prop__ = check_arith_norm_exp tenv pname lexp prop_a in
let n_len, prop = check_arith_norm_exp tenv pname len prop__ in
let hpred, sigma' = IList.partition (function
| Sil.Hpointsto(e, _, _) -> Exp.equal e n_lexp
| _ -> false) prop.Prop.sigma in
@ -120,24 +120,24 @@ let execute___set_array_length { Builtin.pdesc; prop_; path; ret_ids; args; }
| [Sil.Hpointsto(e, Sil.Earray(_, esel, inst), t)] ->
let hpred' = Sil.Hpointsto (e, Sil.Earray (n_len, esel, inst), t) in
let prop' = Prop.set prop ~sigma:(hpred':: sigma') in
[(Prop.normalize prop', path)]
[(Prop.normalize tenv prop', path)]
| _ -> [] (* by construction of prop_a this case is impossible *) ))
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___print_value { Builtin.pdesc; prop_; path; args; }
let execute___print_value { Builtin.tenv; pdesc; prop_; path; args; }
: Builtin.ret_typ =
L.err "__print_value: ";
let pname = Cfg.Procdesc.get_proc_name pdesc in
let do_arg (lexp, _) =
let n_lexp, _ = check_arith_norm_exp pname lexp prop_ in
let n_lexp, _ = check_arith_norm_exp tenv pname lexp prop_ in
L.err "%a " (Sil.pp_exp pe_text) n_lexp in
IList.iter do_arg args;
L.err "@.";
[(prop_, path)]
let is_undefined_opt prop n_lexp =
let is_undefined_opt tenv prop n_lexp =
let is_undef =
Option.is_some (Attribute.get_undef prop n_lexp) in
Option.is_some (Attribute.get_undef tenv prop n_lexp) in
is_undef && (Config.angelic_execution || Config.optimistic_cast)
(** Creates an object in the heap with a given type, when the object is not known to be null or when
@ -156,13 +156,13 @@ let create_type tenv n_lexp typ prop =
let sexp = Sil.Estruct ([], Sil.inst_none) in
let typ'' = Tenv.expand_type tenv typ' in
let texp = Exp.Sizeof (typ'', None, Subtype.subtypes) in
let hpred = Prop.mk_ptsto n_lexp sexp texp in
let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in
Some hpred
| Typ.Tarray _ ->
let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let sexp = mk_empty_array len in
let texp = Exp.Sizeof (typ, None, Subtype.subtypes) in
let hpred = Prop.mk_ptsto n_lexp sexp texp in
let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in
Some hpred
| _ -> None in
match mhpred with
@ -173,19 +173,19 @@ let create_type tenv n_lexp typ prop =
let prop''=
let has_normal_variables =
Sil.fav_exists (Sil.exp_fav n_lexp) Ident.is_normal in
if (is_undefined_opt prop n_lexp) || has_normal_variables
if (is_undefined_opt tenv prop n_lexp) || has_normal_variables
then prop'
else Prop.set prop' ~sigma_fp:(hpred:: sigma_fp) in
let prop''= Prop.normalize prop'' in
let prop''= Prop.normalize tenv prop'' in
prop''
| None -> prop in
let sil_is_null = Exp.BinOp (Binop.Eq, n_lexp, Exp.zero) in
let sil_is_nonnull = Exp.UnOp (Unop.LNot, sil_is_null, None) in
let null_case = Propset.to_proplist (prune ~positive:true sil_is_null prop) in
let non_null_case = Propset.to_proplist (prune ~positive:true sil_is_nonnull prop_type) in
let null_case = Propset.to_proplist (prune tenv ~positive:true sil_is_null prop) in
let non_null_case = Propset.to_proplist (prune tenv ~positive:true sil_is_nonnull prop_type) in
if ((IList.length non_null_case) > 0) && (!Config.footprint) then
non_null_case
else if ((IList.length non_null_case) > 0) && (is_undefined_opt prop n_lexp) then
else if ((IList.length non_null_case) > 0) && (is_undefined_opt tenv prop n_lexp) then
non_null_case
else null_case @ non_null_case
@ -194,7 +194,7 @@ let execute___get_type_of { Builtin.pdesc; tenv; prop_; path; ret_ids; args; }
match args with
| [(lexp, typ)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let props = create_type tenv n_lexp typ prop in
let aux prop =
begin
@ -204,15 +204,15 @@ let execute___get_type_of { Builtin.pdesc; tenv; prop_; path; ret_ids; args; }
| _ -> false) prop.Prop.sigma in
match hpred with
| Sil.Hpointsto(_, _, texp) ->
(return_result texp prop ret_ids), path
(return_result tenv texp prop ret_ids), path
| _ -> assert false
with Not_found -> (return_result Exp.zero prop ret_ids), path
with Not_found -> (return_result tenv Exp.zero prop ret_ids), path
end in
(IList.map aux props)
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** replace the type of the ptsto rooted at [root_e] with [texp] in [prop] *)
let replace_ptsto_texp prop root_e texp =
let replace_ptsto_texp tenv prop root_e texp =
let process_sigma sigma =
let sigma1, sigma2 =
IList.partition (function
@ -225,7 +225,7 @@ let replace_ptsto_texp prop root_e texp =
let sigma_fp = prop.Prop.sigma_fp in
let prop'= Prop.set prop ~sigma:(process_sigma sigma) in
let prop''= Prop.set prop' ~sigma_fp:(process_sigma sigma_fp) in
Prop.normalize prop''
Prop.normalize tenv prop''
let execute___instanceof_cast ~instof
{ Builtin.pdesc; tenv; prop_; path; ret_ids; args; }
@ -233,8 +233,8 @@ let execute___instanceof_cast ~instof
match args with
| [(val1_, typ1); (texp2_, _)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let val1, prop__ = check_arith_norm_exp pname val1_ prop_ in
let texp2, prop = check_arith_norm_exp pname texp2_ prop__ in
let val1, prop__ = check_arith_norm_exp tenv pname val1_ prop_ in
let texp2, prop = check_arith_norm_exp tenv pname texp2_ prop__ in
let is_cast_to_reference =
match typ1 with
| Typ.Tptr (_, Typ.Pk_reference) -> true
@ -244,11 +244,11 @@ let execute___instanceof_cast ~instof
let should_throw_exception =
!Config.curr_language = Config.Java || is_cast_to_reference in
let deal_with_failed_cast val1 _ texp1 texp2 =
Tabulation.raise_cast_exception
Tabulation.raise_cast_exception tenv
__POS__ None texp1 texp2 val1 in
let exe_one_prop prop =
if Exp.equal texp2 Exp.zero then
[(return_result Exp.zero prop ret_ids, path)]
[(return_result tenv Exp.zero prop ret_ids, path)]
else
begin
try
@ -264,8 +264,8 @@ let execute___instanceof_cast ~instof
| Some texp1' ->
let prop' =
if Exp.equal texp1 texp1' then prop
else replace_ptsto_texp prop val1 texp1' in
[(return_result res_e prop' ret_ids, path)] in
else replace_ptsto_texp tenv prop val1 texp1' in
[(return_result tenv res_e prop' ret_ids, path)] in
if instof then (* instanceof *)
begin
let pos_res = mk_res pos_type_opt Exp.one in
@ -289,14 +289,14 @@ let execute___instanceof_cast ~instof
begin
match neg_type_opt with
| Some _ ->
if is_undefined_opt prop val1 then mk_res pos_type_opt val1
if is_undefined_opt tenv prop val1 then mk_res pos_type_opt val1
else deal_with_failed_cast val1 typ1 texp1 texp2
| None -> mk_res pos_type_opt val1
end
end
| _ -> []
with Not_found ->
[(return_result val1 prop ret_ids, path)]
[(return_result tenv val1 prop ret_ids, path)]
end in
let props = create_type tenv val1 typ1 prop in
IList.flatten (IList.map exe_one_prop props)
@ -310,10 +310,10 @@ let execute___cast builtin_args
: Builtin.ret_typ =
execute___instanceof_cast ~instof:false builtin_args
let set_resource_attribute prop path n_lexp loc ra_res =
let prop' = match Attribute.get_resource prop n_lexp with
let set_resource_attribute tenv prop path n_lexp loc ra_res =
let prop' = match Attribute.get_resource tenv prop n_lexp with
| Some (Apred (Aresource ra, _)) ->
Attribute.add_or_replace prop (Apred (Aresource { ra with ra_res }, [n_lexp]))
Attribute.add_or_replace tenv prop (Apred (Aresource { ra with ra_res }, [n_lexp]))
| _ ->
let pname = PredSymb.mem_alloc_pname PredSymb.Mnew in
let ra =
@ -323,72 +323,71 @@ let set_resource_attribute prop path n_lexp loc ra_res =
ra_pname = pname;
ra_loc = loc;
ra_vpath = None } in
Attribute.add_or_replace prop (Apred (Aresource ra, [n_lexp])) in
Attribute.add_or_replace tenv prop (Apred (Aresource ra, [n_lexp])) in
[(prop', path)]
(** Set the attibute of the value as file *)
let execute___set_file_attribute { Builtin.pdesc; prop_; path; ret_ids; args; loc; }
let execute___set_file_attribute { Builtin.tenv; pdesc; prop_; path; ret_ids; args; loc; }
: Builtin.ret_typ =
match args, ret_ids with
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
set_resource_attribute prop path n_lexp loc PredSymb.Rfile
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
set_resource_attribute tenv prop path n_lexp loc PredSymb.Rfile
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Set the attibute of the value as lock *)
let execute___set_lock_attribute { Builtin.pdesc; prop_; path; ret_ids; args; loc; }
let execute___set_lock_attribute { Builtin.tenv; pdesc; prop_; path; ret_ids; args; loc; }
: Builtin.ret_typ =
match args, ret_ids with
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
set_resource_attribute prop path n_lexp loc PredSymb.Rlock
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
set_resource_attribute tenv prop path n_lexp loc PredSymb.Rlock
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Set the resource attribute of the first real argument of method as ignore, the first argument is
assumed to be "this" *)
let execute___method_set_ignore_attribute
{ Builtin.pdesc; prop_; path; ret_ids; args; loc; }
let execute___method_set_ignore_attribute { Builtin.tenv; pdesc; prop_; path; ret_ids; args; loc; }
: Builtin.ret_typ =
match args, ret_ids with
| [_ ; (lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
set_resource_attribute prop path n_lexp loc PredSymb.Rignore
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
set_resource_attribute tenv prop path n_lexp loc PredSymb.Rignore
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Set the attibute of the value as memory *)
let execute___set_mem_attribute { Builtin.pdesc; prop_; path; ret_ids; args; loc; }
let execute___set_mem_attribute { Builtin.tenv; pdesc; prop_; path; ret_ids; args; loc; }
: Builtin.ret_typ =
match args, ret_ids with
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
set_resource_attribute prop path n_lexp loc (PredSymb.Rmemory PredSymb.Mnew)
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
set_resource_attribute tenv prop path n_lexp loc (PredSymb.Rmemory PredSymb.Mnew)
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** report an error if [lexp] is tainted; otherwise, add untained([lexp]) as a precondition *)
let execute___check_untainted
{ Builtin.pdesc; prop_; path; ret_ids; args; proc_name = callee_pname; }
{ Builtin.tenv; pdesc; prop_; path; ret_ids; args; proc_name = callee_pname; }
: Builtin.ret_typ =
match args, ret_ids with
| [(lexp, _)], _ ->
let caller_pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp caller_pname lexp prop_ in
[(check_untainted n_lexp PredSymb.Tk_unknown caller_pname callee_pname prop, path)]
let n_lexp, prop = check_arith_norm_exp tenv caller_pname lexp prop_ in
[(check_untainted tenv n_lexp PredSymb.Tk_unknown caller_pname callee_pname prop, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** take a pointer to a struct, and return the value of a hidden field in the struct *)
let execute___get_hidden_field { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute___get_hidden_field { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args with
| [(lexp, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let ret_val = ref None in
let return_val p = match !ret_val with
| Some e -> return_result e p ret_ids
| Some e -> return_result tenv e p ret_ids
| None -> p in
let foot_var = lazy (Exp.Var (Ident.create_fresh Ident.kfootprint)) in
let filter_fld_hidden (f, _ ) = Ident.fieldname_is_hidden f in
@ -413,19 +412,19 @@ let execute___get_hidden_field { Builtin.pdesc; prop_; path; ret_ids; args; }
let sigma' = IList.map (do_hpred false) prop.Prop.sigma in
let sigma_fp' = IList.map (do_hpred true) prop.Prop.sigma_fp in
let prop' = Prop.set prop ~sigma:sigma' ~sigma_fp:sigma_fp' in
let prop'' = return_val (Prop.normalize prop') in
let prop'' = return_val (Prop.normalize tenv prop') in
[(prop'', path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** take a pointer to a struct and a value,
and set a hidden field in the struct to the given value *)
let execute___set_hidden_field { Builtin.pdesc; prop_; path; args; }
let execute___set_hidden_field { Builtin.tenv; pdesc; prop_; path; args; }
: Builtin.ret_typ =
match args with
| [(lexp1, _); (lexp2, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp1, prop__ = check_arith_norm_exp pname lexp1 prop_ in
let n_lexp2, prop = check_arith_norm_exp pname lexp2 prop__ in
let n_lexp1, prop__ = check_arith_norm_exp tenv pname lexp1 prop_ in
let n_lexp2, prop = check_arith_norm_exp tenv pname lexp2 prop__ in
let foot_var = lazy (Exp.Var (Ident.create_fresh Ident.kfootprint)) in
let filter_fld_hidden (f, _ ) = Ident.fieldname_is_hidden f in
let has_fld_hidden fsel = IList.exists filter_fld_hidden fsel in
@ -447,7 +446,7 @@ let execute___set_hidden_field { Builtin.pdesc; prop_; path; args; }
let sigma' = IList.map (do_hpred false) prop.Prop.sigma in
let sigma_fp' = IList.map (do_hpred true) prop.Prop.sigma_fp in
let prop' = Prop.set prop ~sigma:sigma' ~sigma_fp:sigma_fp' in
let prop'' = Prop.normalize prop' in
let prop'' = Prop.normalize tenv prop' in
[(prop'', path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
@ -494,13 +493,12 @@ let get_suppress_npe_flag args =
false, args' (* this is a CFRelease/CFRetain *)
| _ -> true, args
let execute___objc_retain_impl
({ Builtin.prop_; args; ret_ids; } as builtin_args)
let execute___objc_retain_impl ({ Builtin.tenv; prop_; args; ret_ids; } as builtin_args)
: Builtin.ret_typ =
let mask_errors, args' = get_suppress_npe_flag args in
match args' with
| [(lexp, _)] ->
let prop = return_result lexp prop_ ret_ids in
let prop = return_result tenv lexp prop_ ret_ids in
execute___objc_counter_update
~mask_errors (Binop.PlusA) (IntLit.one)
{ builtin_args with Builtin.prop_ = prop; args = args'; }
@ -537,26 +535,26 @@ let execute___objc_release_cf builtin_args
(** Set the attibute of the value as objc autoreleased *)
let execute___set_autorelease_attribute
{ Builtin.pdesc; prop_; path; ret_ids; args; }
{ Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args, ret_ids with
| [(lexp, _)], _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let prop = return_result lexp prop_ ret_ids in
let prop = return_result tenv lexp prop_ ret_ids in
if Config.objc_memory_model_on then
let n_lexp, prop = check_arith_norm_exp pname lexp prop in
let prop' = Attribute.add_or_replace prop (Apred (Aautorelease, [n_lexp])) in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop in
let prop' = Attribute.add_or_replace tenv prop (Apred (Aautorelease, [n_lexp])) in
[(prop', path)]
else execute___no_op prop path
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Release all the objects in the pool *)
let execute___release_autorelease_pool
({ Builtin.prop_; path; } as builtin_args)
({ Builtin.tenv; prop_; path; } as builtin_args)
: Builtin.ret_typ =
if Config.objc_memory_model_on then
let autoreleased_objects = Attribute.get_for_symb prop_ Aautorelease in
let prop_without_attribute = Attribute.remove_for_attr prop_ Aautorelease in
let prop_without_attribute = Attribute.remove_for_attr tenv prop_ Aautorelease in
let call_release res atom =
match res, atom with
| ((prop', path') :: _, Sil.Apred (_, exp :: _)) ->
@ -579,29 +577,29 @@ let execute___release_autorelease_pool
IList.fold_left call_release [(prop_without_attribute, path)] autoreleased_objects
else execute___no_op prop_ path
let set_attr pdesc prop path exp attr =
let set_attr tenv pdesc prop path exp attr =
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname exp prop in
[(Attribute.add_or_replace prop (Apred (attr, [n_lexp])), path)]
let n_lexp, prop = check_arith_norm_exp tenv pname exp prop in
[(Attribute.add_or_replace tenv prop (Apred (attr, [n_lexp])), path)]
let delete_attr pdesc prop path exp attr =
let delete_attr tenv pdesc prop path exp attr =
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname exp prop in
[(Attribute.remove prop (Apred (attr, [n_lexp])), path)]
let n_lexp, prop = check_arith_norm_exp tenv pname exp prop in
[(Attribute.remove tenv prop (Apred (attr, [n_lexp])), path)]
(** Set attibute att *)
let execute___set_attr attr { Builtin.pdesc; prop_; path; args; }
let execute___set_attr attr { Builtin.tenv; pdesc; prop_; path; args; }
: Builtin.ret_typ =
match args with
| [(lexp, _)] -> set_attr pdesc prop_ path lexp attr
| [(lexp, _)] -> set_attr tenv pdesc prop_ path lexp attr
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(** Delete the locked attibute of the value*)
let execute___delete_locked_attribute { Builtin.prop_; pdesc; path; args; }
let execute___delete_locked_attribute { Builtin.tenv; prop_; pdesc; path; args; }
: Builtin.ret_typ =
match args with
| [(lexp, _)] -> delete_attr pdesc prop_ path lexp PredSymb.Alocked
| [(lexp, _)] -> delete_attr tenv pdesc prop_ path lexp PredSymb.Alocked
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
@ -626,7 +624,7 @@ let execute___set_unlocked_attribute
(** Set the attibute of the value as tainted *)
let execute___set_taint_attribute
({ Builtin.pdesc; args; prop_; path; })
({ Builtin.tenv; pdesc; args; prop_; path; })
: Builtin.ret_typ =
match args with
| (exp, _) :: [(Exp.Const (Const.Cstr taint_kind_str), _)] ->
@ -635,40 +633,40 @@ let execute___set_taint_attribute
| "UnverifiedSSLSocket" -> PredSymb.Tk_unverified_SSL_socket
| "SharedPreferenceData" -> PredSymb.Tk_shared_preferences_data
| other_str -> failwith ("Unrecognized taint kind " ^ other_str) in
set_attr pdesc prop_ path exp (PredSymb.Ataint { PredSymb.taint_source; taint_kind})
set_attr tenv pdesc prop_ path exp (PredSymb.Ataint { PredSymb.taint_source; taint_kind})
| _ ->
(* note: we can also get this if [taint_kind] is not a string literal *)
raise (Exceptions.Wrong_argument_number __POS__)
(** Set the attibute of the value as tainted *)
let execute___set_untaint_attribute
({ Builtin.pdesc; args; prop_; path; })
({ Builtin.tenv; pdesc; args; prop_; path; })
: Builtin.ret_typ =
match args with
| (exp, _) :: [] ->
let taint_source = Cfg.Procdesc.get_proc_name pdesc in
let taint_kind = PredSymb.Tk_unknown in (* TODO: change builtin to specify taint kind *)
set_attr pdesc prop_ path exp (PredSymb.Auntaint { PredSymb.taint_source; taint_kind})
set_attr tenv pdesc prop_ path exp (PredSymb.Auntaint { PredSymb.taint_source; taint_kind})
| _ ->
raise (Exceptions.Wrong_argument_number __POS__)
let execute___objc_cast { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute___objc_cast { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args with
| [(val1_, _); (texp2_, _)] when IList.length ret_ids <= 1 ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let val1, prop__ = check_arith_norm_exp pname val1_ prop_ in
let texp2, prop = check_arith_norm_exp pname texp2_ prop__ in
let val1, prop__ = check_arith_norm_exp tenv pname val1_ prop_ in
let texp2, prop = check_arith_norm_exp tenv pname texp2_ prop__ in
(try
let hpred = IList.find (function
| Sil.Hpointsto(e1, _, _) -> Exp.equal e1 val1
| _ -> false) prop.Prop.sigma in
match hpred, texp2 with
| Sil.Hpointsto (val1, _, _), Exp.Sizeof _ ->
let prop' = replace_ptsto_texp prop val1 texp2 in
[(return_result val1 prop' ret_ids, path)]
| _ -> [(return_result val1 prop ret_ids, path)]
with Not_found -> [(return_result val1 prop ret_ids, path)])
let prop' = replace_ptsto_texp tenv prop val1 texp2 in
[(return_result tenv val1 prop' ret_ids, path)]
| _ -> [(return_result tenv val1 prop ret_ids, path)]
with Not_found -> [(return_result tenv val1 prop ret_ids, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_abort { Builtin.proc_name; }
@ -681,10 +679,10 @@ let execute_exit { Builtin.prop_; path; }
: Builtin.ret_typ =
SymExec.diverge prop_ path
let _execute_free mk loc acc iter =
match Prop.prop_iter_current iter with
let _execute_free tenv mk loc acc iter =
match Prop.prop_iter_current tenv iter with
| (Sil.Hpointsto(lexp, _, _), []) ->
let prop = Prop.prop_iter_remove_curr_then_to_prop iter in
let prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in
let pname = PredSymb.mem_dealloc_pname mk in
let ra =
{ PredSymb.ra_kind = PredSymb.Rrelease;
@ -694,7 +692,7 @@ let _execute_free mk loc acc iter =
PredSymb.ra_vpath = None } in
(* mark value as freed *)
let p_res =
Attribute.add_or_replace_check_changed
Attribute.add_or_replace_check_changed tenv
Tabulation.check_attr_dealloc_mismatch prop (Apred (Aresource ra, [lexp])) in
p_res :: acc
| (Sil.Hpointsto _, _ :: _) -> assert false (* alignment error *)
@ -703,13 +701,13 @@ let _execute_free mk loc acc iter =
let _execute_free_nonzero mk pdesc tenv instr prop lexp typ loc =
try
begin
match Prover.is_root prop lexp lexp with
match Prover.is_root tenv prop lexp lexp with
| None ->
L.d_strln ".... Alignment Error: Freed a non root ....";
assert false
| Some _ ->
let prop_list =
IList.fold_left (_execute_free mk loc) []
IList.fold_left (_execute_free tenv mk loc) []
(Rearrange.rearrange pdesc tenv lexp typ prop loc) in
IList.rev prop_list
end
@ -728,16 +726,16 @@ let execute_free mk { Builtin.pdesc; instr; tenv; prop_; path; args; loc; }
| [(lexp, typ)] ->
begin
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let prop_nonzero = (* case n_lexp!=0 *)
Propset.to_proplist (prune ~positive:true n_lexp prop) in
Propset.to_proplist (prune tenv ~positive:true n_lexp prop) in
let prop_zero = (* case n_lexp==0 *)
Propset.to_proplist (prune ~positive:false n_lexp prop) in
Propset.to_proplist (prune tenv ~positive:false n_lexp prop) in
let plist =
prop_zero @ (* model: if 0 then skip else _execute_free_nonzero *)
IList.flatten (IList.map (fun p ->
_execute_free_nonzero mk pdesc tenv instr p
(Prop.exp_normalize_prop p lexp) typ loc) prop_nonzero) in
(Prop.exp_normalize_prop tenv p lexp) typ loc) prop_nonzero) in
IList.map (fun p -> (p, path)) plist
end
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
@ -776,17 +774,17 @@ let execute_alloc mk can_return_null
| [ret_id] -> ret_id
| _ -> Ident.create_fresh Ident.kprimed in
let size_exp', prop =
let n_size_exp, prop = check_arith_norm_exp pname size_exp prop_ in
let n_size_exp, prop = check_arith_norm_exp tenv pname size_exp prop_ in
let n_size_exp' = evaluate_char_sizeof n_size_exp in
Prop.exp_normalize_prop prop n_size_exp', prop in
Prop.exp_normalize_prop tenv prop n_size_exp', prop in
let cnt_te =
Exp.Sizeof (Typ.Tarray (Typ.Tint Typ.IChar, None), Some size_exp', Subtype.exact) in
let id_new = Ident.create_fresh Ident.kprimed in
let exp_new = Exp.Var id_new in
let ptsto_new =
Prop.mk_ptsto_exp (Some tenv) Prop.Fld_init (exp_new, cnt_te, None) Sil.Ialloc in
Prop.mk_ptsto_exp tenv Prop.Fld_init (exp_new, cnt_te, None) Sil.Ialloc in
let prop_plus_ptsto =
let prop' = Prop.normalize (Prop.prop_sigma_star prop [ptsto_new]) in
let prop' = Prop.normalize tenv (Prop.prop_sigma_star prop [ptsto_new]) in
let ra =
{ PredSymb.ra_kind = PredSymb.Racquire;
PredSymb.ra_res = PredSymb.Rmemory mk;
@ -794,10 +792,10 @@ let execute_alloc mk can_return_null
PredSymb.ra_loc = loc;
PredSymb.ra_vpath = None } in
(* mark value as allocated *)
Attribute.add_or_replace prop' (Apred (Aresource ra, [exp_new])) in
let prop_alloc = Prop.conjoin_eq (Exp.Var ret_id) exp_new prop_plus_ptsto in
Attribute.add_or_replace tenv prop' (Apred (Aresource ra, [exp_new])) in
let prop_alloc = Prop.conjoin_eq tenv (Exp.Var ret_id) exp_new prop_plus_ptsto in
if can_return_null then
let prop_null = Prop.conjoin_eq (Exp.Var ret_id) Exp.zero prop in
let prop_null = Prop.conjoin_eq tenv (Exp.Var ret_id) Exp.zero prop in
[(prop_alloc, path); (prop_null, path)]
else [(prop_alloc, path)]
@ -809,7 +807,7 @@ let execute___cxx_typeid ({ Builtin.pdesc; tenv; prop_; args; loc} as r)
match rest with
| [(field_exp, _); (lexp, typ)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp, prop = check_arith_norm_exp pname lexp prop_ in
let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in
let typ =
try
let hpred = IList.find (function
@ -826,12 +824,12 @@ let execute___cxx_typeid ({ Builtin.pdesc; tenv; prop_; args; loc} as r)
| _ -> res)
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_pthread_create ({ Builtin.prop_; path; args; } as builtin_args)
let execute_pthread_create ({ Builtin.tenv; prop_; path; args; } as builtin_args)
: Builtin.ret_typ =
match args with
| [_; _; start_routine; arg] ->
let routine_name = Prop.exp_normalize_prop prop_ (fst start_routine) in
let routine_arg = Prop.exp_normalize_prop prop_ (fst arg) in
let routine_name = Prop.exp_normalize_prop tenv prop_ (fst start_routine) in
let routine_arg = Prop.exp_normalize_prop tenv prop_ (fst arg) in
(match routine_name, (snd start_routine) with
| Exp.Lvar pvar, _ ->
let fun_name = Pvar.get_name pvar in
@ -866,39 +864,39 @@ let execute_scan_function skip_n_arguments ({ Builtin.args } as call_args)
{ call_args with args = !varargs }
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute__unwrap_exception { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute__unwrap_exception { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args with
| [(ret_exn, _)] ->
begin
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_ret_exn, prop = check_arith_norm_exp pname ret_exn prop_ in
let n_ret_exn, prop = check_arith_norm_exp tenv pname ret_exn prop_ in
match n_ret_exn with
| Exp.Exn exp ->
let prop_with_exn = return_result exp prop ret_ids in
let prop_with_exn = return_result tenv exp prop ret_ids in
[(prop_with_exn, path)]
| _ -> assert false
end
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute_return_first_argument { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute_return_first_argument { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args with
| (arg1_, _):: _ ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let arg1, prop = check_arith_norm_exp pname arg1_ prop_ in
let prop' = return_result arg1 prop ret_ids in
let arg1, prop = check_arith_norm_exp tenv pname arg1_ prop_ in
let prop' = return_result tenv arg1 prop ret_ids in
[(prop', path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
let execute___split_get_nth { Builtin.pdesc; prop_; path; ret_ids; args; }
let execute___split_get_nth { Builtin.tenv; pdesc; prop_; path; ret_ids; args; }
: Builtin.ret_typ =
match args with
| [(lexp1, _); (lexp2, _); (lexp3, _)] ->
let pname = Cfg.Procdesc.get_proc_name pdesc in
let n_lexp1, prop__ = check_arith_norm_exp pname lexp1 prop_ in
let n_lexp2, prop___ = check_arith_norm_exp pname lexp2 prop__ in
let n_lexp3, prop = check_arith_norm_exp pname lexp3 prop___ in
let n_lexp1, prop__ = check_arith_norm_exp tenv pname lexp1 prop_ in
let n_lexp2, prop___ = check_arith_norm_exp tenv pname lexp2 prop__ in
let n_lexp3, prop = check_arith_norm_exp tenv pname lexp3 prop___ in
(match n_lexp1, n_lexp2, n_lexp3 with
| Exp.Const (Const.Cstr str1), Exp.Const (Const.Cstr str2), Exp.Const (Const.Cint n_sil) ->
(let n = IntLit.to_int n_sil in
@ -906,19 +904,19 @@ let execute___split_get_nth { Builtin.pdesc; prop_; path; ret_ids; args; }
let parts = Str.split (Str.regexp_string str2) str1 in
let n_part = IList.nth parts n in
let res = Exp.Const (Const.Cstr n_part) in
[(return_result res prop ret_ids, path)]
[(return_result tenv res prop ret_ids, path)]
with Not_found -> assert false)
| _ -> [(prop, path)])
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
(* forces the expression passed as parameter to be assumed true at the point where this
builtin is called, diverges if this causes an inconsistency *)
let execute___infer_assume { Builtin.prop_; path; args; }
let execute___infer_assume { Builtin.tenv; prop_; path; args; }
: Builtin.ret_typ =
match args with
| [(lexp, _)] ->
let prop_assume = Prop.conjoin_eq lexp (Exp.bool true) prop_ in
if Prover.check_inconsistency prop_assume
let prop_assume = Prop.conjoin_eq tenv lexp (Exp.bool true) prop_ in
if Prover.check_inconsistency tenv prop_assume
then SymExec.diverge prop_assume path
else [(prop_assume, path)]
| _ -> raise (Exceptions.Wrong_argument_number __POS__)
@ -930,7 +928,7 @@ let execute___infer_fail { Builtin.pdesc; tenv; prop_; path; args; loc; }
match args with
| [(lexp_msg, _)] ->
begin
match Prop.exp_normalize_prop prop_ lexp_msg with
match Prop.exp_normalize_prop tenv prop_ lexp_msg with
| Exp.Const (Const.Cstr str) -> str
| _ -> assert false
end

@ -113,7 +113,7 @@ let restore_global_state st =
Timeout.resume_previous_timeout ()
let run_proc_analysis ~propagate_exceptions analyze_proc curr_pdesc callee_pdesc =
let run_proc_analysis tenv ~propagate_exceptions analyze_proc curr_pdesc callee_pdesc =
let curr_pname = Cfg.Procdesc.get_proc_name curr_pdesc in
let callee_pname = Cfg.Procdesc.get_proc_name callee_pdesc in
@ -151,7 +151,7 @@ let run_proc_analysis ~propagate_exceptions analyze_proc curr_pdesc callee_pdesc
Specs.status = Specs.INACTIVE;
timestamp = summary.Specs.timestamp + 1 } in
Specs.add_summary callee_pname summary';
Checkers.ST.store_summary callee_pname;
Checkers.ST.store_summary tenv callee_pname;
Printer.write_proc_html false callee_pdesc in
let log_error_and_continue exn kind =
@ -192,13 +192,13 @@ let run_proc_analysis ~propagate_exceptions analyze_proc curr_pdesc callee_pdesc
log_error_and_continue exn (FKcrash (Printexc.to_string exn))
let analyze_proc_desc ~propagate_exceptions curr_pdesc callee_pdesc =
let analyze_proc_desc tenv ~propagate_exceptions curr_pdesc callee_pdesc =
let callee_pname = Cfg.Procdesc.get_proc_name callee_pdesc in
let proc_attributes = Cfg.Procdesc.get_attributes callee_pdesc in
match !callbacks_ref with
| Some callbacks
when should_be_analyzed proc_attributes callee_pname ->
run_proc_analysis
run_proc_analysis tenv
~propagate_exceptions callbacks.analyze_ondemand curr_pdesc callee_pdesc
| _ -> ()
@ -207,7 +207,7 @@ let analyze_proc_desc ~propagate_exceptions curr_pdesc callee_pdesc =
(** analyze_proc_name curr_pdesc proc_name
performs an on-demand analysis of proc_name
triggered during the analysis of curr_pname. *)
let analyze_proc_name ~propagate_exceptions curr_pdesc callee_pname =
let analyze_proc_name tenv ~propagate_exceptions curr_pdesc callee_pname =
match !callbacks_ref with
| Some callbacks
@ -215,7 +215,7 @@ let analyze_proc_name ~propagate_exceptions curr_pdesc callee_pname =
begin
match callbacks.get_proc_desc callee_pname with
| Some callee_pdesc ->
analyze_proc_desc ~propagate_exceptions curr_pdesc callee_pdesc
analyze_proc_desc tenv ~propagate_exceptions curr_pdesc callee_pdesc
| None ->
()
end

@ -30,12 +30,12 @@ val get_proc_desc : get_proc_desc
(** analyze_proc_desc curr_pdesc callee_pdesc
performs an on-demand analysis of callee_pdesc
triggered during the analysis of curr_pdesc. *)
val analyze_proc_desc : propagate_exceptions:bool -> Cfg.Procdesc.t -> Cfg.Procdesc.t -> unit
val analyze_proc_desc : Tenv.t -> propagate_exceptions:bool -> Cfg.Procdesc.t -> Cfg.Procdesc.t -> unit
(** analyze_proc_name curr_pdesc proc_name
performs an on-demand analysis of proc_name
triggered during the analysis of curr_pdesc. *)
val analyze_proc_name : propagate_exceptions:bool -> Cfg.Procdesc.t -> Procname.t -> unit
val analyze_proc_name : Tenv.t -> propagate_exceptions:bool -> Cfg.Procdesc.t -> Procname.t -> unit
(** Check if the procedure called needs to be analyzed. *)
val procedure_should_be_analyzed : Procname.t -> bool

@ -590,7 +590,7 @@ module PathSet : sig
val to_proplist : t -> Prop.normal Prop.t list
(** convert to a set of props *)
val to_propset : t -> Propset.t
val to_propset : Tenv.t -> t -> Propset.t
(** union of two pathsets *)
val union : t -> t -> t
@ -610,8 +610,8 @@ end = struct
let to_proplist ps =
IList.map fst (elements ps)
let to_propset ps =
Propset.from_proplist (to_proplist ps)
let to_propset tenv ps =
Propset.from_proplist tenv (to_proplist ps)
let filter f ps =
let elements = ref [] in

@ -125,7 +125,7 @@ module PathSet : sig
val to_proplist : t -> Prop.normal Prop.t list
(** convert to a set of props *)
val to_propset : t -> Propset.t
val to_propset : Tenv.t -> t -> Propset.t
(** union of two pathsets *)
val union : t -> t -> t

@ -488,7 +488,7 @@ let atom_const_lt_exp (atom : Sil.atom) = match atom with
let exp_reorder e1 e2 = if Exp.compare e1 e2 <= 0 then (e1, e2) else (e2, e1)
(** create a strexp of the given type, populating the structures if [expand_structs] is true *)
let rec create_strexp_of_type tenvo struct_init_mode (typ : Typ.t) len inst : Sil.strexp =
let rec create_strexp_of_type tenv struct_init_mode (typ : Typ.t) len inst : Sil.strexp =
let init_value () =
let create_fresh_var () =
let fresh_id =
@ -515,7 +515,7 @@ let rec create_strexp_of_type tenvo struct_init_mode (typ : Typ.t) len inst : Si
if Typ.is_objc_ref_counter_field (fld, t, a) then
((fld, Sil.Eexp (Exp.one, inst)) :: flds, None)
else
((fld, create_strexp_of_type tenvo struct_init_mode t len inst) :: flds, None) in
((fld, create_strexp_of_type tenv struct_init_mode t len inst) :: flds, None) in
let flds, _ = IList.fold_right f instance_fields ([], len) in
Estruct (flds, inst)
)
@ -570,7 +570,7 @@ let sigma_get_unsigned_exps sigma =
(** Collapse consecutive indices that should be added. For instance,
this function reduces x[1][1] to x[2]. The [typ] argument is used
to ensure the soundness of this collapsing. *)
let exp_collapse_consecutive_indices_prop (typ : Typ.t) exp =
let exp_collapse_consecutive_indices_prop _tenv (typ : Typ.t) exp =
let typ_is_base (typ1 : Typ.t) = match typ1 with
| Tint _ | Tfloat _ | Tstruct _ | Tvoid | Tfun _ ->
true
@ -720,7 +720,7 @@ module Normalize = struct
let (--) = IntLit.sub
let (++) = IntLit.add
let sym_eval abs e =
let sym_eval _tenv abs e =
let rec eval (e : Exp.t) : Exp.t =
(* L.d_str " ["; Sil.d_exp e; L.d_str"] "; *)
match e with
@ -1114,26 +1114,26 @@ module Normalize = struct
(* L.d_str "sym_eval "; Sil.d_exp e; L.d_str" --> "; Sil.d_exp e'; L.d_ln (); *)
e'
let exp_normalize sub exp =
let exp_normalize tenv sub exp =
let exp' = Sil.exp_sub sub exp in
if !Config.abs_val >= 1 then sym_eval true exp'
else sym_eval false exp'
if !Config.abs_val >= 1 then sym_eval tenv true exp'
else sym_eval tenv false exp'
let texp_normalize sub (exp : Exp.t) : Exp.t = match exp with
let texp_normalize tenv sub (exp : Exp.t) : Exp.t = match exp with
| Sizeof (typ, len, st) ->
Sizeof (typ, Option.map (exp_normalize sub) len, st)
Sizeof (typ, Option.map (exp_normalize tenv sub) len, st)
| _ ->
exp_normalize sub exp
exp_normalize tenv sub exp
let exp_normalize_noabs sub exp =
Config.run_with_abs_val_equal_zero (exp_normalize sub) exp
let exp_normalize_noabs tenv sub exp =
Config.run_with_abs_val_equal_zero (exp_normalize tenv sub) exp
(** Turn an inequality expression into an atom *)
let mk_inequality (e : Exp.t) : Sil.atom =
let mk_inequality tenv (e : Exp.t) : Sil.atom =
match e with
| BinOp (Le, base, Const (Cint n)) ->
(* base <= n case *)
let nbase = exp_normalize_noabs Sil.sub_empty base in
let nbase = exp_normalize_noabs tenv Sil.sub_empty base in
(match nbase with
| BinOp(PlusA, base', Const (Cint n')) ->
let new_offset = Exp.int (n -- n') in
@ -1160,7 +1160,7 @@ module Normalize = struct
Aeq (e, Exp.one))
| BinOp (Lt, Const (Cint n), base) ->
(* n < base case *)
let nbase = exp_normalize_noabs Sil.sub_empty base in
let nbase = exp_normalize_noabs tenv Sil.sub_empty base in
(match nbase with
| BinOp(PlusA, base', Const (Cint n')) ->
let new_offset = Exp.int (n -- n') in
@ -1189,7 +1189,7 @@ module Normalize = struct
Aeq (e, Exp.one)
(** Normalize an inequality *)
let inequality_normalize (a : Sil.atom) =
let inequality_normalize tenv (a : Sil.atom) =
(* turn an expression into a triple (pos,neg,off) of positive and negative occurrences, and
integer offset representing inequality [sum(pos) - sum(neg) + off <= 0] *)
let rec exp_to_posnegoff (e : Exp.t) = match e with
@ -1245,16 +1245,16 @@ module Normalize = struct
match ineq with
| BinOp(Le, e1, e2) ->
let e : Exp.t = BinOp(MinusA, e1, e2) in
mk_inequality (norm_from_exp e)
mk_inequality tenv (norm_from_exp e)
| BinOp(Lt, e1, e2) ->
let e : Exp.t = BinOp(MinusA, BinOp(MinusA, e1, e2), Exp.minus_one) in
mk_inequality (norm_from_exp e)
mk_inequality tenv (norm_from_exp e)
| _ -> a
(** Normalize an atom.
We keep the convention that inequalities with constants
are only of the form [e <= n] and [n < e]. *)
let atom_normalize sub a0 =
let atom_normalize tenv sub a0 =
let a = Sil.atom_sub sub a0 in
let rec normalize_eq (eq : Exp.t * Exp.t) = match eq with
| BinOp(PlusA, e1, Const (Cint n1)), Const (Cint n2)
@ -1284,8 +1284,8 @@ module Normalize = struct
(e1', Exp.zero, true)
| _ -> (e1, e2, false) in
let handle_boolean_operation from_equality e1 e2 : Sil.atom =
let ne1 = exp_normalize sub e1 in
let ne2 = exp_normalize sub e2 in
let ne1 = exp_normalize tenv sub e1 in
let ne2 = exp_normalize tenv sub e2 in
let ne1', ne2', op_negated = handle_unary_negation ne1 ne2 in
let (e1', e2') = normalize_eq (ne1', ne2') in
let (e1'', e2'') = exp_reorder e1' e2' in
@ -1301,13 +1301,13 @@ module Normalize = struct
| Aneq (e1, e2) ->
handle_boolean_operation false e1 e2
| Apred (a, es) ->
Apred (a, IList.map (fun e -> exp_normalize sub e) es)
Apred (a, IList.map (fun e -> exp_normalize tenv sub e) es)
| Anpred (a, es) ->
Anpred (a, IList.map (fun e -> exp_normalize sub e) es) in
if atom_is_inequality a' then inequality_normalize a' else a'
Anpred (a, IList.map (fun e -> exp_normalize tenv sub e) es) in
if atom_is_inequality a' then inequality_normalize tenv a' else a'
let normalize_and_strengthen_atom (p : normal t) (a : Sil.atom) : Sil.atom =
let a' = atom_normalize p.sub a in
let normalize_and_strengthen_atom tenv (p : normal t) (a : Sil.atom) : Sil.atom =
let a' = atom_normalize tenv p.sub a in
match a' with
| Aeq (BinOp (Le, Var id, Const (Cint n)), Const (Cint i))
when IntLit.isone i ->
@ -1325,10 +1325,10 @@ module Normalize = struct
Aneq (e1, e2)
| _ -> a'
let rec strexp_normalize sub (se : Sil.strexp) : Sil.strexp =
let rec strexp_normalize tenv sub (se : Sil.strexp) : Sil.strexp =
match se with
| Eexp (e, inst) ->
Eexp (exp_normalize sub e, inst)
Eexp (exp_normalize tenv sub e, inst)
| Estruct (fld_cnts, inst) ->
begin
match fld_cnts with
@ -1336,39 +1336,39 @@ module Normalize = struct
| _ ->
let fld_cnts' =
IList.map (fun (fld, cnt) ->
fld, strexp_normalize sub cnt) fld_cnts in
fld, strexp_normalize tenv sub cnt) fld_cnts in
let fld_cnts'' = IList.sort Sil.fld_strexp_compare fld_cnts' in
Estruct (fld_cnts'', inst)
end
| Earray (len, idx_cnts, inst) ->
begin
let len' = exp_normalize_noabs sub len in
let len' = exp_normalize_noabs tenv sub len in
match idx_cnts with
| [] ->
if Exp.equal len len' then se else Earray (len', idx_cnts, inst)
| _ ->
let idx_cnts' =
IList.map (fun (idx, cnt) ->
let idx' = exp_normalize sub idx in
idx', strexp_normalize sub cnt) idx_cnts in
let idx' = exp_normalize tenv sub idx in
idx', strexp_normalize tenv sub cnt) idx_cnts in
let idx_cnts'' =
IList.sort Sil.exp_strexp_compare idx_cnts' in
Earray (len', idx_cnts'', inst)
end
(** Exp.Construct a pointsto. *)
let mk_ptsto lexp sexp te : Sil.hpred =
let nsexp = strexp_normalize Sil.sub_empty sexp in
let mk_ptsto tenv lexp sexp te : Sil.hpred =
let nsexp = strexp_normalize tenv Sil.sub_empty sexp in
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. *)
let mk_ptsto_exp tenvo struct_init_mode (exp, (te : Exp.t), expo) inst : Sil.hpred =
let mk_ptsto_exp tenv struct_init_mode (exp, (te : Exp.t), expo) inst : Sil.hpred =
let default_strexp () : Sil.strexp = match te with
| Sizeof (typ, len, _) ->
create_strexp_of_type tenvo struct_init_mode typ len inst
create_strexp_of_type tenv struct_init_mode typ len inst
| Var _ ->
Estruct ([], inst)
| te ->
@ -1377,9 +1377,9 @@ module Normalize = struct
let strexp : Sil.strexp = match expo with
| Some e -> Eexp (e, inst)
| None -> default_strexp () in
mk_ptsto exp strexp te
mk_ptsto tenv exp strexp te
let rec hpred_normalize sub (hpred : Sil.hpred) : Sil.hpred =
let rec hpred_normalize tenv sub (hpred : Sil.hpred) : Sil.hpred =
let replace_hpred hpred' =
L.d_strln "found array with sizeof(..) size";
L.d_str "converting original hpred: "; Sil.d_hpred hpred; L.d_ln ();
@ -1387,14 +1387,14 @@ module Normalize = struct
hpred' in
match hpred with
| Hpointsto (root, cnt, te) ->
let normalized_root = exp_normalize sub root in
let normalized_cnt = strexp_normalize sub cnt in
let normalized_te = texp_normalize sub te in
let normalized_root = exp_normalize tenv sub root in
let normalized_cnt = strexp_normalize tenv sub cnt in
let normalized_te = texp_normalize tenv sub te in
begin match normalized_cnt, normalized_te with
| Earray (Exp.Sizeof _ as size, [], inst), Sizeof (Tarray _, _, _) ->
(* check for an empty array whose size expression is (Sizeof type), and turn the array
into a strexp of the given type *)
let hpred' = mk_ptsto_exp None Fld_init (root, size, None) inst in
let hpred' = mk_ptsto_exp tenv Fld_init (root, size, None) inst in
replace_hpred hpred'
| (Earray (BinOp (Mult, Sizeof (t, None, st1), x), esel, inst)
| Earray (BinOp (Mult, x, Sizeof (t, None, st1)), esel, inst)),
@ -1402,7 +1402,7 @@ module Normalize = struct
when Typ.equal t elt ->
let len = Some x in
let hpred' =
mk_ptsto_exp None Fld_init (root, Sizeof (arr, len, st1), None) inst in
mk_ptsto_exp tenv Fld_init (root, Sizeof (arr, len, st1), None) inst in
replace_hpred (replace_array_contents hpred' esel)
| ( Earray (BinOp (Mult, Sizeof (t, Some len, st1), x), esel, inst)
| Earray (BinOp (Mult, x, Sizeof (t, Some len, st1)), esel, inst)),
@ -1410,43 +1410,43 @@ module Normalize = struct
when Typ.equal t elt ->
let len = Some (Exp.BinOp(Mult, x, len)) in
let hpred' =
mk_ptsto_exp None Fld_init (root, Sizeof (arr, len, st1), None) inst in
mk_ptsto_exp tenv Fld_init (root, Sizeof (arr, len, st1), None) inst in
replace_hpred (replace_array_contents hpred' esel)
| _ ->
Hpointsto (normalized_root, normalized_cnt, normalized_te)
end
| Hlseg (k, para, e1, e2, elist) ->
let normalized_e1 = exp_normalize sub e1 in
let normalized_e2 = exp_normalize sub e2 in
let normalized_elist = IList.map (exp_normalize sub) elist in
let normalized_para = hpara_normalize para in
let normalized_e1 = exp_normalize tenv sub e1 in
let normalized_e2 = exp_normalize tenv sub e2 in
let normalized_elist = IList.map (exp_normalize tenv sub) elist in
let normalized_para = hpara_normalize tenv para in
Hlseg (k, normalized_para, normalized_e1, normalized_e2, normalized_elist)
| Hdllseg (k, para, e1, e2, e3, e4, elist) ->
let norm_e1 = exp_normalize sub e1 in
let norm_e2 = exp_normalize sub e2 in
let norm_e3 = exp_normalize sub e3 in
let norm_e4 = exp_normalize sub e4 in
let norm_elist = IList.map (exp_normalize sub) elist in
let norm_para = hpara_dll_normalize para in
let norm_e1 = exp_normalize tenv sub e1 in
let norm_e2 = exp_normalize tenv sub e2 in
let norm_e3 = exp_normalize tenv sub e3 in
let norm_e4 = exp_normalize tenv sub e4 in
let norm_elist = IList.map (exp_normalize tenv sub) elist in
let norm_para = hpara_dll_normalize tenv para in
Hdllseg (k, norm_para, norm_e1, norm_e2, norm_e3, norm_e4, norm_elist)
and hpara_normalize (para : Sil.hpara) =
let normalized_body = IList.map (hpred_normalize Sil.sub_empty) (para.body) in
and hpara_normalize tenv (para : Sil.hpara) =
let normalized_body = IList.map (hpred_normalize tenv Sil.sub_empty) (para.body) in
let sorted_body = IList.sort Sil.hpred_compare normalized_body in
{ para with body = sorted_body }
and hpara_dll_normalize (para : Sil.hpara_dll) =
let normalized_body = IList.map (hpred_normalize Sil.sub_empty) (para.body_dll) in
and hpara_dll_normalize tenv (para : Sil.hpara_dll) =
let normalized_body = IList.map (hpred_normalize tenv Sil.sub_empty) (para.body_dll) in
let sorted_body = IList.sort Sil.hpred_compare normalized_body in
{ para with body_dll = sorted_body }
let sigma_normalize sub sigma =
let sigma_normalize tenv sub sigma =
let sigma' =
IList.stable_sort Sil.hpred_compare (IList.map (hpred_normalize sub) sigma) in
IList.stable_sort Sil.hpred_compare (IList.map (hpred_normalize tenv sub) sigma) in
if sigma_equal sigma sigma' then sigma else sigma'
let pi_tighten_ineq pi =
let pi_tighten_ineq tenv pi =
let ineq_list, nonineq_list = IList.partition atom_is_inequality pi in
let diseq_list =
let get_disequality_info acc (a : Sil.atom) = match a with
@ -1485,11 +1485,11 @@ module Normalize = struct
let ineq_list' =
let le_ineq_list =
IList.map
(fun (e, n) -> mk_inequality (BinOp(Le, e, Exp.int n)))
(fun (e, n) -> mk_inequality tenv (BinOp(Le, e, Exp.int n)))
le_list_tightened in
let lt_ineq_list =
IList.map
(fun (n, e) -> mk_inequality (BinOp(Lt, Exp.int n, e)))
(fun (n, e) -> mk_inequality tenv (BinOp(Lt, Exp.int n, e)))
lt_list_tightened in
le_ineq_list @ lt_ineq_list in
let nonineq_list' =
@ -1509,9 +1509,9 @@ module Normalize = struct
(** Normalization of pi.
The normalization filters out obviously - true disequalities, such as e <> e + 1. *)
let pi_normalize sub sigma pi0 =
let pi = IList.map (atom_normalize sub) pi0 in
let ineq_list, nonineq_list = pi_tighten_ineq pi in
let pi_normalize tenv sub sigma pi0 =
let pi = IList.map (atom_normalize tenv sub) pi0 in
let ineq_list, nonineq_list = pi_tighten_ineq tenv pi in
let syntactically_different : Exp.t * Exp.t -> bool = function
| BinOp(op1, e1, Const c1), BinOp(op2, e2, Const c2)
when Exp.equal e1 e2 ->
@ -1546,9 +1546,9 @@ module Normalize = struct
(** normalize the footprint part, and rename any primed vars
in the footprint with fresh footprint vars *)
let footprint_normalize prop =
let nsigma = sigma_normalize Sil.sub_empty prop.sigma_fp in
let npi = pi_normalize Sil.sub_empty nsigma prop.pi_fp in
let footprint_normalize tenv prop =
let nsigma = sigma_normalize tenv Sil.sub_empty prop.sigma_fp in
let npi = pi_normalize tenv Sil.sub_empty nsigma prop.pi_fp in
let fp_vars =
let fav = pi_fav npi in
sigma_fav_add fav nsigma;
@ -1570,8 +1570,8 @@ module Normalize = struct
IList.map (fun id -> (id, Ident.create_fresh Ident.kfootprint)) ids_primed in
let ren_sub =
Sil.sub_of_list (IList.map (fun (id1, id2) -> (id1, Exp.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
let nsigma' = sigma_normalize tenv Sil.sub_empty (sigma_sub ren_sub nsigma) in
let npi' = pi_normalize tenv Sil.sub_empty nsigma' (pi_sub ren_sub npi) in
(npi', nsigma') in
set prop ~pi_fp:npi' ~sigma_fp:nsigma'
@ -1582,8 +1582,8 @@ module Normalize = struct
if Sil.sub_equal sub sub' then sub else sub'
(** Conjoin a pure atomic predicate by normal conjunction. *)
let rec prop_atom_and ?(footprint=false) (p : normal t) a : normal t =
let a' = normalize_and_strengthen_atom p a in
let rec prop_atom_and tenv ?(footprint=false) (p : normal t) a : normal t =
let a' = normalize_and_strengthen_atom tenv p a in
if IList.mem Sil.atom_equal a' p.pi then p
else begin
let p' =
@ -1595,22 +1595,22 @@ module Normalize = struct
let p_sub = Sil.sub_filter (fun i' -> not (Ident.equal i i')) p.sub in
let sub' = Sil.sub_join mysub (Sil.sub_range_map (Sil.exp_sub mysub) p_sub) in
let (nsub', npi', nsigma') =
let nsigma' = sigma_normalize sub' p.sigma in
(sub_normalize sub', pi_normalize sub' nsigma' p.pi, nsigma') in
let nsigma' = sigma_normalize tenv sub' p.sigma in
(sub_normalize sub', pi_normalize tenv sub' nsigma' p.pi, nsigma') in
let (eqs_zero, nsigma'') = sigma_remove_emptylseg nsigma' in
let p' =
unsafe_cast_to_normal
(set p ~sub:nsub' ~pi:npi' ~sigma:nsigma'') in
IList.fold_left (prop_atom_and ~footprint) p' eqs_zero
IList.fold_left (prop_atom_and tenv ~footprint) p' eqs_zero
| Aeq (e1, e2) when (Exp.compare e1 e2 = 0) ->
p
| Aneq (e1, e2) ->
let sigma' = sigma_intro_nonemptylseg e1 e2 p.sigma in
let pi' = pi_normalize p.sub sigma' (a':: p.pi) in
let pi' = pi_normalize tenv p.sub sigma' (a':: p.pi) in
unsafe_cast_to_normal
(set p ~pi:pi' ~sigma:sigma')
| _ ->
let pi' = pi_normalize p.sub p.sigma (a':: p.pi) in
let pi' = pi_normalize tenv p.sub p.sigma (a':: p.pi) in
unsafe_cast_to_normal
(set p ~pi:pi') in
if not footprint then p'
@ -1621,17 +1621,17 @@ module Normalize = struct
let predicate_warning =
not (Sil.fav_is_empty fav_nofootprint_a') in
let p'' =
if predicate_warning then footprint_normalize p'
if predicate_warning then footprint_normalize tenv p'
else
match a' with
| Aeq (Exp.Var i, e) when not (Sil.ident_in_exp i e) ->
let mysub = Sil.sub_of_list [(i, e)] in
let sigma_fp' = sigma_normalize mysub p'.sigma_fp in
let pi_fp' = a' :: pi_normalize mysub sigma_fp' p'.pi_fp in
footprint_normalize
let sigma_fp' = sigma_normalize tenv mysub p'.sigma_fp in
let pi_fp' = a' :: pi_normalize tenv mysub sigma_fp' p'.pi_fp in
footprint_normalize tenv
(set p' ~pi_fp:pi_fp' ~sigma_fp:sigma_fp')
| _ ->
footprint_normalize
footprint_normalize tenv
(set p' ~pi_fp:(a' :: p'.pi_fp)) in
if predicate_warning then (L.d_warning "dropping non-footprint "; Sil.d_atom a'; L.d_ln ());
unsafe_cast_to_normal p''
@ -1639,90 +1639,90 @@ module Normalize = struct
end
(** normalize a prop *)
let normalize (eprop : 'a t) : normal t =
let normalize tenv (eprop : 'a t) : normal t =
let p0 =
unsafe_cast_to_normal
(set prop_emp ~sigma: (sigma_normalize Sil.sub_empty eprop.sigma)) in
let nprop = IList.fold_left prop_atom_and p0 (get_pure eprop) in
(set prop_emp ~sigma: (sigma_normalize tenv Sil.sub_empty eprop.sigma)) in
let nprop = IList.fold_left (prop_atom_and tenv) p0 (get_pure eprop) in
unsafe_cast_to_normal
(footprint_normalize (set nprop ~pi_fp:eprop.pi_fp ~sigma_fp:eprop.sigma_fp))
(footprint_normalize tenv (set nprop ~pi_fp:eprop.pi_fp ~sigma_fp:eprop.sigma_fp))
end
(* End of module Normalize *)
let exp_normalize_prop prop exp =
Config.run_with_abs_val_equal_zero (Normalize.exp_normalize prop.sub) exp
let exp_normalize_prop tenv prop exp =
Config.run_with_abs_val_equal_zero (Normalize.exp_normalize tenv prop.sub) exp
let lexp_normalize_prop p lexp =
let lexp_normalize_prop tenv p lexp =
let root = Exp.root_of_lexp lexp in
let offsets = Sil.exp_get_offsets lexp in
let nroot = exp_normalize_prop p root in
let nroot = exp_normalize_prop tenv p root in
let noffsets =
IList.map (fun (n : Sil.offset) -> match n with
| Off_fld _ ->
n
| Off_index e ->
Sil.Off_index (exp_normalize_prop p e)
Sil.Off_index (exp_normalize_prop tenv p e)
) offsets in
Sil.exp_add_offsets nroot noffsets
let atom_normalize_prop prop atom =
Config.run_with_abs_val_equal_zero (Normalize.atom_normalize prop.sub) atom
let atom_normalize_prop tenv prop atom =
Config.run_with_abs_val_equal_zero (Normalize.atom_normalize tenv prop.sub) atom
let strexp_normalize_prop prop strexp =
Config.run_with_abs_val_equal_zero (Normalize.strexp_normalize prop.sub) strexp
let strexp_normalize_prop tenv prop strexp =
Config.run_with_abs_val_equal_zero (Normalize.strexp_normalize tenv prop.sub) strexp
let hpred_normalize_prop prop hpred =
Config.run_with_abs_val_equal_zero (Normalize.hpred_normalize prop.sub) hpred
let hpred_normalize_prop tenv prop hpred =
Config.run_with_abs_val_equal_zero (Normalize.hpred_normalize tenv prop.sub) hpred
let sigma_normalize_prop prop sigma =
Config.run_with_abs_val_equal_zero (Normalize.sigma_normalize prop.sub) sigma
let sigma_normalize_prop tenv prop sigma =
Config.run_with_abs_val_equal_zero (Normalize.sigma_normalize tenv prop.sub) sigma
let pi_normalize_prop prop pi =
Config.run_with_abs_val_equal_zero (Normalize.pi_normalize prop.sub prop.sigma) pi
let pi_normalize_prop tenv prop pi =
Config.run_with_abs_val_equal_zero (Normalize.pi_normalize tenv prop.sub prop.sigma) pi
let sigma_replace_exp epairs sigma =
let sigma_replace_exp tenv epairs sigma =
let sigma' = IList.map (Sil.hpred_replace_exp epairs) sigma in
Normalize.sigma_normalize Sil.sub_empty sigma'
Normalize.sigma_normalize tenv Sil.sub_empty sigma'
(** Construct an atom. *)
let mk_atom atom =
Config.run_with_abs_val_equal_zero (fun () -> Normalize.atom_normalize Sil.sub_empty atom) ()
let mk_atom tenv atom =
Config.run_with_abs_val_equal_zero (fun () -> Normalize.atom_normalize tenv Sil.sub_empty atom) ()
(** Exp.Construct a disequality. *)
let mk_neq e1 e2 = mk_atom (Aneq (e1, e2))
let mk_neq tenv e1 e2 = mk_atom tenv (Aneq (e1, e2))
(** Exp.Construct an equality. *)
let mk_eq e1 e2 = mk_atom (Aeq (e1, e2))
let mk_eq tenv e1 e2 = mk_atom tenv (Aeq (e1, e2))
(** Construct a pred. *)
let mk_pred a es = mk_atom (Apred (a, es))
let mk_pred tenv a es = mk_atom tenv (Apred (a, es))
(** Construct a negated pred. *)
let mk_npred a es = mk_atom (Anpred (a, es))
let mk_npred tenv a es = mk_atom tenv (Anpred (a, es))
(** Exp.Construct a lseg predicate *)
let mk_lseg k para e_start e_end es_shared : Sil.hpred =
let npara = Normalize.hpara_normalize para in
let mk_lseg tenv k para e_start e_end es_shared : Sil.hpred =
let npara = Normalize.hpara_normalize tenv para in
Hlseg (k, npara, e_start, e_end, es_shared)
(** Exp.Construct a dllseg predicate *)
let mk_dllseg k para exp_iF exp_oB exp_oF exp_iB exps_shared : Sil.hpred =
let npara = Normalize.hpara_dll_normalize para in
let mk_dllseg tenv k para exp_iF exp_oB exp_oF exp_iB exps_shared : Sil.hpred =
let npara = Normalize.hpara_dll_normalize tenv para in
Hdllseg (k, npara, exp_iF, exp_oB , exp_oF, exp_iB, exps_shared)
(** Exp.Construct a hpara *)
let mk_hpara root next svars evars body =
let mk_hpara tenv root next svars evars body =
let para =
{ Sil.root = root;
next = next;
svars = svars;
evars = evars;
body = body } in
Normalize.hpara_normalize para
Normalize.hpara_normalize tenv para
(** Exp.Construct a dll_hpara *)
let mk_dll_hpara iF oB oF svars evars body =
let mk_dll_hpara tenv iF oB oF svars evars body =
let para =
{ Sil.cell = iF;
blink = oB;
@ -1730,7 +1730,7 @@ let mk_dll_hpara iF oB oF svars evars body =
svars_dll = svars;
evars_dll = evars;
body_dll = body } in
Normalize.hpara_dll_normalize para
Normalize.hpara_dll_normalize tenv para
(** Construct a points-to predicate for a single program variable.
If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
@ -1738,12 +1738,12 @@ let mk_ptsto_lvar tenv expand_structs inst ((pvar: Pvar.t), texp, expo) : Sil.hp
Normalize.mk_ptsto_exp tenv expand_structs (Lvar pvar, texp, expo) inst
(** Conjoin [exp1]=[exp2] with a symbolic heap [prop]. *)
let conjoin_eq ?(footprint = false) exp1 exp2 prop =
Normalize.prop_atom_and ~footprint prop (Aeq(exp1, exp2))
let conjoin_eq tenv ?(footprint = false) exp1 exp2 prop =
Normalize.prop_atom_and tenv ~footprint prop (Aeq(exp1, exp2))
(** Conjoin [exp1!=exp2] with a symbolic heap [prop]. *)
let conjoin_neq ?(footprint = false) exp1 exp2 prop =
Normalize.prop_atom_and ~footprint prop (Aneq (exp1, exp2))
let conjoin_neq tenv ?(footprint = false) exp1 exp2 prop =
Normalize.prop_atom_and tenv ~footprint prop (Aneq (exp1, exp2))
(** Reset every inst in the prop using the given map *)
let prop_reset_inst inst_map prop =
@ -1801,7 +1801,7 @@ let sigma_get_start_lexps_sort sigma =
let lexps = Sil.hpred_list_get_lexps filter sigma in
IList.sort exp_compare_neg lexps
let sigma_dfs_sort sigma =
let sigma_dfs_sort tenv sigma =
let init () =
let start_lexps = sigma_get_start_lexps_sort sigma in
@ -1840,7 +1840,7 @@ let sigma_dfs_sort sigma =
| [] -> IList.rev visited
| cur ->
if ExpStack.is_empty () then
let cur' = Normalize.sigma_normalize Sil.sub_empty cur in
let cur' = Normalize.sigma_normalize tenv Sil.sub_empty cur in
IList.rev_append cur' visited
else
let e = ExpStack.pop () in
@ -1852,17 +1852,17 @@ let sigma_dfs_sort sigma =
final ();
sigma'
let prop_dfs_sort p =
let prop_dfs_sort tenv p =
let sigma = p.sigma in
let sigma' = sigma_dfs_sort sigma in
let sigma' = sigma_dfs_sort tenv sigma in
let sigma_fp = p.sigma_fp in
let sigma_fp' = sigma_dfs_sort sigma_fp in
let sigma_fp' = sigma_dfs_sort tenv sigma_fp in
let p' = set p ~sigma:sigma' ~sigma_fp:sigma_fp' in
(* L.err "@[<2>P SORTED:@\n%a@\n@." pp_prop p'; *)
p'
let prop_fav_add_dfs fav prop =
prop_fav_add fav (prop_dfs_sort prop)
let prop_fav_add_dfs tenv fav prop =
prop_fav_add fav (prop_dfs_sort tenv prop)
let rec strexp_get_array_indices acc (se : Sil.strexp) = match se with
| Eexp _ ->
@ -1919,9 +1919,9 @@ let compute_reindexing_from_indices indices =
let fav_add = Sil.exp_fav_add in
compute_reindexing fav_add get_id_offset indices
let apply_reindexing subst prop =
let nsigma = Normalize.sigma_normalize subst prop.sigma in
let npi = Normalize.pi_normalize subst nsigma prop.pi in
let apply_reindexing tenv subst prop =
let nsigma = Normalize.sigma_normalize tenv subst prop.sigma in
let npi = Normalize.pi_normalize tenv subst nsigma prop.pi in
let nsub, atoms =
let dom_subst = IList.map fst (Sil.sub_to_list subst) in
let in_dom_subst id = IList.exists (Ident.equal id) dom_subst in
@ -1931,15 +1931,15 @@ let apply_reindexing subst prop =
let eqs = Sil.sub_to_list sub_eqs in
let atoms =
IList.map
(fun (id, e) -> Sil.Aeq (Var id, Normalize.exp_normalize subst e))
(fun (id, e) -> Sil.Aeq (Var id, Normalize.exp_normalize tenv subst e))
eqs in
(sub_keep, atoms) in
let p' =
unsafe_cast_to_normal
(set prop ~sub:nsub ~pi:npi ~sigma:nsigma) in
IList.fold_left Normalize.prop_atom_and p' atoms
IList.fold_left (Normalize.prop_atom_and tenv) p' atoms
let prop_rename_array_indices prop =
let prop_rename_array_indices tenv prop =
if !Config.footprint then prop
else begin
let indices = sigma_get_array_indices prop.sigma in
@ -1958,7 +1958,7 @@ let prop_rename_array_indices prop =
select_minimal_indices indices_seen_new indices_rest_new in
let minimal_indices = select_minimal_indices [] indices in
let subst = compute_reindexing_from_indices minimal_indices in
apply_reindexing subst prop
apply_reindexing tenv subst prop
end
let compute_renaming fav =
@ -2100,11 +2100,11 @@ let sub_captured_ren ren sub =
Sil.sub_map (ident_captured_ren ren) (exp_captured_ren ren) sub
(** Canonicalize the names of primed variables and footprint vars. *)
let prop_rename_primed_footprint_vars (p : normal t) : normal t =
let p = prop_rename_array_indices p in
let prop_rename_primed_footprint_vars tenv (p : normal t) : normal t =
let p = prop_rename_array_indices tenv p in
let bound_vars =
let filter id = Ident.is_footprint id || Ident.is_primed id in
let p_dfs = prop_dfs_sort p in
let p_dfs = prop_dfs_sort tenv p in
let fvars_in_p = prop_fav p_dfs in
Sil.fav_filter_ident fvars_in_p filter;
fvars_in_p in
@ -2119,9 +2119,9 @@ let prop_rename_primed_footprint_vars (p : normal t) : normal t =
(* It is fine to use the empty substituion during normalization
because the renaming maintains that a substitution is normalized *)
let nsub' = Normalize.sub_normalize sub' in
let nsigma' = Normalize.sigma_normalize sub_for_normalize sigma' in
let npi' = Normalize.pi_normalize sub_for_normalize nsigma' pi' in
let p' = Normalize.footprint_normalize
let nsigma' = Normalize.sigma_normalize tenv sub_for_normalize sigma' in
let npi' = Normalize.pi_normalize tenv sub_for_normalize nsigma' pi' in
let p' = Normalize.footprint_normalize tenv
(set prop_emp ~sub:nsub' ~pi:npi' ~sigma:nsigma' ~pi_fp:pi_fp' ~sigma_fp:sigma_fp') in
unsafe_cast_to_normal p'
@ -2136,12 +2136,12 @@ let prop_sub subst (prop: 'a t) : exposed t =
set prop_emp ~pi ~sigma ~pi_fp ~sigma_fp
(** Apply renaming substitution to a proposition. *)
let prop_ren_sub (ren_sub: Sil.subst) (prop: normal t) : normal t =
Normalize.normalize (prop_sub ren_sub prop)
let prop_ren_sub tenv (ren_sub: Sil.subst) (prop: normal t) : normal t =
Normalize.normalize tenv (prop_sub ren_sub prop)
(** Existentially quantify the [fav] in [prop].
[fav] should not contain any primed variables. *)
let exist_quantify fav (prop : normal t) : normal t =
let exist_quantify tenv fav (prop : normal t) : normal t =
let ids = Sil.fav_to_list fav in
if IList.exists Ident.is_primed ids then assert false; (* sanity check *)
if ids == [] then prop else
@ -2159,7 +2159,7 @@ let exist_quantify fav (prop : normal t) : normal t =
L.out "PI:%a\n" pp_pi prop'.pi;
L.out "PROP:%a\n@." pp_prop prop';
*)
prop_ren_sub ren_sub prop'
prop_ren_sub tenv ren_sub prop'
(** Apply the substitution [fe] to all the expressions in the prop. *)
let prop_expmap (fe: Exp.t -> Exp.t) prop =
@ -2171,25 +2171,25 @@ let prop_expmap (fe: Exp.t -> Exp.t) prop =
set prop ~pi ~sigma ~pi_fp ~sigma_fp
(** convert identifiers in fav to kind [k] *)
let vars_make_unprimed fav prop =
let vars_make_unprimed tenv fav prop =
let ids = Sil.fav_to_list fav in
let ren_sub =
Sil.sub_of_list (IList.map
(fun i -> (i, Exp.Var (Ident.create_fresh Ident.knormal)))
ids) in
prop_ren_sub ren_sub prop
prop_ren_sub tenv ren_sub prop
(** convert the normal vars to primed vars. *)
let prop_normal_vars_to_primed_vars p =
let prop_normal_vars_to_primed_vars tenv p =
let fav = prop_fav p in
Sil.fav_filter_ident fav Ident.is_normal;
exist_quantify fav p
exist_quantify tenv fav p
(** convert the primed vars to normal vars. *)
let prop_primed_vars_to_normal_vars (p : normal t) : normal t =
let prop_primed_vars_to_normal_vars tenv (p : normal t) : normal t =
let fav = prop_fav p in
Sil.fav_filter_ident fav Ident.is_primed;
vars_make_unprimed fav p
vars_make_unprimed tenv fav p
let from_pi pi =
set prop_emp ~pi
@ -2198,7 +2198,7 @@ let from_sigma sigma =
set prop_emp ~sigma
(** Rename free variables in a prop replacing them with existentially quantified vars *)
let prop_rename_fav_with_existentials (p : normal t) : normal t =
let prop_rename_fav_with_existentials tenv (p : normal t) : normal t =
let fav = Sil.fav_new () in
prop_fav_add fav p;
let ids = Sil.fav_to_list fav in
@ -2206,7 +2206,7 @@ let prop_rename_fav_with_existentials (p : normal t) : normal t =
let ren_sub = Sil.sub_of_list (IList.map (fun (i, i') -> (i, Exp.Var i')) ids') in
let p' = prop_sub ren_sub p in
(*L.d_strln "Prop after renaming:"; d_prop p'; L.d_strln "";*)
Normalize.normalize p'
Normalize.normalize tenv p'
(** {2 Prop iterators} *)
@ -2239,10 +2239,10 @@ let prop_iter_create prop =
| _ -> None
(** Return the prop associated to the iterator. *)
let prop_iter_to_prop iter =
let prop_iter_to_prop tenv iter =
let sigma = IList.rev_append iter.pit_old (iter.pit_curr:: iter.pit_new) in
let prop =
Normalize.normalize
Normalize.normalize tenv
(set prop_emp
~sub:iter.pit_sub
~pi:iter.pit_pi
@ -2250,7 +2250,7 @@ let prop_iter_to_prop iter =
~pi_fp:iter.pit_pi_fp
~sigma_fp:iter.pit_sigma_fp) in
IList.fold_left
(fun p (footprint, atom) -> Normalize.prop_atom_and ~footprint: footprint p atom)
(fun p (footprint, atom) -> Normalize.prop_atom_and tenv ~footprint: footprint p atom)
prop iter.pit_newpi
(** Add an atom to the pi part of prop iter. The
@ -2261,9 +2261,9 @@ let prop_iter_add_atom footprint iter atom =
(** Remove the current element of the iterator, and return the prop
associated to the resulting iterator *)
let prop_iter_remove_curr_then_to_prop iter : normal t =
let prop_iter_remove_curr_then_to_prop tenv iter : normal t =
let sigma = IList.rev_append iter.pit_old iter.pit_new in
let normalized_sigma = Normalize.sigma_normalize iter.pit_sub sigma in
let normalized_sigma = Normalize.sigma_normalize tenv iter.pit_sub sigma in
let prop =
set prop_emp
~sub:iter.pit_sub
@ -2274,14 +2274,14 @@ let prop_iter_remove_curr_then_to_prop iter : normal t =
unsafe_cast_to_normal prop
(** Return the current hpred and state. *)
let prop_iter_current iter =
let curr = Normalize.hpred_normalize iter.pit_sub iter.pit_curr in
let prop_iter_current tenv iter =
let curr = Normalize.hpred_normalize tenv iter.pit_sub iter.pit_curr in
let prop =
unsafe_cast_to_normal
(set prop_emp ~sigma:[curr]) in
let prop' =
IList.fold_left
(fun p (footprint, atom) -> Normalize.prop_atom_and ~footprint: footprint p atom)
(fun p (footprint, atom) -> Normalize.prop_atom_and tenv ~footprint: footprint p atom)
prop iter.pit_newpi in
match prop'.sigma with
| [curr'] -> (curr', iter.pit_state)
@ -2337,13 +2337,13 @@ let rec prop_iter_find iter filter =
let prop_iter_set_state iter state =
{ iter with pit_state = state }
let prop_iter_make_id_primed id iter =
let prop_iter_make_id_primed tenv id iter =
let pid = Ident.create_fresh Ident.kprimed in
let sub_id = Sil.sub_of_list [(id, Exp.Var pid)] in
let normalize (id, e) =
let eq' : Sil.atom = Aeq (Sil.exp_sub sub_id (Var id), Sil.exp_sub sub_id e) in
Normalize.atom_normalize Sil.sub_empty eq' in
Normalize.atom_normalize tenv Sil.sub_empty eq' in
let rec split pairs_unpid pairs_pid = function
| [] -> (IList.rev pairs_unpid, IList.rev pairs_pid)
@ -2354,7 +2354,7 @@ let prop_iter_make_id_primed id iter =
L.out "@[<2>#### ERROR: an assumption of the analyzer broken ####@\n";
L.out "Broken Assumption: id notin e for all (id,e) in sub@\n";
L.out "(id,e) : (%a,%a)@\n" (Ident.pp pe_text) id1 (Sil.pp_exp pe_text) e1;
L.out "PROP : %a@\n@." (pp_prop pe_text) (prop_iter_to_prop iter);
L.out "PROP : %a@\n@." (pp_prop pe_text) (prop_iter_to_prop tenv iter);
assert false
| Aeq (Var id1, e1) when Ident.equal pid id1 ->
split pairs_unpid ((id1, e1):: pairs_pid) eqs_cur
@ -2473,14 +2473,14 @@ let prop_iter_gc_fields iter =
hpred_gc_fields fav iter'.pit_curr in
prop_iter_map f iter
let prop_case_split prop =
let prop_case_split tenv prop =
let pi_sigma_list = Sil.sigma_to_sigma_ne prop.sigma in
let f props_acc (pi, sigma) =
let sigma' = sigma_normalize_prop prop sigma in
let sigma' = sigma_normalize_prop tenv prop sigma in
let prop' =
unsafe_cast_to_normal
(set prop ~sigma:sigma') in
(IList.fold_left Normalize.prop_atom_and prop' pi):: props_acc in
(IList.fold_left (Normalize.prop_atom_and tenv) prop' pi):: props_acc in
IList.fold_left f [] pi_sigma_list
let prop_expand prop =

@ -119,7 +119,7 @@ val sigma_fav_in_pvars_add : fav -> hpred list -> unit
val prop_fav_add : fav -> 'a t -> unit
(** Compute free non-program variables of prop, visited in depth first order *)
val prop_fav_add_dfs : fav -> 'a t -> unit
val prop_fav_add_dfs : Tenv.t -> fav -> 'a t -> unit
val prop_fav: normal t -> fav
@ -147,12 +147,12 @@ val prop_expmap : (Exp.t -> Exp.t) -> 'a t -> exposed t
(** Relaces all expressions in the [hpred list] using the first argument.
Assume that the first parameter defines a partial function.
No expressions inside hpara are replaced. *)
val sigma_replace_exp : (Exp.t * Exp.t) list -> hpred list -> hpred list
val sigma_replace_exp : Tenv.t -> (Exp.t * Exp.t) list -> hpred list -> hpred list
(** {2 Normalization} *)
(** Turn an inequality expression into an atom *)
val mk_inequality : Exp.t -> Sil.atom
val mk_inequality : Tenv.t -> Exp.t -> Sil.atom
(** Return [true] if the atom is an inequality *)
val atom_is_inequality : Sil.atom -> bool
@ -166,32 +166,32 @@ val atom_const_lt_exp : Sil.atom -> (IntLit.t * Exp.t) option
(** Normalize [exp] using the pure part of [prop]. Later, we should
change this such that the normalization exposes offsets of [exp]
as much as possible. *)
val exp_normalize_prop : 'a t -> Exp.t -> Exp.t
val exp_normalize_prop : Tenv.t -> 'a t -> Exp.t -> Exp.t
(** Normalize the expression without abstracting complex subexpressions *)
val exp_normalize_noabs : Sil.subst -> Exp.t -> Exp.t
val exp_normalize_noabs : Tenv.t -> Sil.subst -> Exp.t -> Exp.t
(** Collapse consecutive indices that should be added. For instance,
this function reduces x[1][1] to x[2]. The [typ] argument is used
to ensure the soundness of this collapsing. *)
val exp_collapse_consecutive_indices_prop : Typ.t -> Exp.t -> Exp.t
val exp_collapse_consecutive_indices_prop : Tenv.t -> Typ.t -> Exp.t -> Exp.t
(** Normalize [exp] used for the address of a heap cell.
This normalization does not combine two offsets inside [exp]. *)
val lexp_normalize_prop : 'a t -> Exp.t -> Exp.t
val lexp_normalize_prop : Tenv.t -> 'a t -> Exp.t -> Exp.t
val atom_normalize_prop : 'a t -> atom -> atom
val atom_normalize_prop : Tenv.t -> 'a t -> atom -> atom
val strexp_normalize_prop : 'a t -> strexp -> strexp
val strexp_normalize_prop : Tenv.t -> 'a t -> strexp -> strexp
val hpred_normalize_prop : 'a t -> hpred -> hpred
val hpred_normalize_prop : Tenv.t -> 'a t -> hpred -> hpred
val sigma_normalize_prop : 'a t -> hpred list -> hpred list
val sigma_normalize_prop : Tenv.t -> 'a t -> hpred list -> hpred list
val pi_normalize_prop : 'a t -> atom list -> atom list
val pi_normalize_prop : Tenv.t -> 'a t -> atom list -> atom list
(** normalize a prop *)
val normalize : exposed t -> normal t
val normalize : Tenv.t -> exposed t -> normal t
(** expose a prop, no-op used to instantiate the sub-type relation *)
val expose : normal t -> exposed t
@ -209,46 +209,44 @@ val prop_is_emp : 'a t -> bool
(** {2 Functions for changing and generating propositions} *)
(** Construct a disequality. *)
val mk_neq : Exp.t -> Exp.t -> atom
val mk_neq : Tenv.t -> Exp.t -> Exp.t -> atom
(** Construct an equality. *)
val mk_eq : Exp.t -> Exp.t -> atom
val mk_eq : Tenv.t -> Exp.t -> Exp.t -> atom
(** Construct a positive pred. *)
val mk_pred : PredSymb.t -> Exp.t list -> atom
val mk_pred : Tenv.t -> PredSymb.t -> Exp.t list -> atom
(** Construct a negative pred. *)
val mk_npred : PredSymb.t -> Exp.t list -> atom
val mk_npred : Tenv.t -> PredSymb.t -> Exp.t list -> atom
(** create a strexp of the given type, populating the structures if [expand_structs] is true *)
val create_strexp_of_type :
Tenv.t option -> struct_init_mode -> Typ.t -> Exp.t option -> Sil.inst -> Sil.strexp
Tenv.t -> struct_init_mode -> Typ.t -> Exp.t option -> Sil.inst -> Sil.strexp
(** Construct a pointsto. *)
val mk_ptsto : Exp.t -> strexp -> Exp.t -> hpred
val mk_ptsto : Tenv.t -> Exp.t -> strexp -> Exp.t -> hpred
(** Construct a points-to predicate for an expression using either the provided expression [name] as
base for fresh identifiers. *)
val mk_ptsto_exp :
Tenv.t option -> struct_init_mode -> Exp.t * Exp.t * Exp.t option -> Sil.inst -> hpred
val mk_ptsto_exp : Tenv.t -> struct_init_mode -> Exp.t * Exp.t * Exp.t option -> Sil.inst -> hpred
(** Construct a points-to predicate for a single program variable.
If [expand_structs] is true, initialize the fields of structs with fresh variables. *)
val mk_ptsto_lvar :
Tenv.t option -> struct_init_mode -> Sil.inst -> Pvar.t * Exp.t * Exp.t option -> hpred
val mk_ptsto_lvar : Tenv.t -> struct_init_mode -> Sil.inst -> Pvar.t * Exp.t * Exp.t option -> hpred
(** Construct a lseg predicate *)
val mk_lseg : lseg_kind -> hpara -> Exp.t -> Exp.t -> Exp.t list -> hpred
val mk_lseg : Tenv.t -> lseg_kind -> hpara -> Exp.t -> Exp.t -> Exp.t list -> hpred
(** Construct a dllseg predicate *)
val mk_dllseg : lseg_kind -> hpara_dll -> Exp.t -> Exp.t -> Exp.t -> Exp.t -> Exp.t list -> hpred
val mk_dllseg : Tenv.t -> lseg_kind -> hpara_dll -> Exp.t -> Exp.t -> Exp.t -> Exp.t -> Exp.t list -> hpred
(** Construct a hpara *)
val mk_hpara : Ident.t -> Ident.t -> Ident.t list -> Ident.t list -> hpred list -> hpara
val mk_hpara : Tenv.t -> Ident.t -> Ident.t -> Ident.t list -> Ident.t list -> hpred list -> hpara
(** Construct a dll_hpara *)
val mk_dll_hpara :
Ident.t -> Ident.t -> Ident.t -> Ident.t list -> Ident.t list -> hpred list -> hpara_dll
Tenv.t -> Ident.t -> Ident.t -> Ident.t -> Ident.t list -> Ident.t list -> hpred list -> hpara_dll
(** Proposition [true /\ emp]. *)
val prop_emp : normal t
@ -263,19 +261,19 @@ val prop_hpred_star : 'a t -> hpred -> exposed t
val prop_sigma_star : 'a t -> hpred list -> exposed t
(** Conjoin a pure atomic predicate by normal conjunction. *)
val prop_atom_and : ?footprint: bool -> normal t -> atom -> normal t
val prop_atom_and : Tenv.t -> ?footprint: bool -> normal t -> atom -> normal t
(** Conjoin [exp1]=[exp2] with a symbolic heap [prop]. *)
val conjoin_eq : ?footprint: bool -> Exp.t -> Exp.t -> normal t -> normal t
val conjoin_eq : Tenv.t -> ?footprint: bool -> Exp.t -> Exp.t -> normal t -> normal t
(** Conjoin [exp1]!=[exp2] with a symbolic heap [prop]. *)
val conjoin_neq : ?footprint: bool -> Exp.t -> Exp.t -> normal t -> normal t
val conjoin_neq : Tenv.t -> ?footprint: bool -> Exp.t -> Exp.t -> normal t -> normal t
(** Return the pure part of [prop]. *)
val get_pure : 'a t -> atom list
(** Canonicalize the names of primed variables. *)
val prop_rename_primed_footprint_vars : normal t -> normal t
val prop_rename_primed_footprint_vars : Tenv.t -> normal t -> normal t
(** Extract the footprint and return it as a prop *)
val extract_footprint : 'a t -> exposed t
@ -287,18 +285,18 @@ val extract_spec : normal t -> (normal t * normal t)
val prop_set_footprint : 'a t -> 'b t -> exposed t
(** Expand PE listsegs if the flag is on. *)
val prop_expand : normal t -> normal t list
val prop_expand : Tenv.t -> normal t -> normal t list
(** {2 Functions for existentially quantifying and unquantifying variables} *)
(** Existentially quantify the [ids] in [prop]. *)
val exist_quantify : fav -> normal t -> normal t
val exist_quantify : Tenv.t -> fav -> normal t -> normal t
(** convert the footprint vars to primed vars. *)
val prop_normal_vars_to_primed_vars : normal t -> normal t
val prop_normal_vars_to_primed_vars : Tenv.t -> normal t -> normal t
(** convert the primed vars to normal vars. *)
val prop_primed_vars_to_normal_vars : normal t -> normal t
val prop_primed_vars_to_normal_vars : Tenv.t -> normal t -> normal t
(** Build an exposed prop from pi *)
val from_pi : pi -> exposed t
@ -311,7 +309,7 @@ val set : ?sub:Sil.subst -> ?pi:pi -> ?sigma:sigma -> ?pi_fp:pi -> ?sigma_fp:sig
'a t -> exposed t
(** Rename free variables in a prop replacing them with existentially quantified vars *)
val prop_rename_fav_with_existentials : normal t -> normal t
val prop_rename_fav_with_existentials : Tenv.t -> normal t -> normal t
(** {2 Prop iterators} *)
@ -322,7 +320,7 @@ type 'a prop_iter
val prop_iter_create : normal t -> unit prop_iter option
(** Return the prop associated to the iterator. *)
val prop_iter_to_prop : 'a prop_iter -> normal t
val prop_iter_to_prop : Tenv.t -> 'a prop_iter -> normal t
(** Add an atom to the pi part of prop iter. The
first parameter records whether it is done
@ -331,10 +329,10 @@ val prop_iter_add_atom : bool -> 'a prop_iter -> atom -> 'a prop_iter
(** Remove the current element from the iterator, and return the prop
associated to the resulting iterator. *)
val prop_iter_remove_curr_then_to_prop : 'a prop_iter -> normal t
val prop_iter_remove_curr_then_to_prop : Tenv.t -> 'a prop_iter -> normal t
(** Return the current hpred and state. *)
val prop_iter_current : 'a prop_iter -> (hpred * 'a)
val prop_iter_current : Tenv.t -> 'a prop_iter -> (hpred * 'a)
(** Return the next iterator. *)
val prop_iter_next : 'a prop_iter -> unit prop_iter option
@ -370,7 +368,7 @@ val prop_iter_update_current_by_list : 'a prop_iter -> hpred list -> unit prop_i
val prop_iter_set_state : 'a prop_iter -> 'b -> 'b prop_iter
(** Rename [ident] in [iter] by a fresh primed identifier *)
val prop_iter_make_id_primed : Ident.t -> 'a prop_iter -> 'a prop_iter
val prop_iter_make_id_primed : Tenv.t -> Ident.t -> 'a prop_iter -> 'a prop_iter
(** Collect garbage fields. *)
val prop_iter_gc_fields : unit prop_iter -> unit prop_iter

@ -29,13 +29,15 @@ let compare = PropSet.compare
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 =
let ps = Prop.prop_expand p in
IList.fold_left (fun pset' p' -> PropSet.add (Prop.prop_rename_primed_footprint_vars p') pset') pset ps
let add tenv p pset =
let ps = Prop.prop_expand tenv p in
IList.fold_left (fun pset' p' ->
PropSet.add (Prop.prop_rename_primed_footprint_vars tenv p') pset'
) pset ps
(** Singleton set. *)
let singleton p =
add p PropSet.empty
let singleton tenv p =
add tenv p PropSet.empty
(** Set union. *)
let union = PropSet.union
@ -61,22 +63,22 @@ let size = PropSet.cardinal
let filter = PropSet.filter
let from_proplist plist =
IList.fold_left (fun pset p -> add p pset) empty plist
let from_proplist tenv plist =
IList.fold_left (fun pset p -> add tenv p pset) empty plist
let to_proplist pset =
PropSet.elements pset
(** Apply function to all the elements of [propset], removing those where it returns [None]. *)
let map_option f pset =
let map_option tenv f pset =
let plisto = IList.map f (to_proplist pset) in
let plisto = IList.filter (function | Some _ -> true | None -> false) plisto in
let plist = IList.map (function Some p -> p | None -> assert false) plisto in
from_proplist plist
from_proplist tenv plist
(** Apply function to all the elements of [propset]. *)
let map f pset =
from_proplist (IList.map f (to_proplist pset))
let map tenv f pset =
from_proplist tenv (IList.map f (to_proplist pset))
(** [fold f pset a] computes [f (... (f (f a p1) p2) ...) pn]
where [p1 ... pN] are the elements of pset, in increasing order. *)

@ -22,7 +22,7 @@ type t
val compare : t -> t -> int
(** Singleton set. *)
val singleton : Prop.normal Prop.t -> t
val singleton : Tenv.t -> Prop.normal Prop.t -> t
(** Set membership. *)
val mem : Prop.normal Prop.t -> t -> bool
@ -34,7 +34,7 @@ val union : t -> t -> t
val inter : t -> t -> t
(** Add [prop] to propset. *)
val add : Prop.normal Prop.t -> t -> t
val add : Tenv.t -> Prop.normal Prop.t -> t -> t
(** Set difference. *)
val diff : t -> t -> t
@ -45,15 +45,15 @@ val empty : t
(** Size of the set *)
val size : t -> int
val from_proplist : Prop.normal Prop.t list -> t
val from_proplist : Tenv.t -> Prop.normal Prop.t list -> t
val to_proplist : t -> Prop.normal Prop.t list
(** Apply function to all the elements of the propset. *)
val map : (Prop.normal Prop.t -> Prop.normal Prop.t) -> t -> t
val map : Tenv.t -> (Prop.normal Prop.t -> Prop.normal Prop.t) -> t -> t
(** Apply function to all the elements of the propset, removing those where it returns [None]. *)
val map_option : (Prop.normal Prop.t -> Prop.normal Prop.t option) -> t -> t
val map_option : Tenv.t -> (Prop.normal Prop.t -> Prop.normal Prop.t option) -> t -> t
(** [fold f pset a] computes [(f pN ... (f p2 (f p1 a))...)],
where [p1 ... pN] are the elements of pset, in increasing

@ -40,17 +40,17 @@ let rec remove_redundancy have_same_key acc = function
if have_same_key x y then remove_redundancy have_same_key acc (x:: l')
else remove_redundancy have_same_key (x:: acc) l
let rec is_java_class = function
let rec is_java_class tenv = function
| Typ.Tstruct struct_typ -> Typ.struct_typ_is_java_class struct_typ
| Typ.Tarray (inner_typ, _) | Tptr (inner_typ, _) -> is_java_class inner_typ
| Typ.Tarray (inner_typ, _) | Tptr (inner_typ, _) -> is_java_class tenv inner_typ
| _ -> false
(** Negate an atom *)
let atom_negate = function
let atom_negate tenv = function
| Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i ->
Prop.mk_inequality (Exp.lt e2 e1)
Prop.mk_inequality tenv (Exp.lt e2 e1)
| Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i)) when IntLit.isone i ->
Prop.mk_inequality (Exp.le e2 e1)
Prop.mk_inequality tenv (Exp.le e2 e1)
| Sil.Aeq (e1, e2) -> Sil.Aneq (e1, e2)
| Sil.Aneq (e1, e2) -> Sil.Aeq (e1, e2)
| Sil.Apred (a, es) -> Sil.Anpred (a, es)
@ -214,7 +214,7 @@ module Inequalities : sig
type t
(** Extract inequalities and disequalities from [prop] *)
val from_prop : Prop.normal Prop.t -> t
val from_prop : Tenv.t -> Prop.normal Prop.t -> t
(** Check [t |- e1!=e2]. Result [false] means "don't know". *)
val check_ne : t -> Exp.t -> Exp.t -> bool
@ -379,7 +379,7 @@ end = struct
IList.iter process_atom pi;
saturate { leqs = !leqs; lts = !lts; neqs = !neqs }
let from_sigma sigma =
let from_sigma _tenv sigma =
let leqs = ref [] in
let lts = ref [] in
let add_lt_minus1_e e =
@ -424,10 +424,10 @@ end = struct
let neqs_new = ineq1.neqs @ ineq2.neqs in
saturate { leqs = leqs_new; lts = lts_new; neqs = neqs_new }
let from_prop prop =
let from_prop tenv prop =
let sigma = prop.Prop.sigma in
let pi = prop.Prop.pi in
let ineq_sigma = from_sigma sigma in
let ineq_sigma = from_sigma tenv sigma in
let ineq_pi = from_pi pi in
saturate (join ineq_sigma ineq_pi)
@ -542,9 +542,9 @@ end
(* End of module Inequalities *)
(** Check [prop |- e1=e2]. Result [false] means "don't know". *)
let check_equal prop e1 e2 =
let n_e1 = Prop.exp_normalize_prop prop e1 in
let n_e2 = Prop.exp_normalize_prop prop e2 in
let check_equal tenv prop e1 e2 =
let n_e1 = Prop.exp_normalize_prop tenv prop e1 in
let n_e2 = Prop.exp_normalize_prop tenv prop e2 in
let check_equal () =
Exp.equal n_e1 n_e2 in
let check_equal_const () =
@ -560,25 +560,25 @@ let check_equal prop e1 e2 =
| _, _ -> false in
let check_equal_pi () =
let eq = Sil.Aeq(n_e1, n_e2) in
let n_eq = Prop.atom_normalize_prop prop eq in
let n_eq = Prop.atom_normalize_prop tenv prop eq in
let pi = prop.Prop.pi in
IList.exists (Sil.atom_equal n_eq) pi in
check_equal () || check_equal_const () || check_equal_pi ()
(** Check [ |- e=0]. Result [false] means "don't know". *)
let check_zero e =
check_equal Prop.prop_emp e Exp.zero
let check_zero tenv e =
check_equal tenv Prop.prop_emp e 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.
*)
let is_root prop base_exp exp =
let is_root tenv prop base_exp exp =
let rec f offlist_past e = match e with
| Exp.Var _ | Exp.Const _ | Exp.UnOp _ | Exp.BinOp _ | Exp.Exn _ | Exp.Closure _ | Exp.Lvar _
| Exp.Sizeof _ ->
if check_equal prop base_exp e
if check_equal tenv prop base_exp e
then Some offlist_past
else None
| Exp.Cast(_, sub_exp) -> f offlist_past sub_exp
@ -587,8 +587,8 @@ let is_root prop base_exp exp =
in f [] exp
(** Get upper and lower bounds of an expression, if any *)
let get_bounds prop _e =
let e_norm = Prop.exp_normalize_prop prop _e in
let get_bounds tenv prop _e =
let e_norm = Prop.exp_normalize_prop tenv prop _e in
let e_root, off = match e_norm with
| Exp.BinOp (Binop.PlusA, e, Exp.Const (Const.Cint n1)) ->
e, IntLit.neg n1
@ -596,7 +596,7 @@ let get_bounds prop _e =
e, n1
| _ ->
e_norm, IntLit.zero in
let ineq = Inequalities.from_prop prop in
let ineq = Inequalities.from_prop tenv prop in
let upper_opt = Inequalities.compute_upper_bound ineq e_root in
let lower_opt = Inequalities.compute_lower_bound ineq e_root in
let (+++) n_opt k = match n_opt with
@ -605,10 +605,10 @@ let get_bounds prop _e =
upper_opt +++ off, lower_opt +++ off
(** Check whether [prop |- e1!=e2]. *)
let check_disequal prop e1 e2 =
let check_disequal tenv prop e1 e2 =
let spatial_part = prop.Prop.sigma in
let n_e1 = Prop.exp_normalize_prop prop e1 in
let n_e2 = Prop.exp_normalize_prop prop e2 in
let n_e1 = Prop.exp_normalize_prop tenv prop e1 in
let n_e2 = Prop.exp_normalize_prop tenv prop e2 in
let check_disequal_const () =
match n_e1, n_e2 with
| Exp.Const c1, Exp.Const c2 ->
@ -630,14 +630,14 @@ let check_disequal prop e1 e2 =
| Exp.Lindex(Exp.Const c1, Exp.Const d1), Exp.Lindex (Exp.Const c2, Exp.Const d2) ->
Const.equal c1 c2 && not (Const.equal d1 d2)
| _, _ -> false in
let ineq = lazy (Inequalities.from_prop prop) in
let ineq = lazy (Inequalities.from_prop tenv prop) in
let check_pi_implies_disequal e1 e2 =
Inequalities.check_ne (Lazy.force ineq) e1 e2 in
let neq_spatial_part () =
let rec f sigma_irrelevant e = function
| [] -> None
| Sil.Hpointsto (base, _, _) as hpred :: sigma_rest ->
(match is_root prop base e with
(match is_root tenv prop base e with
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
@ -645,7 +645,7 @@ let check_disequal prop e1 e2 =
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant'))
| Sil.Hlseg (k, _, e1, e2, _) as hpred :: sigma_rest ->
(match is_root prop e1 e with
(match is_root tenv prop e1 e with
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
@ -660,14 +660,14 @@ let check_disequal prop e1 e2 =
let sigma_rest' = (IList.rev sigma_irrelevant) @ sigma_rest
in f [] e2 sigma_rest')
| Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) :: sigma_rest ->
if is_root prop iF e != None || is_root prop iB e != None then
if is_root tenv prop iF e != None || is_root tenv prop iB e != None then
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (true, sigma_irrelevant')
else
let sigma_irrelevant' = (IList.rev sigma_irrelevant) @ sigma_rest
in Some (false, sigma_irrelevant')
| Sil.Hdllseg (Sil.Lseg_PE, _, iF, _, oF, _, _) as hpred :: sigma_rest ->
(match is_root prop iF e with
(match is_root tenv prop iF e with
| None ->
let sigma_irrelevant' = hpred :: sigma_irrelevant
in f sigma_irrelevant' e sigma_rest
@ -697,7 +697,7 @@ let check_disequal prop e1 e2 =
check_disequal_const () || neq_pure_part () || neq_spatial_part ()
(** Check [prop |- e1<=e2], to be called from normalized atom *)
let check_le_normalized prop e1 e2 =
let check_le_normalized tenv prop e1 e2 =
(* L.d_str "check_le_normalized "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *)
let eL, eR, off = match e1, e2 with
| Exp.BinOp(Binop.MinusA, f1, f2), Exp.Const (Const.Cint n) ->
@ -706,7 +706,7 @@ let check_le_normalized prop e1 e2 =
else f1, f2, n
| _ ->
e1, e2, IntLit.zero in
let ineq = Inequalities.from_prop prop in
let ineq = Inequalities.from_prop tenv prop in
let upper_lower_check () =
let upperL_opt = Inequalities.compute_upper_bound ineq eL in
let lowerR_opt = Inequalities.compute_lower_bound ineq eR in
@ -715,12 +715,12 @@ let check_le_normalized prop e1 e2 =
| Some upper1, Some lower2 -> IntLit.leq upper1 (lower2 ++ IntLit.one ++ off) in
(upper_lower_check ())
|| (Inequalities.check_le ineq e1 e2)
|| (check_equal prop e1 e2)
|| (check_equal tenv prop e1 e2)
(** Check [prop |- e1<e2], to be called from normalized atom *)
let check_lt_normalized prop e1 e2 =
let check_lt_normalized tenv prop e1 e2 =
(* L.d_str "check_lt_normalized "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *)
let ineq = Inequalities.from_prop prop in
let ineq = Inequalities.from_prop tenv prop in
let upper_lower_check () =
let upper1_opt = Inequalities.compute_upper_bound ineq e1 in
let lower2_opt = Inequalities.compute_lower_bound ineq e2 in
@ -740,8 +740,8 @@ let get_smt_key a p =
Digest.to_hex (Digest.file tmp_filename)
(** Check whether [prop |- a]. False means dont know. *)
let check_atom prop a0 =
let a = Prop.atom_normalize_prop prop a0 in
let check_atom tenv prop a0 =
let a = Prop.atom_normalize_prop tenv prop a0 in
let prop_no_fp = Prop.set prop ~pi_fp:[] ~sigma_fp:[] in
if Config.smt_output then begin
let key = get_smt_key a prop_no_fp in
@ -758,42 +758,42 @@ let check_atom prop a0 =
end;
match a with
| Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const (Const.Cint i))
when IntLit.isone i -> check_le_normalized prop e1 e2
when IntLit.isone i -> check_le_normalized tenv prop e1 e2
| Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const (Const.Cint i))
when IntLit.isone i -> check_lt_normalized prop e1 e2
| Sil.Aeq (e1, e2) -> check_equal prop e1 e2
| Sil.Aneq (e1, e2) -> check_disequal prop e1 e2
when IntLit.isone i -> check_lt_normalized tenv prop e1 e2
| Sil.Aeq (e1, e2) -> check_equal tenv prop e1 e2
| Sil.Aneq (e1, e2) -> check_disequal tenv prop e1 e2
| Sil.Apred _ | Anpred _ -> IList.exists (Sil.atom_equal a) prop.Prop.pi
(** Check [prop |- e1<=e2]. Result [false] means "don't know". *)
let check_le prop e1 e2 =
let check_le tenv prop e1 e2 =
let e1_le_e2 = Exp.BinOp (Binop.Le, e1, e2) in
check_atom prop (Prop.mk_inequality e1_le_e2)
check_atom tenv prop (Prop.mk_inequality tenv e1_le_e2)
(** Check whether [prop |- allocated(e)]. *)
let check_allocatedness prop e =
let n_e = Prop.exp_normalize_prop prop e in
let check_allocatedness tenv prop e =
let n_e = Prop.exp_normalize_prop tenv prop e in
let spatial_part = prop.Prop.sigma in
let f = function
| Sil.Hpointsto (base, _, _) ->
is_root prop base n_e != None
is_root tenv prop base n_e != None
| Sil.Hlseg (k, _, e1, e2, _) ->
if k == Sil.Lseg_NE || check_disequal prop e1 e2 then
is_root prop e1 n_e != None
if k == Sil.Lseg_NE || check_disequal tenv prop e1 e2 then
is_root tenv prop e1 n_e != None
else false
| Sil.Hdllseg (k, _, iF, oB, oF, iB, _) ->
if k == Sil.Lseg_NE || check_disequal prop iF oF || check_disequal prop iB oB then
is_root prop iF n_e != None || is_root prop iB n_e != None
if k == Sil.Lseg_NE || check_disequal tenv prop iF oF || check_disequal tenv prop iB oB then
is_root tenv prop iF n_e != None || is_root tenv prop iB n_e != None
else false
in IList.exists f spatial_part
(** Compute an upper bound of an expression *)
let compute_upper_bound_of_exp p e =
let ineq = Inequalities.from_prop p in
let compute_upper_bound_of_exp tenv p e =
let ineq = Inequalities.from_prop tenv p in
Inequalities.compute_upper_bound ineq e
(** Check if two hpreds have the same allocated lhs *)
let check_inconsistency_two_hpreds prop =
let check_inconsistency_two_hpreds tenv prop =
let sigma = prop.Prop.sigma in
let rec f e sigma_seen = function
| [] -> false
@ -811,10 +811,10 @@ let check_inconsistency_two_hpreds prop =
| Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) as hpred :: sigma_rest ->
if Exp.equal e1 e
then
let prop' = Prop.normalize (Prop.from_sigma (sigma_seen@sigma_rest)) in
let prop_new = Prop.conjoin_eq e1 e2 prop' in
let prop' = Prop.normalize tenv (Prop.from_sigma (sigma_seen@sigma_rest)) in
let prop_new = Prop.conjoin_eq tenv e1 e2 prop' in
let sigma_new = prop_new.Prop.sigma in
let e_new = Prop.exp_normalize_prop prop_new e
let e_new = Prop.exp_normalize_prop tenv prop_new e
in f e_new [] sigma_new
else f e (hpred:: sigma_seen) sigma_rest
| Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, Exp.Const (Const.Cint i), _, _) as hpred :: sigma_rest
@ -824,10 +824,10 @@ let check_inconsistency_two_hpreds prop =
| Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, e3, _, _) as hpred :: sigma_rest ->
if Exp.equal e1 e
then
let prop' = Prop.normalize (Prop.from_sigma (sigma_seen@sigma_rest)) in
let prop_new = Prop.conjoin_eq e1 e3 prop' in
let prop' = Prop.normalize tenv (Prop.from_sigma (sigma_seen@sigma_rest)) in
let prop_new = Prop.conjoin_eq tenv e1 e3 prop' in
let sigma_new = prop_new.Prop.sigma in
let e_new = Prop.exp_normalize_prop prop_new e
let e_new = Prop.exp_normalize_prop tenv prop_new e
in f e_new [] sigma_new
else f e (hpred:: sigma_seen) sigma_rest in
let rec check sigma_seen = function
@ -845,11 +845,11 @@ let check_inconsistency_two_hpreds prop =
check [] sigma
(** Inconsistency checking ignoring footprint. *)
let check_inconsistency_base prop =
let check_inconsistency_base tenv prop =
let pi = prop.Prop.pi in
let sigma = prop.Prop.sigma in
let inconsistent_ptsto _ =
check_allocatedness prop Exp.zero in
check_allocatedness tenv prop Exp.zero in
let inconsistent_this_self_var () =
let procdesc =
Cfg.Node.get_proc_desc (State.get_node ()) in
@ -876,14 +876,14 @@ let check_inconsistency_base prop =
| Sil.Aeq (e1, e2) ->
(match e1, e2 with
| Exp.Const c1, Exp.Const c2 -> not (Const.equal c1 c2)
| _ -> check_disequal prop e1 e2)
| _ -> check_disequal tenv prop e1 e2)
| Sil.Aneq (e1, e2) ->
(match e1, e2 with
| Exp.Const c1, Exp.Const c2 -> Const.equal c1 c2
| _ -> (Exp.compare e1 e2 = 0))
| Sil.Apred _ | Anpred _ -> false in
let inconsistent_inequalities () =
let ineq = Inequalities.from_prop prop in
let ineq = Inequalities.from_prop tenv prop in
(*
L.d_strln "Inequalities:";
L.d_strln "Prop: "; Prop.d_prop prop; L.d_ln ();
@ -893,20 +893,20 @@ let check_inconsistency_base prop =
*)
Inequalities.inconsistent ineq in
inconsistent_ptsto ()
|| check_inconsistency_two_hpreds prop
|| check_inconsistency_two_hpreds tenv prop
|| IList.exists inconsistent_atom pi
|| inconsistent_inequalities ()
|| inconsistent_this_self_var ()
(** Inconsistency checking. *)
let check_inconsistency prop =
(check_inconsistency_base prop)
let check_inconsistency tenv prop =
(check_inconsistency_base tenv prop)
||
(check_inconsistency_base (Prop.normalize (Prop.extract_footprint prop)))
(check_inconsistency_base tenv (Prop.normalize tenv (Prop.extract_footprint prop)))
(** Inconsistency checking for the pi part ignoring footprint. *)
let check_inconsistency_pi pi =
check_inconsistency_base (Prop.normalize (Prop.from_pi pi))
let check_inconsistency_pi tenv pi =
check_inconsistency_base tenv (Prop.normalize tenv (Prop.from_pi pi))
(** {2 Abduction prover} *)
@ -1135,9 +1135,9 @@ let extend_sub sub v e =
(** Extend [sub1] and [sub2] to witnesses that each instance of
[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
let exp_imply tenv calc_missing subs e1_in e2_in : subst2 =
let e1 = Prop.exp_normalize_noabs tenv (fst subs) e1_in in
let e2 = Prop.exp_normalize_noabs tenv (snd subs) e2_in in
let var_imply subs v1 v2 : subst2 =
match Ident.is_primed v1, Ident.is_primed v2 with
| false, false ->
@ -1164,7 +1164,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
| e1, Exp.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 tenv 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
@ -1176,7 +1176,7 @@ let exp_imply calc_missing subs e1_in e2_in : subst2 =
| e1, Exp.BinOp (Binop.PlusA, e2, Exp.Var v2)
when Ident.is_primed v2 || Ident.is_footprint v2 ->
let e' = Exp.BinOp (Binop.MinusA, e1, e2) in
do_imply subs (Prop.exp_normalize_noabs Sil.sub_empty e') (Exp.Var v2)
do_imply subs (Prop.exp_normalize_noabs tenv Sil.sub_empty e') (Exp.Var v2)
| Exp.Var _, e2 ->
if calc_missing then
let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in
@ -1247,13 +1247,13 @@ let path_to_id path =
| Some s -> Ident.create_path s
(** Implication for the length of arrays *)
let array_len_imply calc_missing subs len1 len2 indices2 =
let array_len_imply tenv calc_missing subs len1 len2 indices2 =
match len1, len2 with
| _, Exp.Var _
| _, Exp.BinOp (Binop.PlusA, Exp.Var _, _)
| _, Exp.BinOp (Binop.PlusA, _, Exp.Var _)
| Exp.BinOp (Binop.Mult, _, _), _ ->
(try exp_imply calc_missing subs len1 len2 with
(try exp_imply tenv calc_missing subs len1 len2 with
| IMPL_EXC (s, subs', x) ->
raise (IMPL_EXC ("array len:" ^ s, subs', x)))
| _ ->
@ -1263,14 +1263,14 @@ let array_len_imply calc_missing subs len1 len2 indices2 =
(** Extend [sub1] and [sub2] to witnesses that each instance of
[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) =
let rec sexp_imply tenv 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 " : "; Typ.d_full typ2; L.d_ln(); *)
match se1, se2 with
| Sil.Eexp (e1, _), Sil.Eexp (e2, _) ->
(exp_imply calc_missing subs e1 e2, None, None)
(exp_imply tenv calc_missing subs e1 e2, None, None)
| Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) ->
let subs', fld_frame, fld_missing = struct_imply source calc_missing subs fsel1 fsel2 typ2 in
let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 in
let fld_frame_opt = if fld_frame != [] then Some (Sil.Estruct (fld_frame, inst1)) else None in
let fld_missing_opt = if fld_missing != [] then Some (Sil.Estruct (fld_missing, inst1)) else None in
subs', fld_frame_opt, fld_missing_opt
@ -1288,9 +1288,9 @@ let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subs
end
| Sil.Earray (len1, esel1, inst1), Sil.Earray (len2, esel2, _) ->
let indices2 = IList.map fst esel2 in
let subs' = array_len_imply calc_missing subs len1 len2 indices2 in
let subs' = array_len_imply tenv calc_missing subs len1 len2 indices2 in
let subs'', index_frame, index_missing =
array_imply source calc_index_frame calc_missing subs' esel1 esel2 typ2 in
array_imply tenv source calc_index_frame calc_missing subs' esel1 esel2 typ2 in
let index_frame_opt = if index_frame != []
then Some (Sil.Earray (len1, index_frame, inst1))
else None in
@ -1305,11 +1305,11 @@ let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subs
let fsel' =
let g (f, _) = (f, Sil.Eexp (Exp.Var (Ident.create_fresh Ident.knormal), inst)) in
IList.map g fsel in
sexp_imply source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 typ2
sexp_imply tenv source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 typ2
| Sil.Eexp _, Sil.Earray (len, _, inst)
| Sil.Estruct _, Sil.Earray (len, _, inst) ->
let se1' = Sil.Earray (len, [(Exp.zero, se1)], inst) in
sexp_imply source calc_index_frame calc_missing subs se1' se2 typ2
sexp_imply tenv source calc_index_frame calc_missing subs se1' se2 typ2
| Sil.Earray (len, _, _), Sil.Eexp (_, inst) ->
let se2' = Sil.Earray (len, [(Exp.zero, se2)], inst) in
let typ2' = Typ.Tarray (typ2, None) in
@ -1317,12 +1317,12 @@ let rec sexp_imply source calc_index_frame calc_missing subs se1 se2 typ2 : subs
argument is only used by eventually passing its value to Typ.struct_typ_fld, Exp.Lfield,
Typ.struct_typ_fld, or Typ.array_elem. None of these are sensitive to the length field
of Tarray, so forgetting the length of typ2' here is not a problem. *)
sexp_imply source true calc_missing subs se1 se2' typ2' (* calculate index_frame because the rhs is a singleton array *)
sexp_imply tenv source true calc_missing subs se1 se2' typ2' (* calculate index_frame because the rhs is a singleton array *)
| _ ->
d_impl_err ("sexp_imply not implemented", subs, (EXC_FALSE_SEXPS (se1, se2)));
raise (Exceptions.Abduction_case_not_implemented __POS__)
and struct_imply source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Ident.fieldname * Sil.strexp) list) * ((Ident.fieldname * Sil.strexp) list) =
and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Ident.fieldname * Sil.strexp) list) * ((Ident.fieldname * Sil.strexp) list) =
match fsel1, fsel2 with
| _, [] -> subs, fsel1, []
| (f1, se1) :: fsel1', (f2, se2) :: fsel2' ->
@ -1331,8 +1331,8 @@ and struct_imply source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Ident.fi
| 0 ->
let typ' = Typ.struct_typ_fld (Some Typ.Tvoid) f2 typ2 in
let subs', se_frame, se_missing =
sexp_imply (Exp.Lfield (source, f2, typ2)) false calc_missing subs se1 se2 typ' in
let subs'', fld_frame, fld_missing = struct_imply source calc_missing subs' fsel1' fsel2' typ2 in
sexp_imply tenv (Exp.Lfield (source, f2, typ2)) false calc_missing subs se1 se2 typ' in
let subs'', fld_frame, fld_missing = struct_imply tenv source calc_missing subs' fsel1' fsel2' typ2 in
let fld_frame' = match se_frame with
| None -> fld_frame
| Some se -> (f1, se):: fld_frame in
@ -1341,45 +1341,45 @@ and struct_imply source calc_missing subs fsel1 fsel2 typ2 : subst2 * ((Ident.fi
| Some se -> (f1, se):: fld_missing in
subs'', fld_frame', fld_missing'
| n when n < 0 ->
let subs', fld_frame, fld_missing = struct_imply source calc_missing subs fsel1' fsel2 typ2 in
let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1' fsel2 typ2 in
subs', ((f1, se1) :: fld_frame), fld_missing
| _ ->
let typ' = Typ.struct_typ_fld (Some Typ.Tvoid) f2 typ2 in
let subs' =
sexp_imply_nolhs (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in
let subs', fld_frame, fld_missing = struct_imply source calc_missing subs' fsel1 fsel2' typ2 in
sexp_imply_nolhs tenv (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in
let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs' fsel1 fsel2' typ2 in
let fld_missing' = (f2, se2) :: fld_missing in
subs', fld_frame, fld_missing'
end
| [], (f2, se2) :: fsel2' ->
let typ' = Typ.struct_typ_fld (Some Typ.Tvoid) f2 typ2 in
let subs' = sexp_imply_nolhs (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in
let subs'', fld_frame, fld_missing = struct_imply source calc_missing subs' [] fsel2' typ2 in
let subs' = sexp_imply_nolhs tenv (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in
let subs'', fld_frame, fld_missing = struct_imply tenv source calc_missing subs' [] fsel2' typ2 in
subs'', fld_frame, (f2, se2):: fld_missing
and array_imply source calc_index_frame calc_missing subs esel1 esel2 typ2
and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2
: subst2 * ((Exp.t * Sil.strexp) list) * ((Exp.t * Sil.strexp) list)
=
let typ_elem = Typ.array_elem (Some Typ.Tvoid) typ2 in
match esel1, esel2 with
| _,[] -> subs, esel1, []
| (e1, se1) :: esel1', (e2, se2) :: esel2' ->
let e1n = Prop.exp_normalize_noabs (fst subs) e1 in
let e2n = Prop.exp_normalize_noabs (snd subs) e2 in
let e1n = Prop.exp_normalize_noabs tenv (fst subs) e1 in
let e2n = Prop.exp_normalize_noabs tenv (snd subs) e2 in
let n = Exp.compare e1n e2n in
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
if n < 0 then array_imply tenv source calc_index_frame calc_missing subs esel1' esel2 typ2
else if n > 0 then array_imply tenv source calc_index_frame calc_missing subs esel1 esel2' typ2
else (* n=0 *)
let subs', _, _ =
sexp_imply (Exp.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in
array_imply source calc_index_frame calc_missing subs' esel1' esel2' typ2
sexp_imply tenv (Exp.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in
array_imply tenv source calc_index_frame calc_missing subs' esel1' esel2' typ2
| [], (e2, se2) :: esel2' ->
let subs' = sexp_imply_nolhs (Exp.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
let subs' = sexp_imply_nolhs tenv (Exp.Lindex (source, e2)) calc_missing subs se2 typ_elem in
let subs'', index_frame, index_missing = array_imply tenv source calc_index_frame calc_missing subs' [] esel2' typ2 in
let index_missing' = (e2, se2) :: index_missing in
subs'', index_frame, index_missing'
and sexp_imply_nolhs source calc_missing subs se2 typ2 =
and sexp_imply_nolhs tenv source calc_missing subs se2 typ2 =
match se2 with
| Sil.Eexp (_e2, _) ->
let e2 = Sil.exp_sub (snd subs) _e2 in
@ -1402,14 +1402,14 @@ and sexp_imply_nolhs source calc_missing subs se2 typ2 =
raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE))
end
| Sil.Estruct (fsel2, _) ->
(fun (x, _, _) -> x) (struct_imply source calc_missing subs [] fsel2 typ2)
(fun (x, _, _) -> x) (struct_imply tenv source calc_missing subs [] fsel2 typ2)
| Sil.Earray (_, esel2, _) ->
(fun (x, _, _) -> x) (array_imply source false calc_missing subs [] esel2 typ2)
(fun (x, _, _) -> x) (array_imply tenv source false calc_missing subs [] esel2 typ2)
let rec exp_list_imply calc_missing subs l1 l2 = match l1, l2 with
let rec exp_list_imply tenv calc_missing subs l1 l2 = match l1, l2 with
| [],[] -> subs
| e1:: l1, e2:: l2 ->
exp_list_imply calc_missing (exp_imply calc_missing subs e1 e2) l1 l2
exp_list_imply tenv calc_missing (exp_imply tenv calc_missing subs e1 e2) l1 l2
| _ -> assert false
let filter_ne_lhs sub e0 = function
@ -1462,7 +1462,7 @@ let move_primed_lhs_from_front subs sigma = match sigma with
(** [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. *)
let expand_hpred_pointer calc_index_frame hpred : bool * bool * Sil.hpred =
let expand_hpred_pointer _tenv calc_index_frame hpred : bool * bool * Sil.hpred =
let rec expand changed calc_index_frame hpred = match hpred with
| Sil.Hpointsto (Lfield (adr_base, fld, adr_typ), cnt, cnt_texp) ->
let cnt_texp' = match adr_typ, cnt_texp with
@ -1577,7 +1577,7 @@ struct
(** check if t1 is a subtype of t2 *)
let check_subtype tenv t1 t2 =
if is_java_class t1
if is_java_class tenv t1
then
check_subtype_java tenv t1 t2
else
@ -1609,7 +1609,7 @@ struct
else None, Some st1
let case_analysis_type tenv (t1, st1) (t2, st2) =
if is_java_class t1 then
if is_java_class tenv t1 then
case_analysis_type_java tenv (t1, st1) (t2, st2)
else match get_type_name t1, get_type_name t2 with
| Some cn1, Some cn2 ->
@ -1692,7 +1692,7 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing =
| Exp.Sizeof ((Typ.Tarray _) as typ1, _, _), Exp.Sizeof (Typ.Tarray _, _, _)
| Exp.Sizeof ((Typ.Tarray _) as typ1, _, _), Exp.Sizeof (Typ.Tstruct _, _, _)
| Exp.Sizeof ((Typ.Tstruct _) as typ1, _, _), Exp.Sizeof (Typ.Tarray _, _, _)
when is_java_class typ1 -> true
when is_java_class tenv typ1 -> true
| Exp.Sizeof (typ1, _, _), Exp.Sizeof (typ2, _, _) ->
(Typ.is_cpp_class typ1 && Typ.is_cpp_class typ2) ||
@ -1793,13 +1793,13 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
(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
(match Prop.prop_iter_current tenv iter1' with
| Sil.Hpointsto (e1, se1, texp1), _ ->
(try
let typ2 = Exp.texp_to_typ (Some Typ.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
let subs', fld_frame, fld_missing = sexp_imply tenv 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);
@ -1820,7 +1820,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
ProverState.add_frame_typ (e1, t_frame)
| None -> ())
end;
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1'
in (subs', prop1')
with
| IMPL_EXC (s, _, _) when calc_missing ->
@ -1828,36 +1828,36 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> (* Unroll lseg *)
let n' = Exp.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 hpred_list1 = para_inst1@[Prop.mk_lseg tenv 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
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop tenv iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Exp.equal (Sil.exp_sub (fst subs) iF1) e2 -> (* Unroll dllseg forward *)
let n' = Exp.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 hpred_list1 = para_inst1@[Prop.mk_dllseg tenv 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
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop tenv iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _
when Exp.equal (Sil.exp_sub (fst subs) iB1) e2 -> (* Unroll dllseg backward *)
let n' = Exp.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 hpred_list1 = para_inst1@[Prop.mk_dllseg tenv 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
(fun () -> hpred_imply tenv calc_index_frame calc_missing subs (Prop.prop_iter_to_prop tenv iter1'') sigma2 hpred2) in
L.d_decrease_indent 1;
res
| _ -> assert false
@ -1892,9 +1892,9 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Some iter1' ->
let elist2 = IList.map (fun e -> Sil.exp_sub (snd subs) e) _elist2 in
(* force instantiation of existentials *)
let subs' = exp_list_imply calc_missing subs (f2:: elist2) (f2:: elist2) in
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1' in
let hpred1 = match Prop.prop_iter_current iter1' with
let subs' = exp_list_imply tenv calc_missing subs (f2:: elist2) (f2:: elist2) in
let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in
let hpred1 = match Prop.prop_iter_current tenv iter1' with
| hpred1, b ->
if b then ProverState.add_missing_pi (Sil.Aneq(_e2, _f2)); (* for PE |- NE *)
hpred1
@ -1903,7 +1903,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
| Sil.Hpointsto _ -> (* unroll rhs list and try again *)
let n' = Exp.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
let hpred_list2 = para_inst2@[Prop.mk_lseg tenv Sil.Lseg_PE para2 n' _f2 _elist2] in
L.d_increase_indent 1;
let res =
decrease_indent_when_exception
@ -1962,9 +1962,9 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2
let elist2 = IList.map (fun e -> Sil.exp_sub (snd subs) e) elist2 in
(* force instantiation of existentials *)
let subs' =
exp_list_imply calc_missing subs
exp_list_imply tenv calc_missing subs
(iF2:: oB2:: oF2:: iB2:: elist2) (iF2:: oB2:: oF2:: iB2:: elist2) in
let prop1' = Prop.prop_iter_remove_curr_then_to_prop iter1'
let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1'
in (subs', prop1')
)
)
@ -2032,7 +2032,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
(subs, prop1)
| hpred2 :: sigma2' ->
L.d_strln "Current Implication";
d_impl subs (prop1, Prop.normalize (Prop.from_sigma (hpred2 :: sigma2')));
d_impl subs (prop1, Prop.normalize tenv (Prop.from_sigma (hpred2 :: sigma2')));
L.d_ln ();
L.d_ln ();
let normal_case hpred2' =
@ -2050,7 +2050,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
| 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.set prop1 ~sigma:(hpred1' :: prop1.Prop.sigma)) in
Prop.normalize tenv (Prop.set prop1 ~sigma:(hpred1' :: prop1.Prop.sigma)) 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
@ -2058,7 +2058,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
let subs' = match hpred2' with
| Sil.Hpointsto (e2, se2, te2) ->
let typ2 = Exp.texp_to_typ (Some Typ.Tvoid) te2 in
sexp_imply_nolhs e2 calc_missing subs se2 typ2
sexp_imply_nolhs tenv e2 calc_missing subs se2 typ2
| _ -> subs in
ProverState.add_missing_sigma [hpred2'];
subs', prop1
@ -2071,7 +2071,7 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
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
let changed, calc_index_frame', hpred2' = expand_hpred_pointer tenv calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs tenv (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'
@ -2082,17 +2082,17 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : (subst2 *
ProverState.add_missing_sigma sigma2;
subs, prop1
let prepare_prop_for_implication (_, sub2) pi1 sigma1 =
let prepare_prop_for_implication tenv (_, sub2) pi1 sigma1 =
let pi1' = (Prop.pi_sub sub2 (ProverState.get_missing_pi ())) @ pi1 in
let sigma1' = (Prop.sigma_sub sub2 (ProverState.get_missing_sigma ())) @ sigma1 in
let ep = Prop.set Prop.prop_emp ~sub:sub2 ~sigma:sigma1' ~pi:pi1' in
Prop.normalize ep
Prop.normalize tenv ep
let imply_pi calc_missing (sub1, sub2) prop pi2 =
let imply_pi tenv calc_missing (sub1, sub2) prop pi2 =
let do_atom a =
let a' = Sil.atom_sub sub2 a in
try
if not (check_atom prop a')
if not (check_atom tenv prop a')
then raise (IMPL_EXC ("rhs atom missing in lhs", (sub1, sub2), (EXC_FALSE_ATOM a')))
with
| IMPL_EXC _ when calc_missing ->
@ -2100,55 +2100,55 @@ let imply_pi calc_missing (sub1, sub2) prop pi2 =
ProverState.add_missing_pi a in
IList.iter do_atom pi2
let imply_atom calc_missing (sub1, sub2) prop a =
imply_pi calc_missing (sub1, sub2) prop [a]
let imply_atom tenv calc_missing (sub1, sub2) prop a =
imply_pi tenv 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. *)
let rec pre_check_pure_implication calc_missing subs pi1 pi2 =
let rec pre_check_pure_implication tenv calc_missing subs pi1 pi2 =
match pi2 with
| [] -> subs
| (Sil.Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) ->
let e2, f2 = Sil.exp_sub (snd subs) e2_in, Sil.exp_sub (snd subs) f2_in in
if Exp.equal e2 f2 then pre_check_pure_implication calc_missing subs pi1 pi2'
if Exp.equal e2 f2 then pre_check_pure_implication tenv calc_missing subs pi1 pi2'
else
(match e2, f2 with
| Exp.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'
pre_check_pure_implication tenv calc_missing (fst subs, sub2') pi1 pi2'
| e2, Exp.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'
pre_check_pure_implication tenv calc_missing (fst subs, sub2') pi1 pi2'
| _ ->
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'
let prop_for_impl = prepare_prop_for_implication tenv subs pi1' [] in
imply_atom tenv calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in));
pre_check_pure_implication tenv calc_missing subs pi1 pi2'
)
| (Sil.Aneq (e, _) | Apred (_, e :: _) | Anpred (_, e :: _)) :: _
when not calc_missing && (match e with Var v -> not (Ident.is_primed v) | _ -> true) ->
raise (IMPL_EXC ("ineq e2=f2 in rhs with e2 not primed var",
(Sil.sub_empty, Sil.sub_empty), EXC_FALSE))
| (Sil.Aeq _ | Aneq _ | Apred _ | Anpred _) :: pi2' ->
pre_check_pure_implication calc_missing subs pi1 pi2'
pre_check_pure_implication tenv calc_missing subs pi1 pi2'
(** 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. *)
let check_array_bounds (sub1, sub2) prop =
let check_array_bounds tenv (sub1, sub2) prop =
let check_failed atom =
ProverState.checks := Bounds_check :: !ProverState.checks;
L.d_str_color Red "bounds_check failed: provable atom: "; Sil.d_atom atom; L.d_ln();
if (not Config.bound_error_allowed_in_procedure_call) then
raise (IMPL_EXC ("bounds check", (sub1, sub2), EXC_FALSE)) in
let fail_if_le e' e'' =
let lt_ineq = Prop.mk_inequality (Exp.BinOp(Binop.Le, e', e'')) in
if check_atom prop lt_ineq then check_failed lt_ineq in
let lt_ineq = Prop.mk_inequality tenv (Exp.BinOp(Binop.Le, e', e'')) in
if check_atom tenv prop lt_ineq then check_failed lt_ineq in
let check_bound = function
| ProverState.BClen_imply (len1_, len2_, _indices2) ->
let len1 = Sil.exp_sub sub1 len1_ in
@ -2159,9 +2159,9 @@ let check_array_bounds (sub1, sub2) prop =
| _ -> [Exp.BinOp(Binop.PlusA, len2, Exp.minus_one)] (* only check len *) in
IList.iter (fail_if_le len1) indices_to_check
| ProverState.BCfrom_pre _atom ->
let atom_neg = atom_negate (Sil.atom_sub sub2 _atom) in
let atom_neg = atom_negate tenv (Sil.atom_sub sub2 _atom) in
(* L.d_strln_color Orange "BCFrom_pre"; Sil.d_atom atom_neg; L.d_ln (); *)
if check_atom prop atom_neg then check_failed atom_neg in
if check_atom tenv prop atom_neg then check_failed atom_neg in
IList.iter check_bound (ProverState.get_bounds_checks ())
(** [check_implication_base] returns true if [prop1|-prop2],
@ -2175,7 +2175,7 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2
Sil.sub_filter_pair filter prop1.Prop.sub in
let pi1, pi2 = Prop.get_pure prop1, Prop.get_pure prop2 in
let sigma1, sigma2 = prop1.Prop.sigma, prop2.Prop.sigma in
let subs = pre_check_pure_implication calc_missing (prop1.Prop.sub, sub1_base) pi1 pi2 in
let subs = pre_check_pure_implication tenv calc_missing (prop1.Prop.sub, sub1_base) pi1 pi2 in
let pi2_bcheck, pi2_nobcheck = (* find bounds checks implicit in pi2 *)
IList.partition ProverState.atom_is_array_bounds_check pi2 in
IList.iter (fun a -> ProverState.add_bounds_check (ProverState.BCfrom_pre a)) pi2_bcheck;
@ -2195,11 +2195,11 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2
let pi1' = Prop.pi_sub sub1 pi1 in
let sigma1' = Prop.sigma_sub sub1 sigma1 in
L.d_ln ();
let prop_for_impl = prepare_prop_for_implication (sub1, sub2) pi1' sigma1' in
let prop_for_impl = prepare_prop_for_implication tenv (sub1, sub2) pi1' sigma1' in
(* only deal with pi2 without bound checks *)
imply_pi calc_missing (sub1, sub2) prop_for_impl pi2_nobcheck;
imply_pi tenv calc_missing (sub1, sub2) prop_for_impl pi2_nobcheck;
(* handle implicit bound checks, plus those from array_len_imply *)
check_array_bounds (sub1, sub2) prop_for_impl;
check_array_bounds tenv (sub1, sub2) prop_for_impl;
L.d_strln "Result of Abduction";
L.d_increase_indent 1; d_impl (sub1, sub2) (prop1, prop2); L.d_decrease_indent 1; L.d_ln ();
L.d_strln"returning TRUE";
@ -2244,12 +2244,12 @@ let check_implication pname tenv p1 p2 =
| Some _ -> true
| None -> false in
check p1 p2 &&
(if !Config.footprint then check (Prop.normalize (Prop.extract_footprint p1)) (Prop.extract_footprint p2) else true)
(if !Config.footprint then check (Prop.normalize tenv (Prop.extract_footprint p1)) (Prop.extract_footprint p2) else true)
(** {2 Cover: miminum set of pi's whose disjunction is equivalent to true} *)
(** check if the pi's in [cases] cover true *)
let is_cover cases =
let is_cover tenv cases =
let cnt = ref 0 in (* counter for timeout checks, as this function can take exponential time *)
let check () =
incr cnt;
@ -2257,27 +2257,27 @@ let is_cover cases =
let rec _is_cover acc_pi cases =
check ();
match cases with
| [] -> check_inconsistency_pi acc_pi
| [] -> check_inconsistency_pi tenv acc_pi
| (pi, _):: cases' ->
IList.for_all (fun a -> _is_cover ((atom_negate a) :: acc_pi) cases') pi in
IList.for_all (fun a -> _is_cover ((atom_negate tenv a) :: acc_pi) cases') pi in
_is_cover [] cases
exception NO_COVER
(** Find miminum set of pi's in [cases] whose disjunction covers true *)
let find_minimum_pure_cover cases =
let find_minimum_pure_cover tenv cases =
let cases =
let compare (pi1, _) (pi2, _) = int_compare (IList.length pi1) (IList.length pi2)
in IList.sort compare cases in
let rec grow seen todo = match todo with
| [] -> raise NO_COVER
| (pi, x):: todo' ->
if is_cover ((pi, x):: seen) then (pi, x):: seen
if is_cover tenv ((pi, x):: seen) then (pi, x):: seen
else grow ((pi, x):: seen) todo' in
let rec _shrink seen todo = match todo with
| [] -> seen
| (pi, x):: todo' ->
if is_cover (seen @ todo') then _shrink seen todo'
if is_cover tenv (seen @ todo') then _shrink seen todo'
else _shrink ((pi, x):: seen) todo' in
let shrink cases =
if IList.length cases > 2 then _shrink [] cases

@ -15,20 +15,20 @@ open! Utils
open Sil
(** Negate an atom *)
val atom_negate : Sil.atom -> Sil.atom
val atom_negate : Tenv.t -> Sil.atom -> Sil.atom
(** {2 Ordinary Theorem Proving} *)
(** Check [ |- e=0]. Result [false] means "don't know". *)
val check_zero : Exp.t -> bool
val check_zero : Tenv.t -> Exp.t -> bool
(** Check [prop |- exp1=exp2]. Result [false] means "don't know". *)
val check_equal : Prop.normal Prop.t -> Exp.t -> Exp.t -> bool
val check_equal : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Exp.t -> bool
(** Check whether [prop |- exp1!=exp2]. Result [false] means "don't know". *)
val check_disequal : Prop.normal Prop.t -> Exp.t -> Exp.t -> bool
val check_disequal : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Exp.t -> bool
val check_le : Prop.normal Prop.t -> Exp.t -> Exp.t -> bool
val check_le : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Exp.t -> bool
(** Return true if the two types have sizes which can be compared *)
val type_size_comparable : Typ.t -> Typ.t -> bool
@ -40,29 +40,29 @@ val check_type_size_leq : Typ.t -> Typ.t -> bool
val check_type_size_lt : Typ.t -> Typ.t -> bool
(** Check whether [prop |- a]. Result [false] means "don't know". *)
val check_atom : Prop.normal Prop.t -> atom -> bool
val check_atom : Tenv.t -> Prop.normal Prop.t -> atom -> bool
(** Inconsistency checking ignoring footprint. *)
val check_inconsistency_base : Prop.normal Prop.t -> bool
val check_inconsistency_base : Tenv.t -> Prop.normal Prop.t -> bool
(** Inconsistency checking. *)
val check_inconsistency : Prop.normal Prop.t -> bool
val check_inconsistency : Tenv.t -> Prop.normal Prop.t -> bool
(** Check whether [prop |- allocated(exp)]. *)
val check_allocatedness : Prop.normal Prop.t -> Exp.t -> bool
val check_allocatedness : Tenv.t -> Prop.normal Prop.t -> Exp.t -> bool
(** [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. *)
val is_root : Prop.normal Prop.t -> Exp.t -> Exp.t -> offset list option
val is_root : Tenv.t -> Prop.normal Prop.t -> Exp.t -> Exp.t -> offset list option
(** [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. *)
val expand_hpred_pointer : bool -> Sil.hpred -> bool * bool * Sil.hpred
val expand_hpred_pointer : Tenv.t -> bool -> Sil.hpred -> bool * bool * Sil.hpred
(** Get upper and lower bounds of an expression, if any *)
val get_bounds : Prop.normal Prop.t -> Exp.t -> IntLit.t option * IntLit.t option
val get_bounds : Tenv.t -> Prop.normal Prop.t -> Exp.t -> IntLit.t option * IntLit.t option
(** {2 Abduction prover} *)
@ -91,12 +91,12 @@ val check_implication_for_footprint :
(** {2 Cover: miminum set of pi's whose disjunction is equivalent to true} *)
(** Find miminum set of pi's in [cases] whose disjunction covers true *)
val find_minimum_pure_cover : (Sil.atom list * 'a) list -> (Sil.atom list * 'a) list option
val find_minimum_pure_cover : Tenv.t -> (Sil.atom list * 'a) list -> (Sil.atom list * 'a) list option
(** {2 Compute various lower or upper bounds} *)
(** Computer an upper bound of an expression *)
val compute_upper_bound_of_exp : Prop.normal Prop.t -> Exp.t -> IntLit.t option
val compute_upper_bound_of_exp : Tenv.t -> Prop.normal Prop.t -> Exp.t -> IntLit.t option
(** {2 Subtype checking} *)

@ -32,22 +32,22 @@ let rec list_rev_and_concat l1 l2 =
If the index is provably out of bound, a bound error is given.
If the length is a constant and the index is not provably in bound, a warning is given.
*)
let check_bad_index pname p len index loc =
let check_bad_index tenv pname p len index loc =
let len_is_constant = match len with
| Exp.Const _ -> true
| _ -> false in
let index_provably_out_of_bound () =
let index_too_large = Prop.mk_inequality (Exp.BinOp (Binop.Le, len, index)) in
let index_negative = Prop.mk_inequality (Exp.BinOp (Binop.Le, index, Exp.minus_one)) in
(Prover.check_atom p index_too_large) || (Prover.check_atom p index_negative) in
let index_too_large = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, len, index)) in
let index_negative = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, index, Exp.minus_one)) in
(Prover.check_atom tenv p index_too_large) || (Prover.check_atom tenv p index_negative) in
let index_provably_in_bound () =
let len_minus_one = Exp.BinOp(Binop.PlusA, len, Exp.minus_one) in
let index_not_too_large = Prop.mk_inequality (Exp.BinOp(Binop.Le, index, len_minus_one)) in
let index_nonnegative = Prop.mk_inequality (Exp.BinOp(Binop.Le, Exp.zero, index)) in
Prover.check_zero index || (* index 0 always in bound, even when we know nothing about len *)
((Prover.check_atom p index_not_too_large) && (Prover.check_atom p index_nonnegative)) in
let index_not_too_large = Prop.mk_inequality tenv (Exp.BinOp(Binop.Le, index, len_minus_one)) in
let index_nonnegative = Prop.mk_inequality tenv (Exp.BinOp(Binop.Le, Exp.zero, index)) in
Prover.check_zero tenv index || (* index 0 always in bound, even when we know nothing about len *)
((Prover.check_atom tenv p index_not_too_large) && (Prover.check_atom tenv p index_nonnegative)) in
let index_has_bounds () =
match Prover.get_bounds p index with
match Prover.get_bounds tenv p index with
| Some _, Some _ -> true
| _ -> false in
let get_const_opt = function
@ -61,12 +61,12 @@ let check_bad_index pname p len index loc =
let deref_str = Localise.deref_str_array_bound len_const_opt index_const_opt in
let exn =
Exceptions.Array_out_of_bounds_l1
(Errdesc.explain_array_access deref_str p loc, __POS__) in
(Errdesc.explain_array_access tenv deref_str p loc, __POS__) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ?pre:pre_opt exn
else if len_is_constant then
let deref_str = Localise.deref_str_array_bound len_const_opt index_const_opt in
let desc = Errdesc.explain_array_access deref_str p loc in
let desc = Errdesc.explain_array_access tenv deref_str p loc in
let exn = if index_has_bounds ()
then Exceptions.Array_out_of_bounds_l2 (desc, __POS__)
else Exceptions.Array_out_of_bounds_l3 (desc, __POS__) in
@ -75,14 +75,14 @@ let check_bad_index pname p len index loc =
end
(** Perform bounds checking *)
let bounds_check pname prop len e =
let bounds_check tenv pname prop len e =
if Config.trace_rearrange then
begin
L.d_str "Bounds check index:"; Sil.d_exp e;
L.d_str " len: "; Sil.d_exp len;
L.d_ln()
end;
check_bad_index pname prop len e
check_bad_index tenv pname prop len e
let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp t
(off: Sil.offset list) inst : Sil.atom list * Sil.strexp * Typ.t =
@ -134,7 +134,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp
| [] ->
([], Sil.Earray (len, [], inst), t)
| (Sil.Off_index e) :: off' ->
bounds_check pname orig_prop len e (State.get_loc ());
bounds_check tenv pname orig_prop len e (State.get_loc ());
let atoms', se', res_t' =
create_struct_values
pname tenv orig_prop footprint_part kind max_stamp t' off' inst in
@ -260,7 +260,7 @@ let rec _strexp_extend_values
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst
| (Sil.Off_index e) :: off', Sil.Earray (len, esel, inst_arr), Typ.Tarray (typ', len_for_typ') ->
bounds_check pname orig_prop len e (State.get_loc ());
bounds_check tenv pname orig_prop len e (State.get_loc ());
begin
try
let _, se' = IList.find (fun (e', _) -> Exp.equal e e') esel in
@ -298,7 +298,7 @@ and array_case_analysis_index pname tenv orig_prop
if not (Typ.equal typ_cont t' || array_cont == [])
then raise (Exceptions.Bad_footprint __POS__) in
let index_in_array =
IList.exists (fun (i, _) -> Prover.check_equal Prop.prop_emp index i) array_cont in
IList.exists (fun (i, _) -> Prover.check_equal tenv Prop.prop_emp index i) array_cont in
let array_is_full =
match array_len with
| Exp.Const (Const.Cint n') -> IntLit.geq (IntLit.of_int (IList.length array_cont)) n'
@ -387,7 +387,7 @@ let strexp_extend_values
let off', eqs = laundry_offset_for_footprint max_stamp off in
(* do laundry_offset whether footprint_part is true or not, so max_stamp is modified anyway *)
if footprint_part then
off', IList.map (fun (id, e) -> Prop.mk_eq (Exp.Var id) e) eqs
off', IList.map (fun (id, e) -> Prop.mk_eq tenv (Exp.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: ";
@ -397,7 +397,7 @@ let strexp_extend_values
_strexp_extend_values
pname tenv orig_prop footprint_part kind max_stamp se typ off' inst in
let atoms_se_typ_list_filtered =
let check_neg_atom atom = Prover.check_atom Prop.prop_emp (Prover.atom_negate atom) in
let check_neg_atom atom = Prover.check_atom tenv Prop.prop_emp (Prover.atom_negate tenv atom) in
let check_not_inconsistent (atoms, _, _) = not (IList.exists check_neg_atom atoms) in
IList.filter check_not_inconsistent atoms_se_typ_list in
if Config.trace_rearrange then L.d_strln "exiting strexp_extend_values";
@ -426,7 +426,7 @@ let mk_ptsto_exp_footprint
L.err "!!!! Footprint Error, Bad Root : %a !!!! @\n" (Sil.pp_exp pe_text) lexp;
let deref_str = Localise.deref_str_dangling None in
let err_desc =
Errdesc.explain_dereference deref_str orig_prop (State.get_loc ()) in
Errdesc.explain_dereference tenv deref_str orig_prop (State.get_loc ()) in
raise
(Exceptions.Dangling_pointer_dereference
(None, err_desc, __POS__))
@ -440,29 +440,29 @@ let mk_ptsto_exp_footprint
| Exp.Lvar pvar, [], Typ.Tfun _ ->
let fun_name = Procname.from_string_c_fun (Mangled.to_string (Pvar.get_name pvar)) in
let fun_exp = Exp.Const (Const.Cfun fun_name) in
([], Prop.mk_ptsto root (Sil.Eexp (fun_exp, inst)) (Exp.Sizeof (typ, None, st)))
([], Prop.mk_ptsto tenv root (Sil.Eexp (fun_exp, inst)) (Exp.Sizeof (typ, None, st)))
| _, [], Typ.Tfun _ ->
let atoms, se, t =
create_struct_values
pname tenv orig_prop footprint_part Ident.kfootprint max_stamp typ off0 inst in
(atoms, Prop.mk_ptsto root se (Exp.Sizeof (t, None, st)))
(atoms, Prop.mk_ptsto tenv root se (Exp.Sizeof (t, None, st)))
| _ ->
let atoms, se, t =
create_struct_values
pname tenv orig_prop footprint_part Ident.kfootprint max_stamp typ off0 inst in
(atoms, Prop.mk_ptsto root se (Exp.Sizeof (t, None, st))) in
(atoms, Prop.mk_ptsto tenv root se (Exp.Sizeof (t, None, st))) in
let atoms, ptsto_foot = create_ptsto true off_foot in
let sub = Sil.sub_of_list eqs in
let ptsto = Sil.hpred_sub sub ptsto_foot in
let atoms' = IList.map (fun (id, e) -> Prop.mk_eq (Exp.Var id) e) eqs in
let atoms' = IList.map (fun (id, e) -> Prop.mk_eq tenv (Exp.Var id) e) eqs in
(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. *)
let prop_iter_check_fields_ptsto_shallow iter lexp =
let prop_iter_check_fields_ptsto_shallow tenv iter lexp =
let offset = Sil.exp_get_offsets lexp in
let (_, se, _) =
match Prop.prop_iter_current iter with
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, t), _ -> (e, se, t)
| _ -> assert false in
let rec check_offset se = function
@ -553,7 +553,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
let atoms_hpred_list = extend_footprint_pred hpred in
IList.map (fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list
| _ ->
L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop iter); L.d_ln();
L.d_warning "Cannot extend "; Sil.d_exp lexp; L.d_strln " in"; Prop.d_prop (Prop.prop_iter_to_prop tenv iter); L.d_ln();
[([], footprint_sigma)] in
IList.map (fun (atoms, sigma') -> (atoms, IList.stable_sort Sil.hpred_compare sigma')) atoms_sigma_list in
let iter_atoms_fp_sigma_list =
@ -563,11 +563,11 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
Prop.prop_iter_replace_footprint_sigma iter' fp_sigma
) iter_atoms_fp_sigma_list in
let res_prop_list =
IList.map Prop.prop_iter_to_prop res_iter_list in
IList.map (Prop.prop_iter_to_prop tenv) res_iter_list in
begin
L.d_str "in prop_iter_extend_ptsto lexp: "; Sil.d_exp lexp; L.d_ln ();
L.d_strln "prop before:";
let prop_before = Prop.prop_iter_to_prop iter in
let prop_before = Prop.prop_iter_to_prop tenv iter in
Prop.d_prop prop_before; L.d_ln ();
L.d_ln (); L.d_ln ();
L.d_strln "prop list after:";
@ -576,7 +576,7 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst =
res_iter_list
end in
begin
match Prop.prop_iter_current iter with
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, te), _ -> do_extend e se te
| _ -> assert false
end
@ -595,12 +595,12 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
L.d_ln (); L.d_ln ();
let eprop = Prop.expose prop in
let sigma_fp = ptsto_foot :: eprop.Prop.sigma_fp in
let nsigma_fp = Prop.sigma_normalize_prop Prop.prop_emp sigma_fp in
let prop' = Prop.normalize (Prop.set eprop ~sigma_fp:nsigma_fp) in
let prop_new = IList.fold_left (Prop.prop_atom_and ~footprint:!Config.footprint) prop' atoms in
let nsigma_fp = Prop.sigma_normalize_prop tenv Prop.prop_emp sigma_fp in
let prop' = Prop.normalize tenv (Prop.set eprop ~sigma_fp:nsigma_fp) in
let prop_new = IList.fold_left (Prop.prop_atom_and tenv ~footprint:!Config.footprint) prop' atoms in
let iter = match (Prop.prop_iter_create prop_new) with
| None ->
let prop_new' = Prop.normalize (Prop.prop_hpred_star prop_new ptsto) in
let prop_new' = Prop.normalize tenv (Prop.prop_hpred_star prop_new ptsto) in
begin
match (Prop.prop_iter_create prop_new') with
| None -> assert false
@ -612,7 +612,7 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst =
(** If [lexp] is an access to a field that is annotated with @GuardedBy, add constraints to [prop]
expressing the safety conditions for the access. Complain if these conditions cannot be met. *)
let add_guarded_by_constraints prop lexp pdesc =
let add_guarded_by_constraints tenv prop lexp pdesc =
let pname = Cfg.Procdesc.get_proc_name pdesc in
let excluded_guardedby_string str =
(* nothing with a space in it can be a valid Java expression, shouldn't warn *)
@ -744,7 +744,7 @@ let add_guarded_by_constraints prop lexp pdesc =
(function
| Sil.Apred (Alocked, _) -> true
| _ -> false)
(Attribute.get_for_exp prop guarded_by_exp) in
(Attribute.get_for_exp tenv prop guarded_by_exp) in
let should_warn pdesc =
(* adding this check implements "by reference" semantics for guarded-by rather than "by value"
semantics. if this access is through a local L or field V.f
@ -791,7 +791,7 @@ let add_guarded_by_constraints prop lexp pdesc =
end
else
(* private method. add locked proof obligation to [pdesc] *)
Attribute.add ~footprint:true prop Alocked [guarded_by_exp]
Attribute.add tenv ~footprint:true prop Alocked [guarded_by_exp]
| _ ->
if not (proc_has_matching_annot pdesc guarded_by_str
|| is_synchronized_on_class guarded_by_str) && should_warn pdesc
@ -849,7 +849,7 @@ let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst =
exception ARRAY_ACCESS
let rearrange_arith lexp prop =
let rearrange_arith tenv lexp prop =
if Config.trace_rearrange then begin
L.d_strln "entering rearrange_arith";
L.d_str "lexp: "; Sil.d_exp lexp; L.d_ln ();
@ -858,7 +858,7 @@ let rearrange_arith lexp prop =
if (Config.array_level >= 2) then raise ARRAY_ACCESS
else
let root = Exp.root_of_lexp lexp in
if Prover.check_allocatedness prop root then
if Prover.check_allocatedness tenv prop root then
raise ARRAY_ACCESS
else
raise (Exceptions.Symexec_memory_error __POS__)
@ -875,11 +875,11 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
L.d_strln "entering iter_rearrange_ptsto";
L.d_str "lexp: "; Sil.d_exp lexp; L.d_ln ();
L.d_strln "prop:"; Prop.d_prop orig_prop; L.d_ln ();
L.d_strln "iter:"; Prop.d_prop (Prop.prop_iter_to_prop iter);
L.d_strln "iter:"; Prop.d_prop (Prop.prop_iter_to_prop tenv iter);
L.d_ln (); L.d_ln ()
end;
let check_field_splitting () =
match prop_iter_check_fields_ptsto_shallow iter lexp with
match prop_iter_check_fields_ptsto_shallow tenv iter lexp with
| None -> ()
| Some fld ->
begin
@ -893,7 +893,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
else
begin
check_field_splitting ();
match Prop.prop_iter_current iter with
match Prop.prop_iter_current tenv iter with
| Sil.Hpointsto (e, se, te), offset ->
let max_stamp = fav_max_stamp (Prop.prop_iter_fav iter) in
let atoms_se_te_list =
@ -903,15 +903,15 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
let iter' = IList.fold_left (Prop.prop_iter_add_atom !Config.footprint) iter atoms' in
Prop.prop_iter_update_current iter' (Sil.Hpointsto (e, se', te')) in
let filter it =
let p = Prop.prop_iter_to_prop it in
not (Prover.check_inconsistency p) in
let p = Prop.prop_iter_to_prop tenv it in
not (Prover.check_inconsistency tenv p) in
IList.filter filter (IList.map handle_case atoms_se_te_list)
| _ -> [iter]
end in
begin
if Config.trace_rearrange then begin
L.d_strln "exiting iter_rearrange_ptsto, returning results";
Prop.d_proplist_with_typ (IList.map Prop.prop_iter_to_prop res);
Prop.d_proplist_with_typ (IList.map (Prop.prop_iter_to_prop tenv) res);
L.d_decrease_indent 1;
L.d_ln (); L.d_ln ()
end;
@ -919,12 +919,12 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst =
end
(** do re-arrangment for an iter whose current element is a nonempty listseg *)
let iter_rearrange_ne_lseg recurse_on_iters iter para e1 e2 elist =
let iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist =
if Config.nelseg then
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_NE para n' e2 elist] in
let hpred_list1 = para_inst1@[Prop.mk_lseg tenv Sil.Lseg_NE para n' e2 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1 in
let iter_base_case =
let (_, para_inst) = Sil.hpara_instantiate para e1 e2 elist in
@ -934,54 +934,54 @@ let iter_rearrange_ne_lseg recurse_on_iters iter para e1 e2 elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para n' e2 elist] in
let hpred_list1 = para_inst1@[Prop.mk_lseg tenv Sil.Lseg_PE para n' e2 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1 in
recurse_on_iters [iter_inductive_case]
(** do re-arrangment for an iter whose current element is a nonempty dllseg to be unrolled from lhs *)
let iter_rearrange_ne_dllseg_first recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_dll_inst1) = Sil.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg Sil.Lseg_NE para_dll n' e1 e3 e4 elist] in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg tenv Sil.Lseg_NE para_dll n' e1 e3 e4 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1 in
let iter_base_case =
let (_, para_dll_inst) = Sil.hpara_dll_instantiate para_dll e1 e2 e3 elist in
let iter' = Prop.prop_iter_update_current_by_list iter para_dll_inst in
let prop' = Prop.prop_iter_to_prop iter' in
let prop'' = Prop.conjoin_eq ~footprint: (!Config.footprint) e1 e4 prop' in
let prop' = Prop.prop_iter_to_prop tenv iter' in
let prop'' = Prop.conjoin_eq tenv ~footprint: (!Config.footprint) e1 e4 prop' in
match (Prop.prop_iter_create prop'') with
| None -> assert false
| Some iter' -> iter' in
recurse_on_iters [iter_inductive_case; iter_base_case]
(** do re-arrangment for an iter whose current element is a nonempty dllseg to be unrolled from rhs *)
let iter_rearrange_ne_dllseg_last recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_dll_inst1) = Sil.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg Sil.Lseg_NE para_dll e1 e2 e4 n' elist] in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg tenv Sil.Lseg_NE para_dll e1 e2 e4 n' elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1 in
let iter_base_case =
let (_, para_dll_inst) = Sil.hpara_dll_instantiate para_dll e4 e2 e3 elist in
let iter' = Prop.prop_iter_update_current_by_list iter para_dll_inst in
let prop' = Prop.prop_iter_to_prop iter' in
let prop'' = Prop.conjoin_eq ~footprint: (!Config.footprint) e1 e4 prop' in
let prop' = Prop.prop_iter_to_prop tenv iter' in
let prop'' = Prop.conjoin_eq tenv ~footprint: (!Config.footprint) e1 e4 prop' in
match (Prop.prop_iter_create prop'') with
| None -> assert false
| Some iter' -> iter' in
recurse_on_iters [iter_inductive_case; iter_base_case]
(** do re-arrangment for an iter whose current element is a possibly empty listseg *)
let iter_rearrange_pe_lseg recurse_on_iters default_case_iter iter para e1 e2 elist =
let iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist =
let iter_nonemp_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_inst1) = Sil.hpara_instantiate para e1 n' elist in
let hpred_list1 = para_inst1@[Prop.mk_lseg Sil.Lseg_PE para n' e2 elist] in
let hpred_list1 = para_inst1@[Prop.mk_lseg tenv Sil.Lseg_PE para n' e2 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1 in
let iter_subcases =
let removed_prop = Prop.prop_iter_remove_curr_then_to_prop iter in
let prop' = Prop.conjoin_eq ~footprint: (!Config.footprint) e1 e2 removed_prop in
let removed_prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in
let prop' = Prop.conjoin_eq tenv ~footprint: (!Config.footprint) e1 e2 removed_prop in
match (Prop.prop_iter_create prop') with
| None ->
let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in
@ -990,16 +990,16 @@ let iter_rearrange_pe_lseg recurse_on_iters default_case_iter iter para e1 e2 el
recurse_on_iters iter_subcases
(** do re-arrangment for an iter whose current element is a possibly empty dllseg to be unrolled from lhs *)
let iter_rearrange_pe_dllseg_first recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist =
let iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_dll_inst1) = Sil.hpara_dll_instantiate para_dll e1 e2 n' elist in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg Sil.Lseg_PE para_dll n' e1 e3 e4 elist] in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg tenv Sil.Lseg_PE para_dll n' e1 e3 e4 elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1 in
let iter_subcases =
let removed_prop = Prop.prop_iter_remove_curr_then_to_prop iter in
let prop' = Prop.conjoin_eq ~footprint: (!Config.footprint) e1 e3 removed_prop in
let prop'' = Prop.conjoin_eq ~footprint: (!Config.footprint) e2 e4 prop' in
let removed_prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in
let prop' = Prop.conjoin_eq tenv ~footprint: (!Config.footprint) e1 e3 removed_prop in
let prop'' = Prop.conjoin_eq tenv ~footprint: (!Config.footprint) e2 e4 prop' in
match (Prop.prop_iter_create prop'') with
| None ->
let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in
@ -1008,16 +1008,16 @@ let iter_rearrange_pe_dllseg_first recurse_on_iters default_case_iter iter para_
recurse_on_iters iter_subcases
(** do re-arrangment for an iter whose current element is a possibly empty dllseg to be unrolled from rhs *)
let iter_rearrange_pe_dllseg_last recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist =
let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist =
let iter_inductive_case =
let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in
let (_, para_dll_inst1) = Sil.hpara_dll_instantiate para_dll e4 n' e3 elist in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg Sil.Lseg_PE para_dll e1 e2 e4 n' elist] in
let hpred_list1 = para_dll_inst1@[Prop.mk_dllseg tenv Sil.Lseg_PE para_dll e1 e2 e4 n' elist] in
Prop.prop_iter_update_current_by_list iter hpred_list1 in
let iter_subcases =
let removed_prop = Prop.prop_iter_remove_curr_then_to_prop iter in
let prop' = Prop.conjoin_eq ~footprint: (!Config.footprint) e1 e3 removed_prop in
let prop'' = Prop.conjoin_eq ~footprint: (!Config.footprint) e2 e4 prop' in
let removed_prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in
let prop' = Prop.conjoin_eq tenv ~footprint: (!Config.footprint) e1 e3 removed_prop in
let prop'' = Prop.conjoin_eq tenv ~footprint: (!Config.footprint) e2 e4 prop' in
match (Prop.prop_iter_create prop'') with
| None ->
let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in
@ -1026,7 +1026,7 @@ let iter_rearrange_pe_dllseg_last recurse_on_iters default_case_iter iter para_d
recurse_on_iters iter_subcases
(** find the type at the offset from the given type expression, if any *)
let type_at_offset texp off =
let type_at_offset _tenv texp off =
let rec strip_offset off typ = match off, typ with
| [], _ -> Some typ
| (Sil.Off_fld (f, _)):: off', Typ.Tstruct { Typ.instance_fields } ->
@ -1046,11 +1046,11 @@ let type_at_offset texp off =
(** 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 *)
let check_type_size pname prop texp off typ_from_instr =
let check_type_size tenv 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 ();
L.d_str "typ_from_instr: "; Typ.d_full typ_from_instr; L.d_ln ();
match type_at_offset texp off with
match type_at_offset tenv texp off with
| Some typ_of_object ->
L.d_str "typ_o: "; Typ.d_full typ_of_object; L.d_ln ();
if Prover.type_size_comparable typ_from_instr typ_of_object && Prover.check_type_size_leq typ_from_instr typ_of_object = false
@ -1059,7 +1059,7 @@ let check_type_size pname prop texp off typ_from_instr =
let loc = State.get_loc () in
let exn =
Exceptions.Pointer_size_mismatch (
Errdesc.explain_dereference deref_str prop loc, __POS__) in
Errdesc.explain_dereference tenv deref_str prop loc, __POS__) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ?pre:pre_opt exn
end
@ -1103,7 +1103,7 @@ let rec iter_rearrange
L.d_str "typ: "; Typ.d_full typ; L.d_ln ();
L.d_str "type from instruction: "; Typ.d_full typ_from_instr; L.d_ln();
L.d_strln "prop:"; Prop.d_prop prop; L.d_ln ();
L.d_strln "iter:"; Prop.d_prop (Prop.prop_iter_to_prop iter);
L.d_strln "iter:"; Prop.d_prop (Prop.prop_iter_to_prop tenv iter);
L.d_ln (); L.d_ln ()
end;
let default_case_iter (iter': unit Prop.prop_iter) =
@ -1112,7 +1112,7 @@ let rec iter_rearrange
prop_iter_add_hpred_footprint pname tenv prop iter' (lexp, typ) inst
else
if (Config.array_level >= 1 && not !Config.footprint && Exp.pointer_arith lexp)
then rearrange_arith lexp prop
then rearrange_arith tenv lexp prop
else begin
pp_rearrangement_error "cannot find predicate with root" prop lexp;
if not !Config.footprint then Printer.force_delayed_prints ();
@ -1120,11 +1120,11 @@ let rec iter_rearrange
end in
let recurse_on_iters iters =
let f_one_iter iter' =
let prop' = Prop.prop_iter_to_prop iter' in
if Prover.check_inconsistency prop' then
let prop' = Prop.prop_iter_to_prop tenv iter' in
if Prover.check_inconsistency tenv prop' then
[]
else
iter_rearrange pname tenv (Prop.lexp_normalize_prop prop' lexp) typ prop' iter' inst in
iter_rearrange pname tenv (Prop.lexp_normalize_prop tenv prop' lexp) typ prop' iter' inst in
let rec f_many_iters iters_lst = function
| [] -> IList.flatten (IList.rev iters_lst)
| iter':: iters' ->
@ -1133,42 +1133,42 @@ let rec iter_rearrange
f_many_iters [] iters in
let filter = function
| Sil.Hpointsto (base, _, _) | Sil.Hlseg (_, _, base, _, _) ->
Prover.is_root prop base lexp
Prover.is_root tenv prop base lexp
| Sil.Hdllseg (_, _, first, _, _, last, _) ->
let result_first = Prover.is_root prop first lexp in
let result_first = Prover.is_root tenv prop first lexp in
match result_first with
| None -> Prover.is_root prop last lexp
| None -> Prover.is_root tenv prop last lexp
| Some _ -> result_first in
let res =
match Prop.prop_iter_find iter filter with
| None ->
[default_case_iter iter]
| Some iter ->
match Prop.prop_iter_current iter with
match Prop.prop_iter_current tenv iter with
| (Sil.Hpointsto (_, _, texp), off) ->
if Config.type_size then check_type_size pname prop texp off typ_from_instr;
if Config.type_size then check_type_size tenv pname prop texp off typ_from_instr;
iter_rearrange_ptsto pname tenv prop iter lexp inst
| (Sil.Hlseg (Sil.Lseg_NE, para, e1, e2, elist), _) ->
iter_rearrange_ne_lseg recurse_on_iters iter para e1 e2 elist
iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist
| (Sil.Hlseg (Sil.Lseg_PE, para, e1, e2, elist), _) ->
iter_rearrange_pe_lseg recurse_on_iters default_case_iter iter para e1 e2 elist
iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist
| (Sil.Hdllseg (Sil.Lseg_NE, para_dll, e1, e2, e3, e4, elist), _) ->
begin
match Prover.is_root prop e1 lexp, Prover.is_root prop e4 lexp with
match Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp with
| None, None -> assert false
| Some _, _ -> iter_rearrange_ne_dllseg_first recurse_on_iters iter para_dll e1 e2 e3 e4 elist
| _, Some _ -> iter_rearrange_ne_dllseg_last recurse_on_iters iter para_dll e1 e2 e3 e4 elist
| Some _, _ -> iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist
| _, Some _ -> iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist
end
| (Sil.Hdllseg (Sil.Lseg_PE, para_dll, e1, e2, e3, e4, elist), _) ->
begin
match Prover.is_root prop e1 lexp, Prover.is_root prop e4 lexp with
match Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp with
| None, None -> assert false
| Some _, _ -> iter_rearrange_pe_dllseg_first recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist
| _, Some _ -> iter_rearrange_pe_dllseg_last recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist
| Some _, _ -> iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist
| _, Some _ -> iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist
end in
if Config.trace_rearrange then begin
L.d_strln "exiting iter_rearrange, returning results";
Prop.d_proplist_with_typ (IList.map Prop.prop_iter_to_prop res);
Prop.d_proplist_with_typ (IList.map (Prop.prop_iter_to_prop tenv) res);
L.d_decrease_indent 1;
L.d_ln (); L.d_ln ()
end;
@ -1188,7 +1188,7 @@ let is_weak_captured_var pdesc pvar =
(** Check for dereference errors: dereferencing 0, a freed value, or an undefined value *)
let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
let check_dereference_error tenv pdesc (prop : Prop.normal Prop.t) lexp loc =
let nullable_obj_str = ref None in
let nullable_str_is_weak_captured_var = ref false in
(* return true if deref_exp is only pointed to by fields/params with @Nullable annotations *)
@ -1215,7 +1215,7 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
nullable_obj_str := Some (Procname.to_string pname);
true
| _ -> false in
IList.exists is_nullable_attr (Attribute.get_for_exp prop exp) in
IList.exists is_nullable_attr (Attribute.get_for_exp tenv prop exp) in
(* it's ok for a non-nullable local to point to deref_exp *)
is_nullable || Pvar.is_local pvar
| Sil.Hpointsto (_, Sil.Estruct (flds, _), Exp.Sizeof (typ, _, _)) ->
@ -1238,12 +1238,12 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
let root = Exp.root_of_lexp lexp in
let is_deref_of_nullable =
let is_definitely_non_null exp prop =
Prover.check_disequal prop exp Exp.zero in
Prover.check_disequal tenv prop exp Exp.zero in
Config.report_nullable_inconsistency && not (is_definitely_non_null root prop)
&& is_only_pt_by_nullable_fld_or_param root in
let relevant_attributes_getters = [
Attribute.get_resource;
Attribute.get_undef;
Attribute.get_resource tenv;
Attribute.get_undef tenv;
] in
let get_relevant_attributes exp =
let rec fold_getters = function
@ -1259,7 +1259,7 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
| Exp.BinOp((Binop.PlusPI | Binop.PlusA | Binop.MinusPI | Binop.MinusA), base, _) -> base
| _ -> root in
get_relevant_attributes root_no_offset in
if Prover.check_zero (Exp.root_of_lexp root) || is_deref_of_nullable then
if Prover.check_zero tenv (Exp.root_of_lexp root) || is_deref_of_nullable then
begin
let deref_str =
if is_deref_of_nullable then
@ -1271,7 +1271,7 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
| None -> Localise.deref_str_nullable None ""
else Localise.deref_str_null None in
let err_desc =
Errdesc.explain_dereference ~use_buckets: true ~is_nullable: is_deref_of_nullable
Errdesc.explain_dereference tenv ~use_buckets: true ~is_nullable: is_deref_of_nullable
deref_str prop loc in
if Localise.is_parameter_not_null_checked_desc err_desc then
raise (Exceptions.Parameter_not_null_checked (err_desc, __POS__))
@ -1284,29 +1284,29 @@ let check_dereference_error pdesc (prop : Prop.normal Prop.t) lexp loc =
match attribute_opt with
| Some (Apred (Adangling dk, _)) ->
let deref_str = Localise.deref_str_dangling (Some dk) in
let err_desc = Errdesc.explain_dereference deref_str prop (State.get_loc ()) in
let err_desc = Errdesc.explain_dereference tenv deref_str prop (State.get_loc ()) in
raise (Exceptions.Dangling_pointer_dereference (Some dk, err_desc, __POS__))
| Some (Apred (Aundef (s, _, undef_loc, _), _)) ->
if Config.angelic_execution then ()
else
let deref_str = Localise.deref_str_undef (s, undef_loc) in
let err_desc = Errdesc.explain_dereference deref_str prop loc in
let err_desc = Errdesc.explain_dereference tenv deref_str prop loc in
raise (Exceptions.Skip_pointer_dereference (err_desc, __POS__))
| Some (Apred (Aresource ({ ra_kind = Rrelease } as ra), _)) ->
let deref_str = Localise.deref_str_freed ra in
let err_desc = Errdesc.explain_dereference ~use_buckets: true deref_str prop loc in
let err_desc = Errdesc.explain_dereference tenv ~use_buckets: true deref_str prop loc in
raise (Exceptions.Use_after_free (err_desc, __POS__))
| _ ->
if Prover.check_equal Prop.prop_emp (Exp.root_of_lexp root) Exp.minus_one then
if Prover.check_equal tenv Prop.prop_emp (Exp.root_of_lexp root) Exp.minus_one then
let deref_str = Localise.deref_str_dangling None in
let err_desc = Errdesc.explain_dereference deref_str prop loc in
let err_desc = Errdesc.explain_dereference tenv deref_str prop loc in
raise (Exceptions.Dangling_pointer_dereference (None, err_desc, __POS__))
(* Check that an expression representin an objc block can be null and raise a [B1] null exception.*)
(* It's used to check that we don't call possibly null blocks *)
let check_call_to_objc_block_error pdesc prop fun_exp loc =
let check_call_to_objc_block_error tenv pdesc prop fun_exp loc =
let fun_exp_may_be_null () = (* may be null if we don't know if it is definitely not null *)
not (Prover.check_disequal prop (Exp.root_of_lexp fun_exp) Exp.zero) in
not (Prover.check_disequal tenv prop (Exp.root_of_lexp fun_exp) Exp.zero) in
let try_explaining_exp e = (* when e is a temp var, try to find the pvar defining e*)
match e with
| Exp.Var id ->
@ -1337,7 +1337,7 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
not (is_fun_exp_captured_var ()) then
begin
let deref_str = Localise.deref_str_null None in
let err_desc_nobuckets = Errdesc.explain_dereference ~is_nullable: true deref_str prop loc in
let err_desc_nobuckets = Errdesc.explain_dereference tenv ~is_nullable: true deref_str prop loc in
match fun_exp with
| Exp.Var id when Ident.is_footprint id ->
let e_opt, is_field_deref = is_field_deref () in
@ -1371,22 +1371,22 @@ let check_call_to_objc_block_error pdesc prop fun_exp loc =
let rearrange ?(report_deref_errors=true) pdesc tenv lexp typ prop loc
: (Sil.offset list) Prop.prop_iter list =
let nlexp = match Prop.exp_normalize_prop prop lexp with
let nlexp = match Prop.exp_normalize_prop tenv prop lexp with
| Exp.BinOp(Binop.PlusPI, ep, e) -> (* array access with pointer arithmetic *)
Exp.Lindex(ep, e)
| e -> e in
let ptr_tested_for_zero =
Prover.check_disequal prop (Exp.root_of_lexp nlexp) Exp.zero in
Prover.check_disequal tenv prop (Exp.root_of_lexp nlexp) Exp.zero in
let inst = Sil.inst_rearrange (not ptr_tested_for_zero) loc (State.get_path_pos ()) in
L.d_strln ".... Rearrangement Start ....";
L.d_str "Exp: "; Sil.d_exp nlexp; L.d_ln ();
L.d_str "Prop: "; L.d_ln(); Prop.d_prop prop; L.d_ln (); L.d_ln ();
if report_deref_errors then check_dereference_error pdesc prop nlexp (State.get_loc ());
if report_deref_errors then check_dereference_error tenv pdesc prop nlexp (State.get_loc ());
let pname = Cfg.Procdesc.get_proc_name pdesc in
let prop' =
if Config.csl_analysis && !Config.footprint && Procname.is_java pname &&
not (Procname.is_constructor pname || Procname.is_class_initializer pname)
then add_guarded_by_constraints prop lexp pdesc
then add_guarded_by_constraints tenv prop lexp pdesc
else prop in
match Prop.prop_iter_create prop' with
| None ->

@ -16,12 +16,12 @@ exception ARRAY_ACCESS
(** Check for dereference errors: dereferencing 0, a freed value, or an undefined value *)
val check_dereference_error :
Cfg.Procdesc.t -> Prop.normal Prop.t -> Exp.t -> Location.t -> unit
Tenv.t -> Cfg.Procdesc.t -> Prop.normal Prop.t -> Exp.t -> Location.t -> unit
(** Check that an expression representing an objc block can be null and raise a [B1] null exception.
It's used to check that we don't call possibly null blocks *)
val check_call_to_objc_block_error :
Cfg.Procdesc.t -> Prop.normal Prop.t -> Exp.t -> Location.t -> unit
Tenv.t -> Cfg.Procdesc.t -> Prop.normal Prop.t -> Exp.t -> Location.t -> unit
(** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ].
It returns an iterator with [lexp |-> strexp: typ] as current predicate

@ -33,16 +33,16 @@ module Jprop = struct
| Prop (n, _) -> n
| Joined (n, _, _, _) -> n
let rec fav_add_dfs fav = function
| Prop (_, p) -> Prop.prop_fav_add_dfs fav p
let rec fav_add_dfs tenv fav = function
| Prop (_, p) -> Prop.prop_fav_add_dfs tenv fav p
| Joined (_, p, jp1, jp2) ->
Prop.prop_fav_add_dfs fav p;
fav_add_dfs fav jp1;
fav_add_dfs fav jp2
Prop.prop_fav_add_dfs tenv fav p;
fav_add_dfs tenv fav jp1;
fav_add_dfs tenv fav jp2
let rec normalize = function
| Prop (n, p) -> Prop (n, Prop.normalize p)
| Joined (n, p, jp1, jp2) -> Joined (n, Prop.normalize p, normalize jp1, normalize jp2)
let rec normalize tenv = function
| Prop (n, p) -> Prop (n, Prop.normalize tenv p)
| Joined (n, p, jp1, jp2) -> Joined (n, Prop.normalize tenv p, normalize tenv jp1, normalize tenv jp2)
(** Return a compact representation of the jprop *)
let rec compact sh = function
@ -172,38 +172,38 @@ type 'a spec = { pre: 'a Jprop.t; posts: ('a Prop.t * Paths.Path.t) list; visite
module NormSpec : sig
type t
val normalize : Prop.normal spec -> t
val normalize : Tenv.t -> Prop.normal spec -> t
val tospecs : t list -> Prop.normal spec list
val compact : Sil.sharing_env -> t -> t (** Return a compact representation of the spec *)
val erase_join_info_pre : t -> t (** Erase join info from pre of spec *)
val erase_join_info_pre : Tenv.t -> t -> t (** Erase join info from pre of spec *)
end = struct
type t = Prop.normal spec
let tospecs specs = specs
let spec_fav (spec: Prop.normal spec) : Sil.fav =
let spec_fav tenv (spec: Prop.normal spec) : Sil.fav =
let fav = Sil.fav_new () in
Jprop.fav_add_dfs fav spec.pre;
IList.iter (fun (p, _) -> Prop.prop_fav_add_dfs fav p) spec.posts;
Jprop.fav_add_dfs tenv fav spec.pre;
IList.iter (fun (p, _) -> Prop.prop_fav_add_dfs tenv fav p) spec.posts;
fav
let spec_sub sub spec =
{ pre = Jprop.normalize (Jprop.jprop_sub sub spec.pre);
posts = IList.map (fun (p, path) -> (Prop.normalize (Prop.prop_sub sub p), path)) spec.posts;
let spec_sub tenv sub spec =
{ pre = Jprop.normalize tenv (Jprop.jprop_sub sub spec.pre);
posts = IList.map (fun (p, path) -> (Prop.normalize tenv (Prop.prop_sub sub p), path)) spec.posts;
visited = spec.visited }
(** Convert spec into normal form w.r.t. variable renaming *)
let normalize (spec: Prop.normal spec) : Prop.normal spec =
let fav = spec_fav spec in
let normalize tenv (spec: Prop.normal spec) : Prop.normal spec =
let fav = spec_fav tenv spec in
let idlist = Sil.fav_to_list fav in
let count = ref 0 in
let sub =
Sil.sub_of_list (IList.map (fun id ->
incr count; (id, Exp.Var (Ident.create_normal Ident.name_spec !count))) idlist) in
spec_sub sub spec
spec_sub tenv sub spec
(** Return a compact representation of the spec *)
let compact sh spec =
@ -212,9 +212,9 @@ end = struct
{ pre = pre; posts = posts; visited = spec.visited }
(** Erase join info from pre of spec *)
let erase_join_info_pre spec =
let erase_join_info_pre tenv spec =
let spec' = { spec with pre = Jprop.Prop (1, Jprop.to_prop spec.pre) } in
normalize spec'
normalize tenv spec'
end
(** Convert spec into normal form w.r.t. variable renaming *)
@ -540,11 +540,11 @@ let summary_serializer : summary Serialization.serializer =
Serialization.create_serializer Serialization.summary_key
(** Save summary for the procedure into the spec database *)
let store_summary pname (summ: summary) =
let store_summary tenv pname (summ: summary) =
let process_payload payload = match payload.preposts with
| Some specs ->
{ payload with
preposts = Some (IList.map NormSpec.erase_join_info_pre specs);
preposts = Some (IList.map (NormSpec.erase_join_info_pre tenv) specs);
}
| None -> payload in
let summ1 = { summ with payload = process_payload summ.payload } in

@ -263,13 +263,13 @@ val re_initialize_dependency_map : dependency_map_t -> dependency_map_t
val set_status : Procname.t -> status -> unit
(** Convert spec into normal form w.r.t. variable renaming *)
val spec_normalize : Prop.normal spec -> NormSpec.t
val spec_normalize : Tenv.t -> Prop.normal spec -> NormSpec.t
(** path to the .specs file for the given procedure in the current results dir *)
val res_dir_specs_filename : Procname.t -> DB.filename
(** Save summary for the procedure into the spec database *)
val store_summary : Procname.t -> summary -> unit
val store_summary : Tenv.t -> Procname.t -> summary -> unit
(** Return a compact representation of the summary *)
val summary_compact : Sil.sharing_env -> summary -> summary

@ -256,10 +256,10 @@ let extract_pre p tenv pdesc abstract_fun =
let count = ref 0 in
Sil.sub_of_list (IList.map (fun id ->
incr count; (id, Exp.Var (Ident.create_normal Ident.name_spec !count))) idlist) in
let _, p' = Cfg.remove_locals_formals pdesc p in
let _, p' = Cfg.remove_locals_formals tenv pdesc p in
let pre, _ = Prop.extract_spec p' in
let pre' = try abstract_fun tenv pre with exn when SymOp.exn_not_failure exn -> pre in
Prop.normalize (Prop.prop_sub sub pre')
Prop.normalize tenv (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 *)

@ -61,8 +61,8 @@ let check_block_retain_cycle tenv caller_pname prop block_nullified =
fst (IList.split attributes.ProcAttributes.captured)
| None ->
[] in
let prop' = Cfg.remove_seed_captured_vars_block block_captured prop in
let prop'' = Prop.prop_rename_fav_with_existentials prop' in
let prop' = Cfg.remove_seed_captured_vars_block tenv block_captured prop in
let prop'' = Prop.prop_rename_fav_with_existentials tenv prop' in
let _ : Prop.normal Prop.t = Abs.abstract_junk ~original_prop: prop caller_pname tenv prop'' in
()
@ -109,9 +109,9 @@ let rec apply_offlist
lookup_inst := Some inst_curr;
let alloc_attribute_opt =
if inst_curr = Sil.Iinitial then None
else Attribute.get_undef p root_lexp in
else Attribute.get_undef tenv p root_lexp in
let deref_str = Localise.deref_str_uninitialized alloc_attribute_opt in
let err_desc = Errdesc.explain_memory_access deref_str p (State.get_loc ()) in
let err_desc = Errdesc.explain_memory_access tenv deref_str p (State.get_loc ()) in
let exn = (Exceptions.Uninitialized_value (err_desc, __POS__)) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ?pre:pre_opt exn;
@ -128,7 +128,7 @@ let rec apply_offlist
else
begin
L.d_strln "WARNING: struct assignment treated as nondeterministic assignment";
(f None, Prop.create_strexp_of_type (Some tenv) Prop.Fld_init typ None inst, typ, None)
(f None, Prop.create_strexp_of_type tenv Prop.Fld_init typ None inst, typ, None)
end
| [], Sil.Earray _ ->
let offlist' = (Sil.Off_index Exp.zero):: offlist in
@ -173,12 +173,12 @@ let rec apply_offlist
assert false
| (Sil.Off_index idx) :: offlist', Sil.Earray (len, esel, inst1) ->
let nidx = Prop.exp_normalize_prop p idx in
let nidx = Prop.exp_normalize_prop tenv p idx in
begin
let typ' = Tenv.expand_type tenv typ in
let t', len' = match typ' with Typ.Tarray (t', len') -> (t', len') | _ -> assert false in
try
let idx_ese', se' = IList.find (fun ese -> Prover.check_equal p nidx (fst ese)) esel in
let idx_ese', se' = IList.find (fun ese -> Prover.check_equal tenv p nidx (fst ese)) esel in
let res_e', res_se', res_t', res_pred_insts_op' =
apply_offlist
pdesc tenv p fp_root nullify_struct
@ -228,7 +228,7 @@ let ptsto_lookup pdesc tenv p (lexp, se, typ, len, st) offlist id =
match !lookup_inst with
| Some (Sil.Iinitial | Sil.Ialloc | Sil.Ilookup) -> true
| _ -> false in
let ptsto' = Prop.mk_ptsto lexp se' (Exp.Sizeof (typ', len, st)) in
let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof (typ', len, st)) in
(e', ptsto', pred_insts_op', lookup_uninitialized)
(** [ptsto_update p (lexp,se,typ) offlist exp] takes
@ -251,7 +251,7 @@ let ptsto_update pdesc tenv p (lexp, se, typ, len, st) offlist exp =
let pos = State.get_path_pos () in
apply_offlist
pdesc tenv p fp_root true (lexp, se, typ) offlist f (State.get_inst_update pos) lookup_inst in
let ptsto' = Prop.mk_ptsto lexp se' (Exp.Sizeof (typ', len, st)) in
let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof (typ', len, st)) in
(ptsto', pred_insts_op')
let update_iter iter pi sigma =
@ -272,25 +272,25 @@ let rec execute_nullify_se = function
(** Do pruning for conditional [if (e1 != e2) ] if [positive] is true
and [(if (e1 == e2)] if [positive] is false *)
let prune_ne ~positive e1 e2 prop =
let prune_ne tenv ~positive e1 e2 prop =
let is_inconsistent =
if positive then Prover.check_equal prop e1 e2
else Prover.check_disequal prop e1 e2 in
if positive then Prover.check_equal tenv prop e1 e2
else Prover.check_disequal tenv prop e1 e2 in
if is_inconsistent then Propset.empty
else
let conjoin = if positive then Prop.conjoin_neq else Prop.conjoin_eq in
let new_prop = conjoin ~footprint: (!Config.footprint) e1 e2 prop in
if Prover.check_inconsistency new_prop then Propset.empty
else Propset.singleton new_prop
let new_prop = conjoin tenv ~footprint: (!Config.footprint) e1 e2 prop in
if Prover.check_inconsistency tenv new_prop then Propset.empty
else Propset.singleton tenv new_prop
(** Do pruning for conditional "if ([e1] CMP [e2])" if [positive] is
true and "if (!([e1] CMP [e2]))" if [positive] is false, where CMP
is "<" if [is_strict] is true and "<=" if [is_strict] is false.
*)
let prune_ineq ~is_strict ~positive prop e1 e2 =
let prune_ineq tenv ~is_strict ~positive prop e1 e2 =
if Exp.equal e1 e2 then
if (positive && not is_strict) || (not positive && is_strict) then
Propset.singleton prop
Propset.singleton tenv prop
else Propset.empty
else
(* build the pruning condition and its negation, as explained in
@ -305,69 +305,69 @@ let prune_ineq ~is_strict ~positive prop e1 e2 =
let (prune_cond, not_prune_cond) =
if positive then (e1_cmp_e2, not_e1_cmp_e2)
else (not_e1_cmp_e2, e1_cmp_e2) in
let is_inconsistent = Prover.check_atom prop (Prop.mk_inequality not_prune_cond) in
let is_inconsistent = Prover.check_atom tenv prop (Prop.mk_inequality tenv not_prune_cond) in
if is_inconsistent then Propset.empty
else
let footprint = !Config.footprint in
let prop_with_ineq = Prop.conjoin_eq ~footprint prune_cond Exp.one prop in
Propset.singleton prop_with_ineq
let prop_with_ineq = Prop.conjoin_eq tenv ~footprint prune_cond Exp.one prop in
Propset.singleton tenv prop_with_ineq
let rec prune ~positive condition prop =
let rec prune tenv ~positive condition prop =
match condition with
| Exp.Var _ | Exp.Lvar _ ->
prune_ne ~positive condition Exp.zero prop
prune_ne tenv ~positive condition Exp.zero prop
| Exp.Const (Const.Cint i) when IntLit.iszero i ->
if positive then Propset.empty else Propset.singleton prop
if positive then Propset.empty else Propset.singleton tenv prop
| Exp.Const (Const.Cint _ | Const.Cstr _ | Const.Cclass _) | Exp.Sizeof _ ->
if positive then Propset.singleton prop else Propset.empty
if positive then Propset.singleton tenv prop else Propset.empty
| Exp.Const _ ->
assert false
| Exp.Cast (_, condition') ->
prune ~positive condition' prop
prune tenv ~positive condition' prop
| Exp.UnOp (Unop.LNot, condition', _) ->
prune ~positive:(not positive) condition' prop
prune tenv ~positive:(not positive) condition' prop
| Exp.UnOp _ ->
assert false
| Exp.BinOp (Binop.Eq, e, Exp.Const (Const.Cint i))
| Exp.BinOp (Binop.Eq, Exp.Const (Const.Cint i), e)
when IntLit.iszero i && not (IntLit.isnull i) ->
prune ~positive:(not positive) e prop
prune tenv ~positive:(not positive) e prop
| Exp.BinOp (Binop.Eq, e1, e2) ->
prune_ne ~positive:(not positive) e1 e2 prop
prune_ne tenv ~positive:(not positive) e1 e2 prop
| Exp.BinOp (Binop.Ne, e, Exp.Const (Const.Cint i))
| Exp.BinOp (Binop.Ne, Exp.Const (Const.Cint i), e)
when IntLit.iszero i && not (IntLit.isnull i) ->
prune ~positive e prop
prune tenv ~positive e prop
| Exp.BinOp (Binop.Ne, e1, e2) ->
prune_ne ~positive e1 e2 prop
prune_ne tenv ~positive e1 e2 prop
| Exp.BinOp (Binop.Ge, e2, e1) | Exp.BinOp (Binop.Le, e1, e2) ->
prune_ineq ~is_strict:false ~positive prop e1 e2
prune_ineq tenv ~is_strict:false ~positive prop e1 e2
| Exp.BinOp (Binop.Gt, e2, e1) | Exp.BinOp (Binop.Lt, e1, e2) ->
prune_ineq ~is_strict:true ~positive prop e1 e2
prune_ineq tenv ~is_strict:true ~positive prop e1 e2
| Exp.BinOp (Binop.LAnd, condition1, condition2) ->
let pruner = if positive then prune_inter else prune_union in
let pruner = if positive then prune_inter tenv else prune_union tenv in
pruner ~positive condition1 condition2 prop
| Exp.BinOp (Binop.LOr, condition1, condition2) ->
let pruner = if positive then prune_union else prune_inter in
let pruner = if positive then prune_union tenv else prune_inter tenv in
pruner ~positive condition1 condition2 prop
| Exp.BinOp _ | Exp.Lfield _ | Exp.Lindex _ ->
prune_ne ~positive condition Exp.zero prop
prune_ne tenv ~positive condition Exp.zero prop
| Exp.Exn _ ->
assert false
| Exp.Closure _ ->
assert false
and prune_inter ~positive condition1 condition2 prop =
and prune_inter tenv ~positive condition1 condition2 prop =
let res = ref Propset.empty in
let pset1 = prune ~positive condition1 prop in
let pset1 = prune tenv ~positive condition1 prop in
let do_p p =
res := Propset.union (prune ~positive condition2 p) !res in
res := Propset.union (prune tenv ~positive condition2 p) !res in
Propset.iter do_p pset1;
!res
and prune_union ~positive condition1 condition2 prop =
let pset1 = prune ~positive condition1 prop in
let pset2 = prune ~positive condition2 prop in
and prune_union tenv ~positive condition1 condition2 prop =
let pset1 = prune tenv ~positive condition1 prop in
let pset2 = prune tenv ~positive condition2 prop in
Propset.union pset1 pset2
let dangerous_functions =
@ -417,26 +417,26 @@ let check_constant_string_dereference lexp =
| _ -> None
(** Normalize an expression and check for arithmetic problems *)
let check_arith_norm_exp pname exp prop =
match Attribute.find_arithmetic_problem (State.get_path_pos ()) prop exp with
let check_arith_norm_exp tenv pname exp prop =
match Attribute.find_arithmetic_problem tenv (State.get_path_pos ()) prop exp with
| Some (Attribute.Div0 div), prop' ->
let desc = Errdesc.explain_divide_by_zero div (State.get_node ()) (State.get_loc ()) in
let desc = Errdesc.explain_divide_by_zero tenv div (State.get_node ()) (State.get_loc ()) in
let exn = Exceptions.Divide_by_zero (desc, __POS__) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ?pre:pre_opt exn;
Prop.exp_normalize_prop prop exp, prop'
Prop.exp_normalize_prop tenv prop exp, prop'
| Some (Attribute.UminusUnsigned (e, typ)), prop' ->
let desc =
Errdesc.explain_unary_minus_applied_to_unsigned_expression
Errdesc.explain_unary_minus_applied_to_unsigned_expression tenv
e typ (State.get_node ()) (State.get_loc ()) in
let exn = Exceptions.Unary_minus_applied_to_unsigned_expression (desc, __POS__) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop pname) in
Reporting.log_warning pname ?pre:pre_opt exn;
Prop.exp_normalize_prop prop exp, prop'
| None, prop' -> Prop.exp_normalize_prop prop exp, prop'
Prop.exp_normalize_prop tenv prop exp, prop'
| None, prop' -> Prop.exp_normalize_prop tenv prop exp, prop'
(** Check if [cond] is testing for NULL a pointer already dereferenced *)
let check_already_dereferenced pname cond prop =
let check_already_dereferenced tenv pname cond prop =
let find_hpred lhs =
try Some (IList.find (function
| Sil.Hpointsto (e, _, _) -> Exp.equal e lhs
@ -453,7 +453,7 @@ let check_already_dereferenced pname cond prop =
| _ -> None in
let dereferenced_line = match is_check_zero cond with
| Some id ->
(match find_hpred (Prop.exp_normalize_prop prop (Exp.Var id)) with
(match find_hpred (Prop.exp_normalize_prop tenv prop (Exp.Var id)) with
| Some (Sil.Hpointsto (_, se, _)) ->
(match Tabulation.find_dereference_without_null_check_in_sexp se with
| Some n -> Some (id, n)
@ -464,7 +464,7 @@ let check_already_dereferenced pname cond prop =
match dereferenced_line with
| Some (id, (n, _)) ->
let desc =
Errdesc.explain_null_test_after_dereference
Errdesc.explain_null_test_after_dereference tenv
(Exp.Var id) (State.get_node ()) n (State.get_loc ()) in
let exn =
(Exceptions.Null_test_after_dereference (desc, __POS__)) in
@ -655,12 +655,12 @@ let resolve_and_analyze
whether the method is defined or generated by the specialization *)
let analyze_ondemand resolved_pname : unit =
if Procname.equal resolved_pname callee_proc_name then
Ondemand.analyze_proc_name ~propagate_exceptions:true caller_pdesc callee_proc_name
Ondemand.analyze_proc_name tenv ~propagate_exceptions:true caller_pdesc callee_proc_name
else
(* Create the type sprecialized procedure description and analyze it directly *)
Option.may
(fun specialized_pdesc ->
Ondemand.analyze_proc_desc ~propagate_exceptions:true caller_pdesc specialized_pdesc)
Ondemand.analyze_proc_desc tenv ~propagate_exceptions:true caller_pdesc specialized_pdesc)
(match Ondemand.get_proc_desc resolved_pname with
| Some resolved_proc_desc ->
Some resolved_proc_desc
@ -714,7 +714,7 @@ let call_constructor_url_update_args pname actual_params =
(* 2. We don't know, but obj could be null, we return both options, *)
(* (obj = null, res = null), (obj != null, res = [obj foo]) *)
(* We want the same behavior even when we are going to skip the function. *)
let handle_objc_instance_method_call_or_skip actual_pars path callee_pname pre ret_ids res =
let handle_objc_instance_method_call_or_skip tenv actual_pars path callee_pname pre ret_ids res =
let path_description =
"Message " ^
(Procname.to_simplified_string callee_pname) ^
@ -729,16 +729,16 @@ let handle_objc_instance_method_call_or_skip actual_pars path callee_pname pre r
match actual_pars with
| (e, _) :: _
when Exp.equal e Exp.zero ||
Option.is_some (Attribute.get_objc_null pre e) -> true
Option.is_some (Attribute.get_objc_null tenv pre e) -> true
| _ -> false in
let add_objc_null_attribute_or_nullify_result prop =
match ret_ids with
| [ret_id] -> (
match Attribute.find_equal_formal_path receiver prop with
match Attribute.find_equal_formal_path tenv receiver prop with
| Some vfs ->
Attribute.add_or_replace prop (Apred (Aobjc_null, [Exp.Var ret_id; vfs]))
Attribute.add_or_replace tenv prop (Apred (Aobjc_null, [Exp.Var ret_id; vfs]))
| None ->
Prop.conjoin_eq (Exp.Var ret_id) Exp.zero prop
Prop.conjoin_eq tenv (Exp.Var ret_id) Exp.zero prop
)
| _ -> prop in
if is_receiver_null then
@ -754,11 +754,11 @@ let handle_objc_instance_method_call_or_skip actual_pars path callee_pname pre r
so that in a NPE we can separate it into a different error type *)
[(add_objc_null_attribute_or_nullify_result pre, path)]
else
let is_undef = Option.is_some (Attribute.get_undef pre receiver) in
let is_undef = Option.is_some (Attribute.get_undef tenv pre receiver) in
if !Config.footprint && not is_undef then
let res_null = (* returns: (objc_null(res) /\ receiver=0) or an empty list of results *)
let pre_with_attr_or_null = add_objc_null_attribute_or_nullify_result pre in
let propset = prune_ne ~positive:false receiver Exp.zero pre_with_attr_or_null in
let propset = prune_ne tenv ~positive:false receiver Exp.zero pre_with_attr_or_null in
if Propset.is_empty propset then []
else
let prop = IList.hd (Propset.to_proplist propset) in
@ -773,33 +773,33 @@ let handle_objc_instance_method_call_or_skip actual_pars path callee_pname pre r
let handle_objc_instance_method_call actual_pars actual_params pre tenv ret_ids pdesc callee_pname
loc path exec_call =
let res () = exec_call tenv ret_ids pdesc callee_pname loc actual_params pre path in
handle_objc_instance_method_call_or_skip actual_pars path callee_pname pre ret_ids res
handle_objc_instance_method_call_or_skip tenv actual_pars path callee_pname pre ret_ids res
let normalize_params pdesc prop actual_params =
let normalize_params tenv pdesc prop actual_params =
let norm_arg (p, args) (e, t) =
let e', p' = check_arith_norm_exp pdesc e p in
let e', p' = check_arith_norm_exp tenv pdesc e p in
(p', (e', t) :: args) in
let prop, args = IList.fold_left norm_arg (prop, []) actual_params in
(prop, IList.rev args)
let do_error_checks node_opt instr pname pdesc = match node_opt with
let do_error_checks tenv node_opt instr pname pdesc = match node_opt with
| Some node ->
if !Config.curr_language = Config.Java then
PrintfArgs.check_printf_args_ok node instr pname pdesc
PrintfArgs.check_printf_args_ok tenv node instr pname pdesc
| None ->
()
let add_strexp_to_footprint strexp abducted_pv typ prop =
let add_strexp_to_footprint tenv strexp abducted_pv typ prop =
let abducted_lvar = Exp.Lvar abducted_pv in
let lvar_pt_fpvar =
let sizeof_exp = Exp.Sizeof (typ, None, Subtype.subtypes) in
Prop.mk_ptsto abducted_lvar strexp sizeof_exp in
Prop.mk_ptsto tenv abducted_lvar strexp sizeof_exp in
let sigma_fp = prop.Prop.sigma_fp in
Prop.normalize (Prop.set prop ~sigma_fp:(lvar_pt_fpvar :: sigma_fp))
Prop.normalize tenv (Prop.set prop ~sigma_fp:(lvar_pt_fpvar :: sigma_fp))
let add_to_footprint abducted_pv typ prop =
let add_to_footprint tenv abducted_pv typ prop =
let fresh_fp_var = Exp.Var (Ident.create_fresh Ident.kfootprint) in
let prop' = add_strexp_to_footprint (Sil.Eexp (fresh_fp_var, Sil.Inone)) abducted_pv typ prop in
let prop' = add_strexp_to_footprint tenv (Sil.Eexp (fresh_fp_var, Sil.Inone)) abducted_pv typ prop in
prop', fresh_fp_var
(* the current abduction mechanism treats struct values differently than all other types. abduction
@ -808,11 +808,11 @@ let add_to_footprint abducted_pv typ prop =
footprint. we can get rid of this special case if we fix the abduction on struct values *)
let add_struct_value_to_footprint tenv abducted_pv typ prop =
let struct_strexp =
Prop.create_strexp_of_type (Some tenv) Prop.Fld_init typ None Sil.inst_none in
let prop' = add_strexp_to_footprint struct_strexp abducted_pv typ prop in
Prop.create_strexp_of_type tenv Prop.Fld_init typ None Sil.inst_none in
let prop' = add_strexp_to_footprint tenv struct_strexp abducted_pv typ prop in
prop', struct_strexp
let add_constraints_on_retval pdesc prop ret_exp ~has_nullable_annot typ callee_pname callee_loc=
let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nullable_annot typ callee_pname callee_loc=
if Procname.is_infer_undefined callee_pname then prop
else
let is_rec_call pname = (* TODO: (t7147096) extend this to detect mutual recursion *)
@ -828,7 +828,7 @@ let add_constraints_on_retval pdesc prop ret_exp ~has_nullable_annot typ callee_
let bind_exp prop = function
| Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (rhs, _), _)
when Pvar.equal pv abducted ->
Prop.conjoin_eq exp_to_bind rhs prop
Prop.conjoin_eq tenv exp_to_bind rhs prop
| _ -> prop in
IList.fold_left bind_exp prop prop.Prop.sigma in
(* To avoid obvious false positives, assume skip functions do not return null pointers *)
@ -838,10 +838,10 @@ let add_constraints_on_retval pdesc prop ret_exp ~has_nullable_annot typ callee_
prop (* don't assume nonnull if the procedure is annotated with @Nullable *)
else
match typ with
| Typ.Tptr _ -> Prop.conjoin_neq exp Exp.zero prop
| Typ.Tptr _ -> Prop.conjoin_neq tenv exp Exp.zero prop
| _ -> prop in
let add_tainted_post ret_exp callee_pname prop =
Attribute.add_or_replace prop (Apred (Ataint callee_pname, [ret_exp])) in
Attribute.add_or_replace tenv prop (Apred (Ataint callee_pname, [ret_exp])) in
if Config.angelic_execution && not (is_rec_call callee_pname) then
(* introduce a fresh program variable to allow abduction on the return value *)
@ -851,8 +851,8 @@ let add_constraints_on_retval pdesc prop ret_exp ~has_nullable_annot typ callee_
else
let prop' =
if !Config.footprint then
let (prop', fresh_fp_var) = add_to_footprint abducted_ret_pv typ prop in
Prop.conjoin_eq ~footprint: true ret_exp fresh_fp_var prop'
let (prop', fresh_fp_var) = add_to_footprint tenv abducted_ret_pv typ prop in
Prop.conjoin_eq tenv ~footprint: true ret_exp fresh_fp_var prop'
else
(* bind return id to the abducted value pointed to by the pvar we introduced *)
bind_exp_to_abducted_val ret_exp abducted_ret_pv prop in
@ -870,7 +870,7 @@ let add_taint prop lhs_id rhs_exp pname tenv =
if Taint.has_taint_annotation fieldname struct_typ
then
let taint_info = { PredSymb.taint_source = pname; taint_kind = Tk_unknown; } in
Attribute.add_or_replace prop (Apred (Ataint taint_info, [Exp.Var lhs_id]))
Attribute.add_or_replace tenv prop (Apred (Ataint taint_info, [Exp.Var lhs_id]))
else
prop in
match rhs_exp with
@ -888,9 +888,9 @@ let add_taint prop lhs_id rhs_exp pname tenv =
let execute_load ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc prop_ =
let execute_load_ pdesc tenv id loc acc_in iter =
let iter_ren = Prop.prop_iter_make_id_primed id iter in
let prop_ren = Prop.prop_iter_to_prop iter_ren in
match Prop.prop_iter_current iter_ren with
let iter_ren = Prop.prop_iter_make_id_primed tenv id iter in
let prop_ren = Prop.prop_iter_to_prop tenv iter_ren in
match Prop.prop_iter_current tenv iter_ren with
| (Sil.Hpointsto(lexp, strexp, Exp.Sizeof (typ, len, st)), offlist) ->
let contents, new_ptsto, pred_insts_op, lookup_uninitialized =
ptsto_lookup pdesc tenv prop_ren (lexp, strexp, typ, len, st) offlist id in
@ -898,10 +898,10 @@ let execute_load ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc
let pi' = Sil.Aeq (Exp.Var(id), contents):: pi in
let sigma' = new_ptsto:: sigma in
let iter' = update_iter iter_ren pi' sigma' in
let prop' = Prop.prop_iter_to_prop iter' in
let prop' = Prop.prop_iter_to_prop tenv iter' in
let prop'' =
if lookup_uninitialized then
Attribute.add_or_replace prop' (Apred (Adangling DAuninit, [Exp.Var id]))
Attribute.add_or_replace tenv prop' (Apred (Adangling DAuninit, [Exp.Var id]))
else prop' in
let prop''' =
if Config.taint_analysis
@ -915,7 +915,7 @@ let execute_load ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc
end
| (Sil.Hpointsto _, _) ->
Errdesc.warning_err loc "no offset access in execute_load -- treating as skip@.";
(Prop.prop_iter_to_prop iter_ren) :: acc_in
(Prop.prop_iter_to_prop tenv iter_ren) :: acc_in
| _ ->
(* The implementation of this case means that we
ignore this dereferencing operator. When the analyzer treats
@ -923,25 +923,25 @@ let execute_load ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc
should change the implementation here. *)
assert false in
try
let n_rhs_exp, prop = check_arith_norm_exp pname rhs_exp prop_ in
let n_rhs_exp' = Prop.exp_collapse_consecutive_indices_prop typ n_rhs_exp in
let n_rhs_exp, prop = check_arith_norm_exp tenv pname rhs_exp prop_ in
let n_rhs_exp' = Prop.exp_collapse_consecutive_indices_prop tenv typ n_rhs_exp in
match check_constant_string_dereference n_rhs_exp' with
| Some value ->
[Prop.conjoin_eq (Exp.Var id) value prop]
[Prop.conjoin_eq tenv (Exp.Var id) value prop]
| None ->
let exp_get_undef_attr exp =
let fold_undef_pname callee_opt atom =
match callee_opt, atom with
| None, Sil.Apred (Aundef _, _) -> Some atom
| _ -> callee_opt in
IList.fold_left fold_undef_pname None (Attribute.get_for_exp prop exp) in
IList.fold_left fold_undef_pname None (Attribute.get_for_exp tenv prop exp) in
let prop' =
if Config.angelic_execution then
(* when we try to deref an undefined value, add it to the footprint *)
match exp_get_undef_attr n_rhs_exp' with
| Some (Apred (Aundef (callee_pname, ret_annots, callee_loc, _), _)) ->
let has_nullable_annot = Annotations.ia_is_nullable ret_annots in
add_constraints_on_retval
add_constraints_on_retval tenv
pdesc prop n_rhs_exp' ~has_nullable_annot typ callee_pname callee_loc
| _ -> prop
else prop in
@ -952,7 +952,7 @@ let execute_load ?(report_deref_errors=true) pname pdesc tenv id rhs_exp typ loc
if (Config.array_level = 0) then assert false
else
let undef = Exp.get_undefined false in
[Prop.conjoin_eq (Exp.Var id) undef prop_]
[Prop.conjoin_eq tenv (Exp.Var id) undef prop_]
let load_ret_annots pname =
match AttributesTable.load_attributes pname with
@ -965,26 +965,26 @@ let load_ret_annots pname =
let execute_store ?(report_deref_errors=true) pname pdesc tenv lhs_exp typ rhs_exp loc prop_ =
let execute_store_ pdesc tenv rhs_exp acc_in iter =
let (lexp, strexp, typ, len, st, offlist) =
match Prop.prop_iter_current iter with
match Prop.prop_iter_current tenv iter with
| (Sil.Hpointsto(lexp, strexp, Exp.Sizeof (typ, len, st)), offlist) ->
(lexp, strexp, typ, len, st, offlist)
| _ -> assert false in
let p = Prop.prop_iter_to_prop iter in
let p = Prop.prop_iter_to_prop tenv iter in
let new_ptsto, pred_insts_op =
ptsto_update pdesc tenv p (lexp, strexp, typ, len, st) offlist rhs_exp in
let update acc (pi, sigma) =
let sigma' = new_ptsto:: sigma in
let iter' = update_iter iter pi sigma' in
let prop' = Prop.prop_iter_to_prop iter' in
let prop' = Prop.prop_iter_to_prop tenv iter' in
prop' :: acc in
match pred_insts_op with
| None -> update acc_in ([],[])
| Some pred_insts -> IList.fold_left update acc_in pred_insts in
try
let n_lhs_exp, prop_' = check_arith_norm_exp pname lhs_exp prop_ in
let n_rhs_exp, prop = check_arith_norm_exp pname rhs_exp prop_' in
let prop = Attribute.replace_objc_null prop n_lhs_exp n_rhs_exp in
let n_lhs_exp' = Prop.exp_collapse_consecutive_indices_prop typ n_lhs_exp in
let n_lhs_exp, prop_' = check_arith_norm_exp tenv pname lhs_exp prop_ in
let n_rhs_exp, prop = check_arith_norm_exp tenv pname rhs_exp prop_' in
let prop = Attribute.replace_objc_null tenv prop n_lhs_exp n_rhs_exp in
let n_lhs_exp' = Prop.exp_collapse_consecutive_indices_prop tenv typ n_lhs_exp in
let iter_list = Rearrange.rearrange ~report_deref_errors pdesc tenv n_lhs_exp' typ prop loc in
IList.rev (IList.fold_left (execute_store_ pdesc tenv n_rhs_exp) [] iter_list)
with Rearrange.ARRAY_ACCESS ->
@ -1002,11 +1002,11 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
IList.map (fun p -> (p, path)) pl in
let instr = match _instr with
| Sil.Call (ret, exp, par, loc, call_flags) ->
let exp' = Prop.exp_normalize_prop prop_ exp in
let exp' = Prop.exp_normalize_prop tenv prop_ exp in
let instr' = match exp' with
| Exp.Closure c ->
let proc_exp = Exp.Const (Const.Cfun c.name) in
let proc_exp' = Prop.exp_normalize_prop prop_ proc_exp in
let proc_exp' = Prop.exp_normalize_prop tenv prop_ proc_exp in
let par' = IList.map (fun (id_exp, _, typ) -> (id_exp, typ)) c.captured_vars in
Sil.Call (ret, proc_exp', par' @ par, loc, call_flags)
| _ ->
@ -1031,7 +1031,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
pdesc= current_pdesc; instr; tenv; prop_= prop; path; ret_ids; args= actual_args;
proc_name= callee_pname; loc; } in
if is_objc_instance_method then
handle_objc_instance_method_call_or_skip actual_args path callee_pname prop ret_ids skip_res
handle_objc_instance_method_call_or_skip tenv actual_args path callee_pname prop ret_ids skip_res
else skip_res () in
let call_args prop_ proc_name args ret_ids loc = {
Builtin.pdesc = current_pdesc; instr; tenv; prop_; path; ret_ids; args; proc_name; loc; } in
@ -1043,7 +1043,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
execute_store current_pname current_pdesc tenv lhs_exp typ rhs_exp loc prop_
|> ret_old_path
| Sil.Prune (cond, loc, true_branch, ik) ->
let prop__ = Attribute.nullify_exp_with_objc_null prop_ cond in
let prop__ = Attribute.nullify_exp_with_objc_null tenv prop_ cond in
let check_condition_always_true_false () =
let report_condition_always_true_false i =
let skip_loop = match ik with
@ -1055,20 +1055,20 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
true (* skip subpart of a condition obtained from compilation of && and || *)
| _ -> false in
true_branch && not skip_loop in
match Prop.exp_normalize_prop Prop.prop_emp cond with
match Prop.exp_normalize_prop tenv Prop.prop_emp cond with
| Exp.Const (Const.Cint i) when report_condition_always_true_false i ->
let node = State.get_node () in
let desc = Errdesc.explain_condition_always_true_false i cond node loc in
let desc = Errdesc.explain_condition_always_true_false tenv i cond node loc in
let exn =
Exceptions.Condition_always_true_false (desc, not (IntLit.iszero i), __POS__) in
let pre_opt = State.get_normalized_pre (Abs.abstract_no_symop current_pname) in
Reporting.log_warning current_pname ?pre:pre_opt exn
| _ -> () in
if not Config.report_runtime_exceptions then
check_already_dereferenced current_pname cond prop__;
check_already_dereferenced tenv current_pname cond prop__;
check_condition_always_true_false ();
let n_cond, prop = check_arith_norm_exp current_pname cond prop__ in
ret_old_path (Propset.to_proplist (prune ~positive:true n_cond prop))
let n_cond, prop = check_arith_norm_exp tenv current_pname cond prop__ in
ret_old_path (Propset.to_proplist (prune tenv ~positive:true n_cond prop))
| Sil.Call (ret_ids, Exp.Const (Const.Cfun callee_pname), args, loc, _)
when Builtin.is_registered callee_pname ->
let sym_exe_builtin = Builtin.get callee_pname in
@ -1077,7 +1077,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
Exp.Const (Const.Cfun ((Procname.Java callee_pname_java) as callee_pname)),
actual_params, loc, call_flags)
when Config.lazy_dynamic_dispatch ->
let norm_prop, norm_args = normalize_params current_pname prop_ actual_params in
let norm_prop, norm_args = normalize_params tenv current_pname prop_ actual_params in
let exec_skip_call skipped_pname ret_annots ret_type =
skip_call norm_prop path skipped_pname ret_annots loc ret_ids (Some ret_type) norm_args in
let resolved_pname, summary_opt =
@ -1103,14 +1103,14 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
| Sil.Call (ret_ids,
Exp.Const (Const.Cfun ((Procname.Java callee_pname_java) as callee_pname)),
actual_params, loc, call_flags) ->
do_error_checks (Paths.Path.curr_node path) instr current_pname current_pdesc;
let norm_prop, norm_args = normalize_params current_pname prop_ actual_params in
do_error_checks tenv (Paths.Path.curr_node path) instr current_pname current_pdesc;
let norm_prop, norm_args = normalize_params tenv current_pname prop_ actual_params in
let url_handled_args =
call_constructor_url_update_args callee_pname norm_args in
let resolved_pnames =
resolve_virtual_pname tenv norm_prop url_handled_args callee_pname call_flags in
let exec_one_pname pname =
Ondemand.analyze_proc_name ~propagate_exceptions:true current_pdesc pname;
Ondemand.analyze_proc_name tenv ~propagate_exceptions:true current_pdesc pname;
let exec_skip_call ret_annots ret_type =
skip_call norm_prop path pname ret_annots loc ret_ids (Some ret_type) url_handled_args in
match Specs.get_summary pname with
@ -1132,13 +1132,13 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
| Sil.Call (ret_ids, Exp.Const (Const.Cfun callee_pname), actual_params, loc, call_flags) ->
(* Generic fun call with known name *)
let (prop_r, n_actual_params) = normalize_params current_pname prop_ actual_params in
let (prop_r, n_actual_params) = normalize_params tenv current_pname prop_ actual_params in
let resolved_pname =
match resolve_virtual_pname tenv prop_r n_actual_params callee_pname call_flags with
| resolved_pname :: _ -> resolved_pname
| [] -> callee_pname in
Ondemand.analyze_proc_name ~propagate_exceptions:true current_pdesc resolved_pname;
Ondemand.analyze_proc_name tenv ~propagate_exceptions:true current_pdesc resolved_pname;
let callee_pdesc_opt = Ondemand.get_proc_desc resolved_pname in
@ -1193,10 +1193,10 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
(call_args prop resolved_pname n_actual_params ret_ids loc) in
IList.flatten (IList.map do_call sentinel_result)
| Sil.Call (ret_ids, fun_exp, actual_params, loc, call_flags) -> (* Call via function pointer *)
let (prop_r, n_actual_params) = normalize_params current_pname prop_ actual_params in
let (prop_r, n_actual_params) = normalize_params tenv current_pname prop_ actual_params in
if call_flags.CallFlags.cf_is_objc_block then
Rearrange.check_call_to_objc_block_error current_pdesc prop_r fun_exp loc;
Rearrange.check_dereference_error current_pdesc prop_r fun_exp loc;
Rearrange.check_call_to_objc_block_error tenv current_pdesc prop_r fun_exp loc;
Rearrange.check_dereference_error tenv current_pdesc prop_r fun_exp loc;
if call_flags.CallFlags.cf_noreturn then begin
L.d_str "Unknown function pointer with noreturn attribute ";
Sil.d_exp fun_exp; L.d_strln ", diverging.";
@ -1221,7 +1221,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
let se' = execute_nullify_se se in
Sil.Hpointsto(e, se', typ):: sigma' in
let eprop_res = Prop.set eprop ~sigma:sigma'' in
ret_old_path [Prop.normalize eprop_res]
ret_old_path [Prop.normalize tenv eprop_res]
| [], _ ->
ret_old_path [prop_]
| _ ->
@ -1232,7 +1232,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
let node = State.get_node () in
let blocks_nullified = get_blocks_nullified node in
IList.iter (check_block_retain_cycle tenv current_pname prop_) blocks_nullified;
if Prover.check_inconsistency prop_
if Prover.check_inconsistency tenv prop_
then
ret_old_path []
else
@ -1240,18 +1240,18 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path
[Abs.remove_redundant_array_elements current_pname tenv
(Abs.abstract current_pname tenv prop_)]
| Sil.Remove_temps (temps, _) ->
ret_old_path [Prop.exist_quantify (Sil.fav_from_list temps) prop_]
ret_old_path [Prop.exist_quantify tenv (Sil.fav_from_list temps) prop_]
| Sil.Declare_locals (ptl, _) ->
let sigma_locals =
let add_None (x, y) = (x, Exp.Sizeof (y, None, Subtype.exact), None) in
let sigma_locals () =
IList.map
(Prop.mk_ptsto_lvar (Some tenv) Prop.Fld_init Sil.inst_initial)
(Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_initial)
(IList.map add_None ptl) in
Config.run_in_re_execution_mode (* no footprint vars for locals *)
sigma_locals () in
let sigma' = prop_.Prop.sigma @ sigma_locals in
let prop' = Prop.normalize (Prop.set prop_ ~sigma:sigma') in
let prop' = Prop.normalize tenv (Prop.set prop_ ~sigma:sigma') in
ret_old_path [prop']
| Sil.Stackop _ -> (* this should be handled at the propset level *)
assert false
@ -1286,7 +1286,7 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
| Sil.Hpointsto (lhs, _, _) when Exp.equal lhs actual_var -> new_hpred
| hpred -> hpred)
prop.Prop.sigma in
Prop.normalize (Prop.set prop ~sigma:sigma') in
Prop.normalize tenv (Prop.set prop ~sigma:sigma') in
let add_actual_by_ref_to_footprint prop (actual, actual_typ, _) =
match actual with
| Exp.Lvar actual_pv ->
@ -1311,7 +1311,7 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
| Typ.Tptr (typ, _) ->
(* for pointer types passed by reference, do abduction directly on the pointer *)
let (prop', fresh_fp_var) =
add_to_footprint abducted_ref_pv typ prop in
add_to_footprint tenv abducted_ref_pv typ prop in
prop', Sil.Eexp (fresh_fp_var, Sil.Inone)
| typ ->
failwith
@ -1325,7 +1325,7 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
Sil.Hpointsto (lhs, abduced_strexp, typ_exp)
| hpred -> hpred)
prop'.Prop.sigma in
Prop.normalize (Prop.set prop' ~sigma:filtered_sigma)
Prop.normalize tenv (Prop.set prop' ~sigma:filtered_sigma)
else
(* bind actual passed by ref to the abducted value pointed to by the synthetic pvar *)
let prop' =
@ -1336,13 +1336,13 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
false
| _ -> true)
prop.Prop.sigma in
Prop.normalize (Prop.set prop ~sigma:filtered_sigma) in
Prop.normalize tenv (Prop.set prop ~sigma:filtered_sigma) in
IList.fold_left
(fun p hpred ->
match hpred with
| Sil.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abducted_ref_pv ->
let new_hpred = Sil.Hpointsto (actual, rhs, texp) in
Prop.normalize (Prop.set p ~sigma:(new_hpred :: prop'.Prop.sigma))
Prop.normalize tenv (Prop.set p ~sigma:(new_hpred :: prop'.Prop.sigma))
| _ -> p)
prop'
prop'.Prop.sigma
@ -1352,7 +1352,7 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
let actual_pt_havocd_var =
let havocd_var = Exp.Var (Ident.create_fresh Ident.kprimed) in
let sizeof_exp = Exp.Sizeof (Typ.strip_ptr actual_typ, None, Subtype.subtypes) in
Prop.mk_ptsto actual (Sil.Eexp (havocd_var, Sil.Inone)) sizeof_exp in
Prop.mk_ptsto tenv actual (Sil.Eexp (havocd_var, Sil.Inone)) sizeof_exp in
replace_actual_hpred actual actual_pt_havocd_var prop in
let do_actual_by_ref =
if Config.angelic_execution then add_actual_by_ref_to_footprint
@ -1373,8 +1373,8 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call
IList.filter is_not_const actuals_by_ref in
IList.fold_left do_actual_by_ref prop non_const_actuals_by_ref
and check_untainted exp taint_kind caller_pname callee_pname prop =
match Attribute.get_taint prop exp with
and check_untainted tenv exp taint_kind caller_pname callee_pname prop =
match Attribute.get_taint tenv prop exp with
| Some (Apred (Ataint taint_info, _)) ->
let err_desc =
Errdesc.explain_tainted_value_reaching_sensitive_function
@ -1387,12 +1387,12 @@ and check_untainted exp taint_kind caller_pname callee_pname prop =
Exceptions.Tainted_value_reaching_sensitive_function
(err_desc, __POS__) in
Reporting.log_warning caller_pname exn;
Attribute.add_or_replace prop (Apred (Auntaint taint_info, [exp]))
Attribute.add_or_replace tenv prop (Apred (Auntaint taint_info, [exp]))
| _ ->
if !Config.footprint then
let taint_info = { PredSymb.taint_source = callee_pname; taint_kind; } in
(* add untained(n_lexp) to the footprint *)
Attribute.add ~footprint:true prop (Auntaint taint_info) [exp]
Attribute.add tenv ~footprint:true prop (Auntaint taint_info) [exp]
else prop
(** execute a call for an unknown or scan function *)
@ -1403,9 +1403,9 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots
let do_exp p (e, _) =
let do_attribute q atom =
match atom with
| Sil.Apred ((Aresource {ra_res = Rfile} as res), _) -> Attribute.remove_for_attr q res
| Sil.Apred ((Aresource {ra_res = Rfile} as res), _) -> Attribute.remove_for_attr tenv q res
| _ -> q in
IList.fold_left do_attribute p (Attribute.get_for_exp p e) in
IList.fold_left do_attribute p (Attribute.get_for_exp tenv p e) in
let filtered_args =
match args, instr with
| _:: other_args, Sil.Call (_, _, _, _, { CallFlags.cf_virtual }) when cf_virtual ->
@ -1422,7 +1422,7 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots
let prop_acc' =
try
let _, taint_kind = IList.find (fun (num, _) -> num = param_num) param_nums in
check_untainted actual_exp taint_kind caller_pname callee_pname prop_acc
check_untainted tenv actual_exp taint_kind caller_pname callee_pname prop_acc
with Not_found -> prop_acc in
prop_acc', param_num + 1 in
IList.fold_left
@ -1446,7 +1446,7 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots
else pre in
let pre_2 = match ret_ids, ret_type_option with
| [ret_id], Some ret_typ ->
add_constraints_on_retval
add_constraints_on_retval tenv
pdesc pre_1 (Exp.Var ret_id) ret_typ ~has_nullable_annot callee_pname loc
| _ ->
pre_1 in
@ -1454,7 +1454,7 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots
let caller_pname = Cfg.Procdesc.get_proc_name pdesc in
add_tainted_pre pre_3 args caller_pname callee_pname in
if is_scan (* if scan function, don't mark anything with undef attributes *)
then [(Tabulation.remove_constant_string_class pre_final, path)]
then [(Tabulation.remove_constant_string_class tenv pre_final, path)]
else
(* otherwise, add undefined attribute to retvals and actuals passed by ref *)
let exps_to_mark =
@ -1463,7 +1463,7 @@ and unknown_or_scan_call ~is_scan ret_type_option ret_annots
(fun exps_to_mark (exp, _, _) -> exp :: exps_to_mark) ret_exps actuals_by_ref in
let prop_with_undef_attr =
let path_pos = State.get_path_pos () in
Attribute.mark_vars_as_undefined
Attribute.mark_vars_as_undefined tenv
pre_final exps_to_mark callee_pname ret_annots loc path_pos in
[(prop_with_undef_attr, path)]
@ -1495,7 +1495,7 @@ and check_variadic_sentinel
if not fails_on_nil then
let deref_str = Localise.deref_str_nil_argument_in_variadic_method proc_name nargs i in
let err_desc =
Errdesc.explain_dereference ~use_buckets: true ~is_premature_nil: true
Errdesc.explain_dereference tenv ~use_buckets: true ~is_premature_nil: true
deref_str prop_ loc in
raise (Exceptions.Premature_nil_termination (err_desc, __POS__))
else
@ -1637,12 +1637,12 @@ and sym_exec_wrapper handle_exn tenv pdesc instr ((prop: Prop.normal Prop.t), pa
let ren_sub =
Sil.sub_of_list (IList.map
(fun (id1, id2) -> (id1, Exp.Var id2)) ids_primed_normal) in
let p' = Prop.normalize (Prop.prop_sub ren_sub p) in
let p' = Prop.normalize tenv (Prop.prop_sub ren_sub p) in
let fav_normal = Sil.fav_from_list (IList.map snd ids_primed_normal) in
p', fav_normal in
let prop_normal_to_primed fav_normal p = (* rename given normal vars to fresh primed *)
if Sil.fav_to_list fav_normal = [] then p
else Prop.exist_quantify fav_normal p in
else Prop.exist_quantify tenv fav_normal p in
try
let pre_process_prop p =
let p', fav =
@ -1651,9 +1651,9 @@ and sym_exec_wrapper handle_exn tenv pdesc instr ((prop: Prop.normal Prop.t), pa
else prop_primed_to_normal p in
let p'' =
let map_res_action e ra = (* update the vpath in resource attributes *)
let vpath, _ = Errdesc.vpath_find p' e in
let vpath, _ = Errdesc.vpath_find tenv p' e in
{ ra with PredSymb.ra_vpath = vpath } in
Attribute.map_resource p' map_res_action in
Attribute.map_resource tenv p' map_res_action in
p'', fav in
let post_process_result fav_normal p path =
let p' = prop_normal_to_primed fav_normal p in
@ -1683,7 +1683,7 @@ and sym_exec_wrapper handle_exn tenv pdesc instr ((prop: Prop.normal Prop.t), pa
res_list in
let results =
IList.map
(fun (p, path) -> (Prop.prop_rename_primed_footprint_vars p, path))
(fun (p, path) -> (Prop.prop_rename_primed_footprint_vars tenv p, path))
res_list_nojunk in
L.d_strln "Instruction Returns";
Propgraph.d_proplist prop (IList.map fst results); L.d_ln ();
@ -1720,7 +1720,7 @@ let node handle_exn tenv node (pset : Paths.PathSet.t) : Paths.PathSet.t =
let pp_stack_instr pset' =
L.d_str "Stack Instruction "; Sil.d_instr instr; L.d_ln ();
L.d_strln "Stack Instruction Returns";
Propset.d Prop.prop_emp (Paths.PathSet.to_propset pset'); L.d_ln () in
Propset.d Prop.prop_emp (Paths.PathSet.to_propset tenv pset'); L.d_ln () in
match instr, stack with
| Sil.Stackop (Sil.Push, _), _ ->
pp_stack_instr pset;

@ -31,14 +31,14 @@ val unknown_or_scan_call : is_scan:bool -> Typ.t option -> Typ.item_annotation -
val check_variadic_sentinel : ?fails_on_nil:bool -> int -> int * int -> Builtin.t
val check_untainted :
Exp.t -> PredSymb.taint_kind -> Procname.t -> Procname.t -> Prop.normal Prop.t ->
Tenv.t -> Exp.t -> PredSymb.taint_kind -> Procname.t -> Procname.t -> Prop.normal Prop.t ->
Prop.normal Prop.t
(** Check for arithmetic problems and normalize an expression. *)
val check_arith_norm_exp :
Procname.t -> Exp.t -> Prop.normal Prop.t -> Exp.t * Prop.normal Prop.t
Tenv.t -> Procname.t -> Exp.t -> Prop.normal Prop.t -> Exp.t * Prop.normal Prop.t
val prune : positive:bool -> Exp.t -> Prop.normal Prop.t -> Propset.t
val prune : Tenv.t -> positive:bool -> Exp.t -> Prop.normal Prop.t -> Propset.t
(** OO method resolution: given a class name and a method name, climb the class hierarchy to find
the procname that the method name will actually resolve to at runtime. For example, if we have a

@ -83,9 +83,9 @@ let d_splitting split =
L.d_strln "------------------------------------------------------------";
L.d_decrease_indent 1
let print_results actual_pre results =
let print_results tenv actual_pre results =
L.d_strln "***** RESULTS FUNCTION CALL *******";
Propset.d actual_pre (Propset.from_proplist results);
Propset.d actual_pre (Propset.from_proplist tenv results);
L.d_strln "***** END RESULTS FUNCTION CALL *******"
(***************)
@ -284,12 +284,12 @@ and find_dereference_without_null_check_in_sexp_list = function
(** Check dereferences implicit in the spec pre.
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_dereferences tenv callee_pname actual_pre sub spec_pre formal_params =
let check_dereference e sexp =
let e_sub = Sil.exp_sub sub e in
let desc use_buckets deref_str =
let error_desc =
Errdesc.explain_dereference_as_caller_expression
Errdesc.explain_dereference_as_caller_expression tenv
~use_buckets
deref_str actual_pre spec_pre e (State.get_node ()) (State.get_loc ()) formal_params in
(L.d_strln_color Red) "found error in dereference";
@ -313,15 +313,15 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
else
(* Check if the dereferenced expr has the dangling uninitialized attribute. *)
(* In that case it raise a dangling pointer dereferece *)
if Attribute.has_dangling_uninit spec_pre e then
if Attribute.has_dangling_uninit tenv spec_pre e then
Some (Deref_undef_exp, desc false (Localise.deref_str_dangling (Some PredSymb.DAuninit)) )
else if Exp.equal e_sub Exp.minus_one
then Some (Deref_minusone, desc true (Localise.deref_str_dangling None))
else match Attribute.get_resource actual_pre e_sub with
else match Attribute.get_resource tenv actual_pre e_sub with
| Some (Apred (Aresource ({ ra_kind = Rrelease } as ra), _)) ->
Some (Deref_freed ra, desc true (Localise.deref_str_freed ra))
| _ ->
(match Attribute.get_undef actual_pre e_sub with
(match Attribute.get_undef tenv actual_pre e_sub with
| Some (Apred (Aundef (s, _, loc, pos), _)) ->
Some (Deref_undef (s, loc, pos), desc false (Localise.deref_str_undef (s, loc)))
| _ -> None) in
@ -352,19 +352,19 @@ let check_dereferences callee_pname actual_pre sub spec_pre formal_params =
with Not_found -> deref_err)
else Some deref_err
let post_process_sigma (sigma: Sil.hpred list) loc : Sil.hpred list =
let post_process_sigma tenv (sigma: Sil.hpred list) loc : Sil.hpred list =
let map_inst inst = Sil.inst_new_loc loc inst in
let do_hpred (_, _, hpred) = Sil.hpred_instmap map_inst hpred in
(* update the location of instrumentations *)
IList.map (fun hpred -> do_hpred (Prover.expand_hpred_pointer false hpred)) sigma
IList.map (fun hpred -> do_hpred (Prover.expand_hpred_pointer tenv false hpred)) sigma
(** check for interprocedural path errors in the post *)
let check_path_errors_in_post caller_pname post post_path =
let check_path_errors_in_post tenv caller_pname post post_path =
let check_attr atom =
match atom with
| Sil.Apred (Adiv0 path_pos, [e]) ->
if Prover.check_zero e then
let desc = Errdesc.explain_divide_by_zero e (State.get_node ()) (State.get_loc ()) in
if Prover.check_zero tenv e then
let desc = Errdesc.explain_divide_by_zero tenv e (State.get_node ()) (State.get_loc ()) in
let new_path, path_pos_opt =
let current_path, _ = State.get_path () in
if Paths.Path.contains_position post_path path_pos
@ -380,24 +380,24 @@ let check_path_errors_in_post caller_pname post post_path =
(** 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 *)
let post_process_post
let post_process_post tenv
caller_pname callee_pname loc actual_pre ((post: Prop.exposed Prop.t), post_path) =
let actual_pre_has_freed_attribute e = match Attribute.get_resource actual_pre e with
let actual_pre_has_freed_attribute e = match Attribute.get_resource tenv actual_pre e with
| Some (Apred (Aresource ({ ra_kind = Rrelease }), _)) -> true
| _ -> false in
let atom_update_alloc_attribute = function
| Sil.Apred (Aresource ra, [e])
when not (ra.ra_kind = PredSymb.Rrelease && actual_pre_has_freed_attribute e) ->
(* unless it was already freed before the call *)
let vpath, _ = Errdesc.vpath_find post e in
let vpath, _ = Errdesc.vpath_find tenv post e in
let ra' = { ra with ra_pname = callee_pname; ra_loc = loc; ra_vpath = vpath } in
Sil.Apred (Aresource ra', [e])
| a -> a in
let prop' = Prop.set post ~sigma:(post_process_sigma post.Prop.sigma loc) in
let prop' = Prop.set post ~sigma:(post_process_sigma tenv post.Prop.sigma loc) in
let pi' = IList.map atom_update_alloc_attribute prop'.Prop.pi in
(* update alloc attributes to refer to the caller *)
let post' = Prop.set prop' ~pi:pi' in
check_path_errors_in_post caller_pname post' post_path;
check_path_errors_in_post tenv caller_pname post' post_path;
post', post_path
let hpred_lhs_compare hpred1 hpred2 = match hpred1, hpred2 with
@ -457,7 +457,7 @@ and sexp_star_fld se1 se2 : Sil.strexp =
L.d_ln ();
assert false
let texp_star texp1 texp2 =
let texp_star _tenv texp1 texp2 =
let rec ftal_sub ftal1 ftal2 = match ftal1, ftal2 with
| [], _ -> true
| _, [] -> false
@ -478,16 +478,16 @@ let texp_star texp1 texp2 =
| _ ->
texp1
let hpred_star_fld (hpred1 : Sil.hpred) (hpred2 : Sil.hpred) : Sil.hpred =
let hpred_star_fld tenv (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 (); *)
Sil.Hpointsto(e1, sexp_star_fld se1 se2, texp_star t1 t2)
Sil.Hpointsto(e1, sexp_star_fld se1 se2, texp_star tenv t1 t2)
| _ -> assert false
(** Implementation of [*] for the field-splitting model *)
let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpred list =
let sigma_star_fld tenv (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpred list =
let sigma1 = IList.stable_sort hpred_lhs_compare sigma1 in
let sigma2 = IList.stable_sort hpred_lhs_compare sigma2 in
(* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *)
@ -498,7 +498,7 @@ let sigma_star_fld (sigma1 : Sil.hpred list) (sigma2 : Sil.hpred list) : Sil.hpr
| hpred1:: sigma1', hpred2:: sigma2' ->
begin
match hpred_lhs_compare hpred1 hpred2 with
| 0 -> hpred_star_fld hpred1 hpred2 :: star sigma1' sigma2'
| 0 -> hpred_star_fld tenv hpred1 hpred2 :: star sigma1' sigma2'
| n when n < 0 -> hpred1 :: star sigma1' sg2
| _ -> star sg1 sigma2'
end
@ -546,7 +546,7 @@ let sigma_star_typ
(** [prop_footprint_add_pi_sigma_starfld_sigma prop pi sigma missing_fld]
extends the footprint of [prop] with [pi,sigma]
and extends the fields of |-> with [missing_fld] *)
let prop_footprint_add_pi_sigma_starfld_sigma
let prop_footprint_add_pi_sigma_starfld_sigma tenv
(prop : 'a Prop.t) pi_new sigma_new missing_fld missing_typ : Prop.normal Prop.t option =
let rec extend_sigma current_sigma new_sigma = match new_sigma with
| [] -> Some current_sigma
@ -576,10 +576,10 @@ let prop_footprint_add_pi_sigma_starfld_sigma
match extend_sigma prop.Prop.sigma_fp sigma_new with
| None -> None
| Some sigma' ->
let sigma_fp' = sigma_star_fld sigma' missing_fld in
let sigma_fp' = sigma_star_fld tenv sigma' missing_fld in
let sigma_fp'' = sigma_star_typ sigma_fp' missing_typ in
let pi' = pi_new @ prop.Prop.pi in
Some (Prop.normalize (Prop.set prop ~pi:pi' ~pi_fp:pi_fp' ~sigma_fp:sigma_fp''))
Some (Prop.normalize tenv (Prop.set prop ~pi:pi' ~pi_fp:pi_fp' ~sigma_fp:sigma_fp''))
(** Check if the attribute change is a mismatch between a kind
of allocation and a different kind of deallocation *)
@ -592,7 +592,7 @@ let check_attr_dealloc_mismatch att_old att_new = match att_old, att_new with
| _ -> ()
(** [prop_copy_footprint p1 p2] copies the footprint and pure part of [p1] into [p2] *)
let prop_copy_footprint_pure p1 p2 =
let prop_copy_footprint_pure tenv p1 p2 =
let p2' =
Prop.set p2 ~pi_fp:p1.Prop.pi_fp ~sigma_fp:p1.Prop.sigma_fp in
let pi2 = p2'.Prop.pi in
@ -601,10 +601,10 @@ let prop_copy_footprint_pure p1 p2 =
let replace_attr prop atom = (* call replace_atom_attribute which deals with existing attibutes *)
(* if [atom] represents an attribute [att], add the attribure to [prop] *)
if Attribute.is_pred atom then
Attribute.add_or_replace_check_changed check_attr_dealloc_mismatch prop atom
Attribute.add_or_replace_check_changed tenv check_attr_dealloc_mismatch prop atom
else
prop in
IList.fold_left replace_attr (Prop.normalize res_noattr) pi2_attr
IList.fold_left replace_attr (Prop.normalize tenv res_noattr) pi2_attr
(** check if an expression is an exception *)
let exp_is_exn = function
@ -647,14 +647,14 @@ let lookup_custom_errors prop =
search_error prop.Prop.sigma
(** set a prop to an exception sexp *)
let prop_set_exn pname prop se_exn =
let prop_set_exn tenv pname prop se_exn =
let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in
let map_hpred = function
| Sil.Hpointsto (e, _, t) when Exp.equal e ret_pvar ->
Sil.Hpointsto(e, se_exn, t)
| hpred -> hpred in
let sigma' = IList.map map_hpred prop.Prop.sigma in
Prop.normalize (Prop.set prop ~sigma:sigma')
Prop.normalize tenv (Prop.set prop ~sigma:sigma')
(** Include a subtrace for a procedure call if the callee is not a model. *)
let include_subtrace callee_pname =
@ -663,7 +663,7 @@ let include_subtrace callee_pname =
not (AttributesTable.is_whitelisted_cpp_method (Procname.to_string callee_pname))
(** combine the spec's post with a splitting and actual precondition *)
let combine
let combine tenv
ret_ids (posts: ('a Prop.t * Paths.Path.t) list)
actual_pre path_pre split
caller_pdesc callee_pname loc =
@ -686,7 +686,7 @@ let combine
posts in
IList.map
(fun (p, path) ->
(post_process_post
(post_process_post tenv
caller_pname callee_pname loc actual_pre (Prop.prop_sub split.sub p, path)))
posts' in
L.d_increase_indent 1;
@ -707,10 +707,10 @@ let combine
L.d_decrease_indent 1; L.d_ln ();
let compute_result post_p =
let post_p' =
let post_sigma = sigma_star_fld post_p.Prop.sigma split.frame_fld in
let post_sigma = sigma_star_fld tenv post_p.Prop.sigma split.frame_fld in
let post_sigma' = sigma_star_typ post_sigma split.frame_typ in
Prop.set post_p ~sigma:post_sigma' in
let post_p1 = Prop.prop_sigma_star (prop_copy_footprint_pure actual_pre post_p') split.frame in
let post_p1 = Prop.prop_sigma_star (prop_copy_footprint_pure tenv actual_pre post_p') split.frame in
let handle_null_case_analysis sigma =
let id_assigned_to_null id =
@ -730,7 +730,7 @@ let combine
let post_p1_sigma = post_p1.Prop.sigma in
let post_p1_sigma' = handle_null_case_analysis post_p1_sigma in
let post_p1' = Prop.set post_p1 ~sigma:post_p1_sigma' in
Prop.normalize (Prop.set post_p1' ~pi:(post_p1.Prop.pi @ split.missing_pi)) in
Prop.normalize tenv (Prop.set post_p1' ~pi:(post_p1.Prop.pi @ split.missing_pi)) in
let post_p3 = (* replace [result|callee] with an aux variable dedicated to this proc *)
let callee_ret_pvar =
@ -744,31 +744,31 @@ let combine
match Prop.prop_iter_find iter filter with
| None -> post_p2
| Some iter' ->
match fst (Prop.prop_iter_current iter') with
match fst (Prop.prop_iter_current tenv iter') with
| Sil.Hpointsto (_, Sil.Eexp (e', inst), _) when exp_is_exn e' ->
(* resuls is an exception: set in caller *)
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
prop_set_exn caller_pname p (Sil.Eexp (e', inst))
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
prop_set_exn tenv caller_pname p (Sil.Eexp (e', inst))
| Sil.Hpointsto (_, Sil.Eexp (e', _), _) when IList.length ret_ids = 1 ->
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
Prop.conjoin_eq e' (Exp.Var (IList.hd ret_ids)) p
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
Prop.conjoin_eq tenv e' (Exp.Var (IList.hd ret_ids)) p
| Sil.Hpointsto (_, Sil.Estruct (ftl, _), _)
when IList.length ftl = IList.length ret_ids ->
let rec do_ftl_ids p = function
| [], [] -> p
| (_, Sil.Eexp (e', _)):: ftl', ret_id:: ret_ids' ->
let p' = Prop.conjoin_eq e' (Exp.Var ret_id) p in
let p' = Prop.conjoin_eq tenv e' (Exp.Var ret_id) p in
do_ftl_ids p' (ftl', ret_ids')
| _ -> p in
let p = Prop.prop_iter_remove_curr_then_to_prop iter' in
let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in
do_ftl_ids p (ftl, ret_ids)
| Sil.Hpointsto _ -> (* returning nothing or unexpected sexp, turning into nondet *)
Prop.prop_iter_remove_curr_then_to_prop iter'
Prop.prop_iter_remove_curr_then_to_prop tenv iter'
| _ -> assert false in
let post_p4 =
if !Config.footprint
then
prop_footprint_add_pi_sigma_starfld_sigma
prop_footprint_add_pi_sigma_starfld_sigma tenv
post_p3
split.missing_pi
split.missing_sigma
@ -783,11 +783,11 @@ let combine
let results =
IList.map (function (Some x, path) -> (x, path) | (None, _) -> assert false)
_results in
print_results actual_pre (IList.map fst results);
print_results tenv actual_pre (IList.map fst results);
Some results
(* Add Auntaint attribute to a callee_pname precondition *)
let mk_pre pre formal_params callee_pname callee_attrs =
let mk_pre tenv pre formal_params callee_pname callee_attrs =
if Config.taint_analysis
then
match Taint.accepts_sensitive_params callee_pname (Some callee_attrs) with
@ -797,8 +797,8 @@ let mk_pre pre formal_params callee_pname callee_attrs =
|> IList.fold_left
(fun prop_acc (param, taint_kind) ->
let attr = PredSymb.Auntaint { taint_source = callee_pname; taint_kind; } in
Taint.add_tainting_attribute attr param prop_acc)
(Prop.normalize pre)
Taint.add_tainting_attribute tenv attr param prop_acc)
(Prop.normalize tenv pre)
|> Prop.expose
else pre
@ -815,7 +815,7 @@ let report_taint_error e taint_info callee_pname caller_pname calling_prop =
(err_desc, __POS__) in
Reporting.log_warning caller_pname exn
let check_taint_on_variadic_function callee_pname caller_pname actual_params calling_prop =
let check_taint_on_variadic_function tenv callee_pname caller_pname actual_params calling_prop =
let rec n_tail lst n = (* return the tail of a list from element n *)
if n = 1 then lst
else match lst with
@ -831,7 +831,7 @@ let check_taint_on_variadic_function callee_pname caller_pname actual_params cal
L.d_str "Paramters to be checked: [ ";
IList.iter(fun (e,_) ->
L.d_str (" " ^ (Sil.exp_to_string e) ^ " ");
match Attribute.get_taint calling_prop e with
match Attribute.get_taint tenv calling_prop e with
| Some (Apred (Ataint taint_info, _)) ->
report_taint_error e taint_info callee_pname caller_pname calling_prop
| _ -> ()) actual_params';
@ -841,7 +841,7 @@ let check_taint_on_variadic_function callee_pname caller_pname actual_params cal
(** Construct the actual precondition: add to the current state a copy
of the (callee's) formal parameters instantiated with the actual
parameters. *)
let mk_actual_precondition prop actual_params formal_params =
let mk_actual_precondition tenv prop actual_params formal_params =
let formals_actuals =
let rec comb fpars apars = match fpars, apars with
| f:: fpars', a:: apars' -> (f, a) :: comb fpars' apars'
@ -860,15 +860,15 @@ let mk_actual_precondition prop actual_params formal_params =
| _:: _,[] -> raise (Exceptions.Wrong_argument_number __POS__) in
comb formal_params actual_params in
let mk_instantiation (formal_var, (actual_e, actual_t)) =
Prop.mk_ptsto
Prop.mk_ptsto tenv
(Exp.Lvar formal_var)
(Sil.Eexp (actual_e, Sil.inst_actual_precondition))
(Exp.Sizeof (actual_t, None, Subtype.exact)) in
let instantiated_formals = IList.map mk_instantiation formals_actuals in
let actual_pre = Prop.prop_sigma_star prop instantiated_formals in
Prop.normalize actual_pre
Prop.normalize tenv actual_pre
let mk_posts ret_ids prop callee_pname callee_attrs posts =
let mk_posts tenv ret_ids prop callee_pname callee_attrs posts =
match ret_ids with
| [ret_id] ->
let mk_getter_idempotent posts =
@ -880,7 +880,7 @@ let mk_posts ret_ids prop callee_pname callee_attrs posts =
IList.exists
(function
| Sil.Apred (Aretval (pname, _), [exp]) when Procname.equal callee_pname pname ->
Prover.check_disequal prop exp Exp.zero
Prover.check_disequal tenv prop exp Exp.zero
| _ -> false)
(Attribute.get_all prop) in
if last_call_ret_non_null then
@ -888,7 +888,7 @@ let mk_posts ret_ids prop callee_pname callee_attrs posts =
IList.exists
(function
| Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar ->
Prover.check_equal (Prop.normalize prop) e Exp.zero
Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero
| _ -> false)
prop.Prop.sigma in
IList.filter (fun (prop, _) -> not (returns_null prop)) posts
@ -897,9 +897,9 @@ let mk_posts ret_ids prop callee_pname callee_attrs posts =
match Taint.returns_tainted callee_pname (Some callee_attrs) with
| Some taint_kind ->
let taint_retval (prop, path) =
let prop_normal = Prop.normalize prop in
let prop_normal = Prop.normalize tenv prop in
let prop' =
Attribute.add_or_replace prop_normal
Attribute.add_or_replace tenv prop_normal
(Apred (Ataint { taint_source = callee_pname; taint_kind; }, [Exp.Var ret_id]))
|> Prop.expose in
(prop', path) in
@ -913,17 +913,17 @@ let mk_posts ret_ids prop callee_pname callee_attrs posts =
| _ -> posts
(** Check if actual_pre * missing_footprint |- false *)
let inconsistent_actualpre_missing actual_pre split_opt =
let inconsistent_actualpre_missing tenv actual_pre split_opt =
match split_opt with
| Some split ->
let prop'= Prop.normalize (Prop.prop_sigma_star actual_pre split.missing_sigma) in
let prop''= IList.fold_left Prop.prop_atom_and prop' split.missing_pi in
Prover.check_inconsistency prop''
let prop'= Prop.normalize tenv (Prop.prop_sigma_star actual_pre split.missing_sigma) in
let prop''= IList.fold_left (Prop.prop_atom_and tenv) prop' split.missing_pi in
Prover.check_inconsistency tenv prop''
| None -> false
(* perform the taint analysis check by comparing the taint atoms in [calling_pi] with the untaint
atoms required by the [missing_pi] computed during abduction *)
let do_taint_check caller_pname callee_pname calling_prop missing_pi sub actual_params =
let do_taint_check tenv caller_pname callee_pname calling_prop missing_pi sub actual_params =
let calling_pi = calling_prop.Prop.pi in
(* get a version of [missing_pi] whose var names match the names in calling pi *)
let missing_pi_sub = Prop.pi_sub sub missing_pi in
@ -969,29 +969,29 @@ let do_taint_check caller_pname callee_pname calling_prop missing_pi sub actual_
(fun a -> Sil.atom_equal atom a)
untaint_atoms)
taint_untaint_exp_map) in
check_taint_on_variadic_function callee_pname caller_pname actual_params calling_prop;
check_taint_on_variadic_function tenv callee_pname caller_pname actual_params calling_prop;
IList.filter not_untaint_atom missing_pi_sub
let class_cast_exn pname_opt texp1 texp2 exp ml_loc =
let class_cast_exn tenv pname_opt texp1 texp2 exp ml_loc =
let desc =
Errdesc.explain_class_cast_exception
Errdesc.explain_class_cast_exception tenv
pname_opt texp1 texp2 exp (State.get_node ()) (State.get_loc ()) in
Exceptions.Class_cast_exception (desc, ml_loc)
let raise_cast_exception ml_loc pname_opt texp1 texp2 exp =
let exn = class_cast_exn pname_opt texp1 texp2 exp ml_loc in
let raise_cast_exception tenv ml_loc pname_opt texp1 texp2 exp =
let exn = class_cast_exn tenv pname_opt texp1 texp2 exp ml_loc in
raise exn
let get_check_exn check callee_pname loc ml_loc = match check with
let get_check_exn tenv check callee_pname loc ml_loc = match check with
| Prover.Bounds_check ->
let desc = Localise.desc_precondition_not_met (Some Localise.Pnm_bounds) callee_pname loc in
Exceptions.Precondition_not_met (desc, ml_loc)
| Prover.Class_cast_check (texp1, texp2, exp) ->
class_cast_exn (Some callee_pname) texp1 texp2 exp ml_loc
class_cast_exn tenv (Some callee_pname) texp1 texp2 exp ml_loc
let check_uninitialize_dangling_deref callee_pname actual_pre sub formal_params props =
let check_uninitialize_dangling_deref tenv callee_pname actual_pre sub formal_params props =
IList.iter (fun (p, _ ) ->
match check_dereferences callee_pname actual_pre sub p formal_params with
match check_dereferences tenv callee_pname actual_pre sub p formal_params with
| Some (Deref_undef_exp, desc) ->
raise (Exceptions.Dangling_pointer_dereference (Some PredSymb.DAuninit, desc, __POS__))
| _ -> ()) props
@ -1001,10 +1001,10 @@ let exe_spec
tenv ret_ids (n, nspecs) caller_pdesc callee_pname callee_attrs loc prop path_pre
(spec : Prop.exposed Specs.spec) actual_params formal_params : abduction_res =
let caller_pname = Cfg.Procdesc.get_proc_name caller_pdesc in
let posts = mk_posts ret_ids prop callee_pname callee_attrs spec.Specs.posts in
let actual_pre = mk_actual_precondition prop actual_params formal_params in
let posts = mk_posts tenv ret_ids prop callee_pname callee_attrs spec.Specs.posts in
let actual_pre = mk_actual_precondition tenv prop actual_params formal_params in
let spec_pre =
mk_pre (Specs.Jprop.to_prop spec.Specs.pre) formal_params callee_pname callee_attrs in
mk_pre tenv (Specs.Jprop.to_prop spec.Specs.pre) formal_params callee_pname callee_attrs in
L.d_strln ("EXECUTING SPEC " ^ string_of_int n ^ "/" ^ string_of_int nspecs);
L.d_strln "ACTUAL PRECONDITION =";
L.d_increase_indent 1; Prop.d_prop actual_pre; L.d_decrease_indent 1; L.d_ln ();
@ -1017,18 +1017,18 @@ let exe_spec
(checks, sub1, sub2, frame, missing_pi, missing_sigma,
frame_fld, missing_fld, frame_typ, missing_typ) ->
let log_check_exn check =
let exn = get_check_exn check callee_pname loc __POS__ in
let exn = get_check_exn tenv check callee_pname loc __POS__ in
Reporting.log_warning caller_pname exn in
let do_split () =
let missing_pi' =
if Config.taint_analysis then
do_taint_check caller_pname callee_pname actual_pre missing_pi sub2 actual_params
do_taint_check tenv caller_pname callee_pname actual_pre missing_pi sub2 actual_params
else missing_pi in
process_splitting
actual_pre sub1 sub2 frame missing_pi' missing_sigma
frame_fld missing_fld frame_typ missing_typ in
let report_valid_res split =
match combine
match combine tenv
ret_ids posts
actual_pre path_pre split
caller_pdesc callee_pname loc with
@ -1036,11 +1036,11 @@ let exe_spec
| Some results ->
(* After combining we check that we have not added
a points-to of initialized variables.*)
check_uninitialize_dangling_deref
check_uninitialize_dangling_deref tenv
callee_pname actual_pre split.sub formal_params results;
let inconsistent_results, consistent_results =
IList.partition (fun (p, _) -> Prover.check_inconsistency p) results in
let incons_pre_missing = inconsistent_actualpre_missing actual_pre (Some split) in
IList.partition (fun (p, _) -> Prover.check_inconsistency tenv p) results in
let incons_pre_missing = inconsistent_actualpre_missing tenv actual_pre (Some split) in
Valid_res { incons_pre_missing = incons_pre_missing;
vr_pi = split.missing_pi;
vr_sigma = split.missing_sigma;
@ -1049,7 +1049,7 @@ let exe_spec
begin
IList.iter log_check_exn checks;
let subbed_pre = (Prop.prop_sub sub1 actual_pre) in
match check_dereferences callee_pname subbed_pre sub2 spec_pre formal_params with
match check_dereferences tenv callee_pname subbed_pre sub2 spec_pre formal_params with
| Some (Deref_undef _, _) when Config.angelic_execution ->
let split = do_split () in
report_valid_res split
@ -1084,25 +1084,25 @@ let exe_spec
else report_valid_res split
end
let remove_constant_string_class prop =
let remove_constant_string_class tenv prop =
let filter = function
| Sil.Hpointsto (Exp.Const (Const.Cstr _ | Const.Cclass _), _, _) -> false
| _ -> true in
let sigma = IList.filter filter prop.Prop.sigma in
let sigmafp = IList.filter filter prop.Prop.sigma_fp in
let prop' = Prop.set prop ~sigma ~sigma_fp:sigmafp in
Prop.normalize prop'
Prop.normalize tenv prop'
(** existentially quantify the path identifier generated
by the prover to keep track of expansions of lhs paths
and remove pointsto's whose lhs is a constant string *)
let quantify_path_idents_remove_constant_strings (prop: Prop.normal Prop.t) : Prop.normal Prop.t =
let quantify_path_idents_remove_constant_strings tenv (prop: Prop.normal Prop.t) : Prop.normal Prop.t =
let fav = Prop.prop_fav prop in
Sil.fav_filter_ident fav Ident.is_path;
remove_constant_string_class (Prop.exist_quantify fav prop)
remove_constant_string_class tenv (Prop.exist_quantify tenv fav prop)
(** Strengthen the footprint by adding pure facts from the current part *)
let prop_pure_to_footprint (p: 'a Prop.t) : Prop.normal Prop.t =
let prop_pure_to_footprint tenv (p: 'a Prop.t) : Prop.normal Prop.t =
let is_footprint_atom_not_attribute a =
not (Attribute.is_pred a)
&&
@ -1113,10 +1113,10 @@ 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.set p ~pi_fp:(p.Prop.pi_fp @ new_footprint_atoms))
Prop.normalize tenv (Prop.set p ~pi_fp:(p.Prop.pi_fp @ new_footprint_atoms))
(** post-process the raw result of a function call *)
let exe_call_postprocess ret_ids trace_call callee_pname callee_attrs loc results =
let exe_call_postprocess tenv ret_ids trace_call callee_pname callee_attrs loc results =
let filter_valid_res = function
| Invalid_res _ -> false
| Valid_res _ -> true in
@ -1191,7 +1191,7 @@ let exe_call_postprocess ret_ids trace_call callee_pname callee_attrs loc result
else if IList.exists (function
| Prover_checks (check :: _) ->
trace_call Specs.CallStats.CR_not_met;
let exn = get_check_exn check callee_pname loc __POS__ in
let exn = get_check_exn tenv check callee_pname loc __POS__ in
raise exn
| _ -> false) invalid_res then
call_desc (Some Localise.Pnm_bounds)
@ -1206,13 +1206,13 @@ let exe_call_postprocess ret_ids trace_call callee_pname callee_attrs loc result
then (* no consistent results on one spec: divergence *)
let incons_res =
IList.map
(fun (p, path) -> (prop_pure_to_footprint p, path))
(fun (p, path) -> (prop_pure_to_footprint tenv 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
IList.map
(fun (p, path) -> (prop_pure_to_footprint p, path))
(fun (p, path) -> (prop_pure_to_footprint tenv p, path))
(IList.flatten (IList.map process_valid_res valid_res))
end
else if valid_res_no_miss_pi != [] then
@ -1224,7 +1224,7 @@ let exe_call_postprocess ret_ids trace_call callee_pname callee_attrs loc result
L.d_strln "Missing pure facts for the function call:";
IList.iter print_pi (IList.map (fun vr -> vr.vr_pi) valid_res_miss_pi);
match
Prover.find_minimum_pure_cover
Prover.find_minimum_pure_cover tenv
(IList.map (fun vr -> (vr.vr_pi, vr.vr_cons_res)) valid_res_miss_pi) with
| None ->
trace_call Specs.CallStats.CR_not_met;
@ -1237,7 +1237,7 @@ let exe_call_postprocess ret_ids trace_call callee_pname callee_attrs loc result
trace_call Specs.CallStats.CR_success;
let res =
IList.map
(fun (p, path) -> (quantify_path_idents_remove_constant_strings p, path))
(fun (p, path) -> (quantify_path_idents_remove_constant_strings tenv p, path))
res_with_path_idents in
let ret_annot, _ = callee_attrs.ProcAttributes.method_annotation in
let returns_nullable ret_annot = Annotations.ia_is_nullable ret_annot in
@ -1257,7 +1257,7 @@ let exe_call_postprocess ret_ids trace_call callee_pname callee_attrs loc result
let ret_var = Exp.Var ret_id in
let mark_id_as_retval (p, path) =
let att_retval = PredSymb.Aretval (callee_pname, ret_annot) in
Attribute.add p att_retval [ret_var], path in
Attribute.add tenv p att_retval [ret_var], path in
IList.map mark_id_as_retval res
| _ -> res
@ -1295,7 +1295,7 @@ let exe_function_call
actual_params
formal_params in
let results = IList.map exe_one_spec spec_list in
exe_call_postprocess ret_ids trace_call callee_pname callee_attrs loc results
exe_call_postprocess tenv ret_ids trace_call callee_pname callee_attrs loc results
(*
let check_splitting_precondition sub1 sub2 =

@ -16,7 +16,7 @@ open! Utils
type splitting
(** Remove constant string or class from a prop *)
val remove_constant_string_class : 'a Prop.t -> Prop.normal Prop.t
val remove_constant_string_class : Tenv.t -> 'a Prop.t -> Prop.normal Prop.t
(** Check if the attribute change is a mismatch between a kind of allocation
and a different kind of deallocation *)
@ -28,7 +28,7 @@ val find_dereference_without_null_check_in_sexp : Sil.strexp -> (int * PredSymb.
(** raise a cast exception *)
val raise_cast_exception :
Logging.ml_loc -> Procname.t option -> Exp.t -> Exp.t -> Exp.t -> 'a
Tenv.t -> Logging.ml_loc -> Procname.t option -> Exp.t -> Exp.t -> Exp.t -> 'a
(** check if a prop is an exception *)
val prop_is_exn : Procname.t -> 'a Prop.t -> bool

@ -371,7 +371,7 @@ let get_params_to_taint tainted_param_nums formal_params =
IList.fold_left collect_params_to_taint [] numbered_params
(* add tainting attribute to a pvar in a prop *)
let add_tainting_attribute att pvar_param prop =
let add_tainting_attribute tenv att pvar_param prop =
IList.fold_left
(fun prop_acc hpred ->
match hpred with
@ -379,6 +379,6 @@ let add_tainting_attribute att pvar_param prop =
when Pvar.equal pvar pvar_param ->
L.d_strln ("TAINT ANALYSIS: setting taint/untaint attribute of parameter " ^
(Pvar.to_string pvar));
Attribute.add_or_replace prop_acc (Apred (att, [rhs]))
Attribute.add_or_replace tenv prop_acc (Apred (att, [rhs]))
| _ -> prop_acc)
prop prop.Prop.sigma

@ -23,7 +23,7 @@ val tainted_params : Procname.t -> (int * PredSymb.taint_kind) list
(** returns the taint_kind of [fieldname] if it has a taint source annotation *)
val has_taint_annotation : Ident.fieldname -> Typ.struct_typ -> bool
val add_tainting_attribute : PredSymb.t -> Pvar.t -> Prop.normal Prop.t -> Prop.normal Prop.t
val add_tainting_attribute : Tenv.t -> PredSymb.t -> Pvar.t -> Prop.normal Prop.t -> Prop.normal Prop.t
val get_params_to_taint :
(int * PredSymb.taint_kind) list -> Pvar.t list -> (Pvar.t * PredSymb.taint_kind) list

@ -81,7 +81,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
let procs = Domain.elements astate in
let callees = IList.map
(fun pn ->
match SpecSummary.read_summary pdesc pn with
let tenv = AttributesTable.get_tenv pn in
match SpecSummary.read_summary tenv pdesc pn with
| None | Some None -> (match get_proc_desc pn with
| None -> stacktree_stub_of_procname pn
(* This can happen when the callee is in the same cluster/ buck

@ -339,7 +339,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct
let call_site = CallSite.make callee_pname call_loc in
begin
(* Runs the analysis of callee_pname if not already analyzed *)
match Summary.read_summary pdesc callee_pname with
match Summary.read_summary tenv pdesc callee_pname with
| Some Domain.NonBottom (call_map, _) ->
add_call call_map tenv callee_pname caller_pname call_site astate
| None ->

@ -256,9 +256,9 @@ let get_annotated_signature proc_attributes : 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. *)
let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
let annotated_signature_is_anonymous_inner_class_wrapper tenv ann_sig proc_name =
let check_ret (ia, t) =
Typ.item_annotation_is_empty ia && PatternMatch.type_is_object t in
Typ.item_annotation_is_empty ia && PatternMatch.type_is_object tenv t in
let x_param_found = ref false in
let name_is_x_number name =
let name_str = Mangled.to_string name in
@ -278,7 +278,7 @@ let annotated_signature_is_anonymous_inner_class_wrapper ann_sig proc_name =
else
name_is_x_number name &&
Typ.item_annotation_is_empty ia &&
PatternMatch.type_is_object t in
PatternMatch.type_is_object tenv t in
Procname.java_is_anonymous_inner_class proc_name
&& check_ret ann_sig.ret
&& IList.for_all check_param ann_sig.params

@ -32,7 +32,7 @@ type 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. *)
val annotated_signature_is_anonymous_inner_class_wrapper : annotated_signature -> Procname.t -> bool
val annotated_signature_is_anonymous_inner_class_wrapper : Tenv.t -> annotated_signature -> Procname.t -> bool
(** Check if the given parameter has a Nullable annotation in the given signature *)
val param_is_nullable : Pvar.t -> annotated_signature -> bool

@ -61,13 +61,13 @@ let do_node _ node (s : State.t) : (State.t list) * (State.t list) =
(** Report an error. *)
let report_error description pn pd loc =
let report_error tenv description pn pd loc =
if verbose then L.stderr "ERROR: %s@." description;
Checkers.ST.report_error pn pd "CHECKERS_DEAD_CODE" loc description
Checkers.ST.report_error tenv pn pd "CHECKERS_DEAD_CODE" loc description
(** Check the final state at the end of the analysis. *)
let check_final_state proc_name proc_desc final_s =
let check_final_state tenv proc_name proc_desc final_s =
let proc_nodes = Cfg.Procdesc.get_nodes proc_desc in
let tot_nodes = IList.length proc_nodes in
let tot_visited = State.num_visited final_s in
@ -84,7 +84,7 @@ let check_final_state proc_name proc_desc final_s =
| k when k = Cfg.Node.exn_sink_kind -> false
| _ -> true in
if report
then report_error description proc_name proc_desc loc in
then report_error tenv description proc_name proc_desc loc in
IList.iter do_node not_visited
end
@ -107,7 +107,7 @@ let callback_check_dead_code { Callbacks.proc_desc; proc_name; tenv } =
match transitions exit_node with
| DFDead.Transition (pre_final_s, _, _) ->
let final_s = State.add_visited exit_node pre_final_s in
check_final_state proc_name proc_desc final_s
check_final_state tenv proc_name proc_desc final_s
| DFDead.Dead_state -> ()
end in

@ -37,9 +37,9 @@ let boolean_variables =
]
(** Report a warning in the spec file of the procedure. *)
let report_warning description pn pd loc =
let report_warning tenv description pn pd loc =
if verbose then L.stderr "ERROR: %s@." description;
Checkers.ST.report_error pn pd "CHECKERS_TRACE_CALLS_SEQUENCE" loc description
Checkers.ST.report_error tenv pn pd "CHECKERS_TRACE_CALLS_SEQUENCE" loc description
(** Tracing APIs. *)
@ -188,7 +188,7 @@ end
module Automaton = struct
(** Transfer function for a procedure call. *)
let do_call caller_pn caller_pd callee_pn (s : State.t) loc : State.t =
let do_call tenv caller_pn caller_pd callee_pn (s : State.t) loc : State.t =
let method_name () = match callee_pn with
| Procname.Java pname_java ->
Procname.java_get_method pname_java
@ -202,26 +202,26 @@ module Automaton = struct
else if APIs.is_end callee_pn then
begin
if verbose then L.stderr " calling %s@." (method_name ());
if State.has_zero s then report_warning "too many end/stop" caller_pn caller_pd loc;
if State.has_zero s then report_warning tenv "too many end/stop" caller_pn caller_pd loc;
State.decr s
end
else s
(** Transfer function for an instruction. *)
let do_instr pn pd (instr : Sil.instr) (state : State.t) : State.t =
let do_instr tenv pn pd (instr : Sil.instr) (state : State.t) : State.t =
match instr with
| Sil.Call (_, Exp.Const (Const.Cfun callee_pn), _, loc, _) ->
do_call pn pd callee_pn state loc
do_call tenv pn pd callee_pn state loc
| _ -> state
(** Check if the final state contains any numbers other than zero (balanced). *)
let check_final_state pn pd exit_node (s : State.t) : unit =
let check_final_state tenv pn pd exit_node (s : State.t) : unit =
if verbose then L.stderr "@.Final: %s@." (State.to_string s);
if not (State.is_balanced s) then
begin
let description = Printf.sprintf "%d missing end/stop" (Elem.get_int (State.max s)) in
let loc = Cfg.Node.get_loc exit_node in
report_warning description pn pd loc
report_warning tenv description pn pd loc
end
end
@ -302,13 +302,13 @@ end
(** State transformation for a cfg node. *)
let do_node pn pd idenv _ node (s : State.t) : (State.t list) * (State.t list) =
let do_node tenv pn pd idenv _ node (s : State.t) : (State.t list) * (State.t list) =
if verbose then L.stderr "N:%d S:%s@." (Cfg.Node.get_id node :> int) (State.to_string s);
let curr_state = ref s in
let do_instr instr : unit =
let state1 = Automaton.do_instr pn pd instr !curr_state in
let state1 = Automaton.do_instr tenv pn pd instr !curr_state in
let state2 = BooleanVars.do_instr pn pd idenv instr state1 in
curr_state := state2 in
@ -316,8 +316,8 @@ let do_node pn pd idenv _ node (s : State.t) : (State.t list) * (State.t list) =
[!curr_state], [!curr_state]
(** Check the final state at the end of the analysis. *)
let check_final_state proc_name proc_desc exit_node final_s =
Automaton.check_final_state proc_name proc_desc exit_node final_s;
let check_final_state tenv proc_name proc_desc exit_node final_s =
Automaton.check_final_state tenv proc_name proc_desc exit_node final_s;
BooleanVars.check_final_state proc_name proc_desc exit_node final_s
(** Check that the trace calls are balanced.
@ -329,7 +329,7 @@ let callback_check_trace_call_sequence { Callbacks.proc_desc; proc_name; idenv;
type t = State.t
let equal = State.equal
let join = State.join
let do_node = do_node proc_name proc_desc idenv
let do_node = do_node tenv proc_name proc_desc idenv
let proc_throws pn =
if APIs.is_begin_or_end pn
then DoesNotThrow (* assume the tracing function do not throw *)
@ -343,7 +343,7 @@ let callback_check_trace_call_sequence { Callbacks.proc_desc; proc_name; idenv;
let exit_node = Cfg.Procdesc.get_exit_node proc_desc in
match transitions exit_node with
| DFTrace.Transition (final_s, _, _) ->
check_final_state proc_name proc_desc exit_node final_s
check_final_state tenv proc_name proc_desc exit_node final_s
| DFTrace.Dead_state -> ()
end in

@ -55,16 +55,16 @@ module ST = struct
end
end
let store_summary proc_name =
let store_summary tenv proc_name =
Option.may
(fun summary ->
let summary' =
{ summary with
Specs.timestamp = summary.Specs.timestamp + 1 } in
try Specs.store_summary proc_name summary' with Sys_error s -> L.err "%s@." s)
try Specs.store_summary tenv proc_name summary' with Sys_error s -> L.err "%s@." s)
(Specs.get_summary proc_name)
let report_error
let report_error tenv
proc_name
proc_desc
kind
@ -121,7 +121,7 @@ module ST = struct
let is_class_suppressed =
match PatternMatch.get_this_type proc_attributes with
| Some t -> begin
match (PatternMatch.type_get_annotation t) with
match (PatternMatch.type_get_annotation tenv t) with
| Some ia -> Annotations.ia_has_annotation_with ia annotation_matches
| None -> false
end
@ -158,13 +158,13 @@ module ST = struct
end
end
let report_calls_and_accesses callback node instr =
let report_calls_and_accesses tenv callback node instr =
let proc_desc = Cfg.Node.get_proc_desc node in
let proc_name = Cfg.Procdesc.get_proc_name proc_desc in
let callee = Procname.to_string proc_name in
match PatternMatch.get_java_field_access_signature instr with
| Some (bt, fn, ft) ->
ST.report_error
ST.report_error tenv
proc_name
proc_desc
(callback ^ "_CALLBACK")
@ -173,7 +173,7 @@ let report_calls_and_accesses callback node instr =
| None ->
match PatternMatch.get_java_method_call_formal_signature instr with
| Some (bt, fn, _, rt) ->
ST.report_error
ST.report_error tenv
proc_name
proc_desc
(callback ^ "_CALLBACK")
@ -182,18 +182,23 @@ let report_calls_and_accesses callback node instr =
| None -> ()
(** Report all field accesses and method calls of a procedure. *)
let callback_check_access { Callbacks.proc_desc } =
Cfg.Procdesc.iter_instrs (report_calls_and_accesses "PROC") proc_desc
let callback_check_access { Callbacks.tenv; proc_desc } =
Cfg.Procdesc.iter_instrs (report_calls_and_accesses tenv "PROC") proc_desc
(** Report all field accesses and method calls of a class. *)
let callback_check_cluster_access all_procs get_proc_desc _ =
IList.iter
(Option.may (fun d -> Cfg.Procdesc.iter_instrs (report_calls_and_accesses "CLUSTER") d))
(IList.map get_proc_desc all_procs)
IList.iter (fun proc_name ->
match get_proc_desc proc_name with
| Some proc_desc ->
let tenv = AttributesTable.get_tenv proc_name in
Cfg.Procdesc.iter_instrs (report_calls_and_accesses tenv "CLUSTER") proc_desc
| _ ->
()
) all_procs
(** Looks for writeToParcel methods and checks whether read is in reverse *)
let callback_check_write_to_parcel_java
pname_java ({ Callbacks.proc_desc; idenv; get_proc_desc } as args) =
pname_java ({ Callbacks.tenv; proc_desc; idenv; get_proc_desc } as args) =
let verbose = ref false in
let is_write_to_parcel this_expr this_type =
@ -214,7 +219,7 @@ let callback_check_write_to_parcel_java
PatternMatch.has_formal_method_argument_type_names
proc_desc pname_java ["android.os.Parcel"] in
let parcel_constructors = function
let parcel_constructors _tenv = function
| Typ.Tptr (Typ.Tstruct { Typ.def_methods }, _) ->
IList.filter is_parcel_constructor def_methods
| _ -> [] in
@ -289,7 +294,7 @@ let callback_check_write_to_parcel_java
L.stdout "Serialization check for %a@."
Procname.pp args.Callbacks.proc_name;
try
match parcel_constructors this_type with
match parcel_constructors tenv this_type with
| x :: _ ->
(match get_proc_desc x with
| Some x_proc_desc -> check x_proc_desc proc_desc
@ -542,16 +547,16 @@ let callback_check_field_access { Callbacks.proc_desc } =
Cfg.Procdesc.iter_instrs do_instr proc_desc
(** Print c method calls. *)
let callback_print_c_method_calls { Callbacks.proc_desc; proc_name } =
let callback_print_c_method_calls { Callbacks.tenv; proc_desc; proc_name } =
let do_instr node = function
| Sil.Call (_, Exp.Const (Const.Cfun pn), (e, _):: _, loc, _)
when Procname.is_c_method pn ->
let receiver = match Errdesc.exp_rv_dexp node e with
let receiver = match Errdesc.exp_rv_dexp tenv node e with
| Some de -> DecompiledExp.to_string de
| None -> "?" in
let description =
Printf.sprintf "['%s' %s]" receiver (Procname.to_string pn) in
ST.report_error
ST.report_error tenv
proc_name
proc_desc
"CHECKERS_PRINT_OBJC_METHOD_CALLS"
@ -560,7 +565,7 @@ let callback_print_c_method_calls { Callbacks.proc_desc; proc_name } =
| Sil.Call (_, Exp.Const (Const.Cfun pn), _, loc, _) ->
let description =
Printf.sprintf "call to %s" (Procname.to_string pn) in
ST.report_error
ST.report_error tenv
proc_name
proc_desc
"CHECKERS_PRINT_C_CALL"
@ -570,13 +575,13 @@ let callback_print_c_method_calls { Callbacks.proc_desc; proc_name } =
Cfg.Procdesc.iter_instrs do_instr proc_desc
(** Print access to globals. *)
let callback_print_access_to_globals { Callbacks.proc_desc; proc_name } =
let callback_print_access_to_globals { Callbacks.tenv; proc_desc; proc_name } =
let do_pvar is_read pvar loc =
let description =
Printf.sprintf "%s of global %s"
(if is_read then "read" else "write")
(Pvar.to_string pvar) in
ST.report_error
ST.report_error tenv
proc_name
proc_desc
"CHECKERS_ACCESS_GLOBAL"

@ -22,6 +22,7 @@ module ST : sig
(** Report an error. *)
val report_error:
Tenv.t ->
Procname.t ->
Cfg.Procdesc.t ->
string ->
@ -35,7 +36,7 @@ module ST : sig
unit
(** Store the summary to a .specs file. *)
val store_summary : Procname.t -> unit
val store_summary : Tenv.t -> Procname.t -> unit
end (* ST *)

@ -13,7 +13,7 @@ module L = Logging
module F = Format
(** Check an implicit cast when returning an immutable collection from a method whose type is mutable. *)
let check_immutable_cast curr_pname curr_pdesc typ_expected typ_found_opt loc : unit =
let check_immutable_cast tenv curr_pname curr_pdesc typ_expected typ_found_opt loc : unit =
match typ_found_opt with
| Some typ_found ->
begin
@ -39,7 +39,7 @@ let check_immutable_cast curr_pname curr_pdesc typ_expected typ_found_opt loc :
(Procname.to_simplified_string curr_pname)
Typename.pp name_given
Typename.pp name_expected in
Checkers.ST.report_error
Checkers.ST.report_error tenv
curr_pname
curr_pdesc
"CHECKERS_IMMUTABLE_CAST"
@ -50,5 +50,5 @@ let check_immutable_cast curr_pname curr_pdesc typ_expected typ_found_opt loc :
end
| None -> ()
let callback_check_immutable_cast =
Eradicate.callback_check_return_type check_immutable_cast
let callback_check_immutable_cast ({Callbacks.tenv} as args) =
Eradicate.callback_check_return_type (check_immutable_cast tenv) args

@ -24,7 +24,7 @@ type taint_spec = {
language : Config.language
}
let type_is_object = function
let type_is_object _tenv = function
| Typ.Tptr (Tstruct { name }, _) -> string_equal (Typename.name name) JConfig.object_cl
| _ -> false
@ -77,7 +77,7 @@ let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals
| (_, t):: _ -> Some t
| _ -> None
let type_get_direct_supertypes = function
let type_get_direct_supertypes _tenv = function
| Typ.Tptr (Tstruct { superclasses }, _)
| Typ.Tstruct { superclasses } ->
superclasses
@ -88,7 +88,7 @@ let type_get_class_name = function
| Typ.Tptr (typ, _) -> Typ.name typ
| _ -> None
let type_get_annotation
let type_get_annotation _tenv
(t: Typ.t): Typ.item_annotation option =
match t with
| Typ.Tptr (Typ.Tstruct { Typ.struct_annotations }, _)
@ -96,8 +96,8 @@ let type_get_annotation
Some struct_annotations
| _ -> None
let type_has_direct_supertype (typ : Typ.t) (class_name : Typename.t) =
IList.exists (fun cn -> Typename.equal cn class_name) (type_get_direct_supertypes typ)
let type_has_direct_supertype tenv (typ : Typ.t) (class_name : Typename.t) =
IList.exists (fun cn -> Typename.equal cn class_name) (type_get_direct_supertypes tenv typ)
let type_has_supertype
(tenv: Tenv.t)
@ -124,9 +124,9 @@ let type_has_supertype
end in
has_supertype typ Typ.Set.empty
let type_is_nested_in_direct_supertype t n =
let type_is_nested_in_direct_supertype tenv t n =
let is_nested_in cn1 cn2 = string_is_prefix (Typename.name cn1 ^ "$") (Typename.name cn2) in
IList.exists (is_nested_in n) (type_get_direct_supertypes t)
IList.exists (is_nested_in n) (type_get_direct_supertypes tenv t)
let rec get_type_name = function
| Typ.Tvar name
@ -135,7 +135,7 @@ let rec get_type_name = function
| Typ.Tptr (t, _) -> get_type_name t
| _ -> "_"
let get_field_type_name
let get_field_type_name _tenv
(typ: Typ.t)
(fieldname: Ident.fieldname): string option =
match typ with
@ -157,7 +157,7 @@ let java_get_const_type_name
| Const.Cfloat _ -> "java.lang.Double"
| _ -> "_"
let get_vararg_type_names
let get_vararg_type_names tenv
(call_node: Cfg.Node.t)
(ivar: Pvar.t): string list =
(* Is this the node creating ivar? *)
@ -176,7 +176,7 @@ let get_vararg_type_names
let rec nvar_type_name nvar instrs =
match instrs with
| Sil.Load (nv, Exp.Lfield (_, id, t), _, _):: _
when Ident.equal nv nvar -> get_field_type_name t id
when Ident.equal nv nvar -> get_field_type_name tenv t id
| Sil.Load (nv, _, t, _):: _
when Ident.equal nv nvar ->
Some (get_type_name t)
@ -249,7 +249,7 @@ let get_java_method_call_formal_signature = function
| _ -> None
let type_is_class = function
let type_is_class _tenv = function
| Typ.Tptr (Typ.Tstruct _, _) -> true
| Typ.Tptr (Typ.Tvar _, _) -> true
| Typ.Tptr (Typ.Tarray _, _) -> true
@ -362,7 +362,7 @@ let proc_iter_overridden_methods f tenv proc_name =
| Some curr_struct_typ ->
IList.iter
(do_super_type tenv)
(type_get_direct_supertypes (Typ.Tstruct curr_struct_typ))
(type_get_direct_supertypes tenv (Typ.Tstruct curr_struct_typ))
| None ->
())
| _ ->

@ -36,7 +36,7 @@ val get_this_type : ProcAttributes.t -> Typ.t option
val get_type_name : Typ.t -> string
(** Get the type names of a variable argument *)
val get_vararg_type_names : Cfg.Node.t -> Pvar.t -> string list
val get_vararg_type_names : Tenv.t -> Cfg.Node.t -> Pvar.t -> string list
val has_formal_method_argument_type_names :
Cfg.Procdesc.t -> Procname.java -> string list -> bool
@ -84,22 +84,22 @@ val proc_calls :
Only Java supported at the moment. *)
val proc_iter_overridden_methods : (Procname.t -> unit) -> Tenv.t -> Procname.t -> unit
val type_get_annotation : Typ.t -> Typ.item_annotation option
val type_get_annotation : Tenv.t -> Typ.t -> Typ.item_annotation option
(** Get the class name of the type *)
val type_get_class_name : Typ.t -> Typename.t option
val type_get_direct_supertypes : Typ.t -> Typename.t list
val type_get_direct_supertypes : Tenv.t -> Typ.t -> Typename.t list
val type_has_direct_supertype : Typ.t -> Typename.t -> bool
val type_has_direct_supertype : Tenv.t -> Typ.t -> Typename.t -> bool
(** Is the type a class type *)
val type_is_class : Typ.t -> bool
val type_is_class : Tenv.t -> Typ.t -> bool
val type_is_nested_in_direct_supertype : Typ.t -> Typename.t -> bool
val type_is_nested_in_direct_supertype : Tenv.t -> Typ.t -> Typename.t -> bool
(** Is the type java.lang.Object *)
val type_is_object : Typ.t -> bool
val type_is_object : Tenv.t -> Typ.t -> bool
(** return the set of instance fields that are assigned to a null literal in [procdesc] *)
val get_fields_nullified : Cfg.Procdesc.t -> Ident.FieldSet.t

@ -114,7 +114,7 @@ let rec format_string_type_names
let printf_args_name = "CHECKERS_PRINTF_ARGS"
let check_printf_args_ok
let check_printf_args_ok tenv
(node: Cfg.Node.t)
(instr: Sil.instr)
(proc_name: Procname.t)
@ -134,7 +134,7 @@ let check_printf_args_ok
n_arg
(default_format_type_name ft)
gt in
Checkers.ST.report_error
Checkers.ST.report_error tenv
proc_name
proc_desc
printf_args_name
@ -148,7 +148,7 @@ let check_printf_args_ok
"format string arguments don't mach provided arguments in %s at line %s"
instr_name
instr_line in
Checkers.ST.report_error
Checkers.ST.report_error tenv
proc_name
proc_desc
printf_args_name
@ -185,7 +185,7 @@ let check_printf_args_ok
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)
PatternMatch.get_vararg_type_names tenv node ivar)
| None -> [] in
match fmt with
| Some fmt ->
@ -196,7 +196,7 @@ let check_printf_args_ok
(format_string_type_names fmt 0)
(fixed_nvar_type_names@ vararg_ivar_type_names)
| None ->
Checkers.ST.report_error
Checkers.ST.report_error tenv
proc_name
proc_desc
printf_args_name
@ -211,8 +211,8 @@ let check_printf_args_ok
| None -> ())
| _ -> ()
let callback_printf_args { Callbacks.proc_desc; proc_name } : unit =
Cfg.Procdesc.iter_instrs (fun n i -> check_printf_args_ok n i proc_name proc_desc) proc_desc
let callback_printf_args { Callbacks.tenv; proc_desc; proc_name } : unit =
Cfg.Procdesc.iter_instrs (fun n i -> check_printf_args_ok tenv n i proc_name proc_desc) proc_desc
(*
let printf_signature_to_string

@ -19,6 +19,6 @@ type printf_signature = {
val add_printf_like_function : printf_signature -> unit
val check_printf_args_ok : Cfg.Node.t -> Sil.instr -> Procname.t -> Cfg.Procdesc.t -> unit
val check_printf_args_ok : Tenv.t -> Cfg.Node.t -> Sil.instr -> Procname.t -> Cfg.Procdesc.t -> unit
val callback_printf_args: Callbacks.proc_callback_t

@ -138,7 +138,7 @@ struct
loc_old.Location.line
(DB.source_file_to_string alloc_loc.Location.file)
alloc_loc.Location.line in
Checkers.ST.report_error
Checkers.ST.report_error tenv
curr_pname curr_pdesc checkers_repeated_calls_name loc description
| None -> ()
end

@ -25,7 +25,7 @@ module type S = sig
val write_summary : Procname.t -> summary -> unit
(* read and return the summary for [callee_pname] called from [caller_pdesc]. does the analysis to
create the summary if needed *)
val read_summary : Cfg.Procdesc.t -> Procname.t -> summary option
val read_summary : Tenv.t -> Cfg.Procdesc.t -> Procname.t -> summary option
end
module Make (H : Helper) = struct
@ -40,8 +40,8 @@ module Make (H : Helper) = struct
Printf.sprintf "Summary for %s should exist, but does not!@." (Procname.to_string pname)
|> failwith
let read_summary caller_pdesc callee_pname =
Ondemand.analyze_proc_name ~propagate_exceptions:false caller_pdesc callee_pname;
let read_summary tenv caller_pdesc callee_pname =
Ondemand.analyze_proc_name tenv ~propagate_exceptions:false caller_pdesc callee_pname;
match Specs.get_summary callee_pname with
| None -> None
| Some summary -> Some (H.read_from_payload summary.Specs.payload)

@ -61,7 +61,7 @@ let get_class_param function_method_decl_info =
else []
let should_add_return_param return_type ~is_objc_method =
let should_add_return_param _tenv return_type ~is_objc_method =
match return_type with
| Typ.Tstruct _ -> not is_objc_method
| _ -> false
@ -75,7 +75,7 @@ let get_return_param tenv function_method_decl_info =
let is_objc_method = is_objc_method function_method_decl_info in
let return_type_ptr = get_original_return_type function_method_decl_info in
let return_typ = CTypes_decl.type_ptr_to_sil_type tenv return_type_ptr in
if should_add_return_param return_typ ~is_objc_method then
if should_add_return_param tenv return_typ ~is_objc_method then
[(Mangled.from_string CFrontend_config.return_param,
Ast_expressions.create_pointer_qual_type ~is_const:false return_type_ptr)]
else
@ -125,7 +125,7 @@ let get_return_type tenv function_method_decl_info =
let return_type_ptr = get_original_return_type function_method_decl_info in
let return_typ = CTypes_decl.type_ptr_to_sil_type tenv return_type_ptr in
let is_objc_method = is_objc_method function_method_decl_info in
if should_add_return_param return_typ ~is_objc_method then
if should_add_return_param tenv return_typ ~is_objc_method then
Ast_expressions.create_void_type, Some (Typ.Tptr (return_typ, Typ.Pk_pointer))
else return_type_ptr, None

@ -21,7 +21,7 @@ type method_call_type =
| MCNoVirtual
| MCStatic
val should_add_return_param : Typ.t -> is_objc_method:bool -> bool
val should_add_return_param : Tenv.t -> Typ.t -> is_objc_method:bool -> bool
val create_local_procdesc : Cfg.cfg -> Tenv.t -> CMethod_signature.method_signature ->
Clang_ast_t.stmt list -> (Pvar.t * Typ.t) list -> bool -> bool

@ -279,11 +279,12 @@ struct
let create_call_instr trans_state return_type function_sil params_sil sil_loc
call_flags ~is_objc_method =
let {context = {tenv}} = trans_state in
let ret_id = if (Typ.equal return_type Typ.Tvoid) then []
else [Ident.create_fresh Ident.knormal] in
let ret_id', params, initd_exps, ret_exps =
(* Assumption: should_add_return_param will return true only for struct types *)
if CMethod_trans.should_add_return_param return_type ~is_objc_method then
if CMethod_trans.should_add_return_param tenv return_type ~is_objc_method then
let param_type = Typ.Tptr (return_type, Typ.Pk_pointer) in
let var_exp = match trans_state.var_exp_typ with
| Some (exp, _) -> exp
@ -626,6 +627,7 @@ struct
and var_deref_trans trans_state stmt_info (decl_ref : Clang_ast_t.decl_ref) =
let context = trans_state.context in
let _tenv = context.tenv in
let _, _, type_ptr = Ast_utils.get_info_from_decl_ref decl_ref in
let ast_typ = CTypes_decl.type_ptr_to_sil_type context.tenv type_ptr in
let typ = match ast_typ with

@ -102,7 +102,7 @@ struct
(fun f -> f curr_pname curr_pdesc ret_type typ_found_opt loc)
checks.TypeCheck.check_ret_type;
if checks.TypeCheck.eradicate then
EradicateChecks.check_return_annotation
EradicateChecks.check_return_annotation tenv
find_canonical_duplicate curr_pname exit_node ret_range
ret_ia ret_implicitly_nullable loc in
@ -119,7 +119,7 @@ struct
let module DFTypeCheck = MakeDF(struct
type t = Extension.extension TypeState.t
let equal = TypeState.equal
let join = TypeState.join Extension.ext
let join = TypeState.join tenv Extension.ext
let do_node tenv node typestate =
State.set_node node;
let typestates_succ, typestates_exn =
@ -305,7 +305,7 @@ struct
check_field_initialization &&
checks.TypeCheck.eradicate
then begin
EradicateChecks.check_constructor_initialization
EradicateChecks.check_constructor_initialization tenv
find_canonical_duplicate
curr_pname
curr_pdesc
@ -332,7 +332,7 @@ struct
tenv curr_pname curr_pdesc
annotated_signature;
TypeErr.report_forall_checks_and_reset Checkers.ST.report_error curr_pname;
TypeErr.report_forall_checks_and_reset tenv (Checkers.ST.report_error tenv) curr_pname;
update_summary curr_pname curr_pdesc final_typestate_opt
(** Entry point for the eradicate-based checker infrastructure. *)

@ -39,7 +39,7 @@ let return_nonnull_silent = true
let check_library_calls = false
let get_field_annotation fn typ =
let get_field_annotation _tenv fn typ =
match Typ.get_field_type_and_annotation fn typ with
| None -> None
| Some (t, ia) ->
@ -52,11 +52,11 @@ let get_field_annotation fn typ =
else ia in
Some (t, ia')
let report_error =
TypeErr.report_error Checkers.ST.report_error
let report_error tenv =
TypeErr.report_error tenv (Checkers.ST.report_error tenv)
let explain_expr node e =
match Errdesc.exp_rv_dexp node e with
let explain_expr tenv node e =
match Errdesc.exp_rv_dexp tenv node e with
| Some de -> Some (DecompiledExp.to_string de)
| None -> None
@ -79,19 +79,19 @@ let is_virtual = function
(** Check an access (read or write) to a field. *)
let check_field_access
let check_field_access tenv
find_canonical_duplicate curr_pname node instr_ref exp fname ta loc : unit =
if TypeAnnotation.get_value Annotations.Nullable ta = true then
let origin_descr = TypeAnnotation.descr_origin ta in
report_error
let origin_descr = TypeAnnotation.descr_origin tenv ta in
report_error tenv
find_canonical_duplicate
node
(TypeErr.Null_field_access (explain_expr node exp, fname, origin_descr, false))
(TypeErr.Null_field_access (explain_expr tenv node exp, fname, origin_descr, false))
(Some instr_ref)
loc curr_pname
(** Check an access to an array *)
let check_array_access
let check_array_access tenv
find_canonical_duplicate
curr_pname
node
@ -102,11 +102,11 @@ let check_array_access
loc
indexed =
if TypeAnnotation.get_value Annotations.Nullable ta = true then
let origin_descr = TypeAnnotation.descr_origin ta in
report_error
let origin_descr = TypeAnnotation.descr_origin tenv ta in
report_error tenv
find_canonical_duplicate
node
(TypeErr.Null_field_access (explain_expr node array_exp, fname, origin_descr, indexed))
(TypeErr.Null_field_access (explain_expr tenv node array_exp, fname, origin_descr, indexed))
(Some instr_ref)
loc
curr_pname
@ -121,7 +121,7 @@ type from_call =
| From_containsKey (** x.containsKey *)
(** Check the normalized "is zero" or "is not zero" condition of a prune instruction. *)
let check_condition case_zero find_canonical_duplicate curr_pname
let check_condition tenv case_zero find_canonical_duplicate curr_pname
node e typ ta true_branch from_call idenv linereader loc instr_ref : unit =
let is_fun_nonnull ta = match TypeAnnotation.get_origin ta with
| TypeOrigin.Proc proc_origin ->
@ -165,28 +165,28 @@ let check_condition case_zero find_canonical_duplicate curr_pname
(activate_condition_redundant || nonnull) &&
true_branch &&
(not is_temp || nonnull) &&
PatternMatch.type_is_class typ &&
PatternMatch.type_is_class tenv typ &&
not (from_try_with_resources ()) &&
from_call = From_condition &&
not (TypeAnnotation.origin_is_fun_library ta) in
let is_always_true = not case_zero in
let nonnull = is_fun_nonnull ta in
if should_report then
report_error
report_error tenv
find_canonical_duplicate
node
(TypeErr.Condition_redundant (is_always_true, explain_expr node e, nonnull))
(TypeErr.Condition_redundant (is_always_true, explain_expr tenv node e, nonnull))
(Some instr_ref)
loc curr_pname
(** Check an "is zero" condition. *)
let check_zero find_canonical_duplicate = check_condition true find_canonical_duplicate
let check_zero tenv find_canonical_duplicate = check_condition tenv true find_canonical_duplicate
(** Check an "is not zero" condition. *)
let check_nonzero find_canonical_duplicate = check_condition false find_canonical_duplicate
let check_nonzero tenv find_canonical_duplicate = check_condition tenv false find_canonical_duplicate
(** Check an assignment to a field. *)
let check_field_assignment
let check_field_assignment tenv
find_canonical_duplicate curr_pname node instr_ref typestate exp_lhs
exp_rhs typ loc fname t_ia_opt typecheck_expr : unit =
let (t_lhs, ta_lhs, _) =
@ -203,7 +203,7 @@ let check_field_assignment
false in
TypeAnnotation.get_value Annotations.Nullable ta_lhs = false &&
TypeAnnotation.get_value Annotations.Nullable ta_rhs = true &&
PatternMatch.type_is_class t_lhs &&
PatternMatch.type_is_class tenv t_lhs &&
not (Ident.java_fieldname_is_outer_instance fname) &&
not (field_is_field_injector_readwrite ()) in
let should_report_absent =
@ -223,8 +223,8 @@ let check_field_assignment
begin
let ann = if should_report_nullable then Annotations.Nullable else Annotations.Present in
if Models.Inference.enabled then Models.Inference.field_add_nullable_annotation fname;
let origin_descr = TypeAnnotation.descr_origin ta_rhs in
report_error
let origin_descr = TypeAnnotation.descr_origin tenv ta_rhs in
report_error tenv
find_canonical_duplicate
node
(TypeErr.Field_annotation_inconsistent (ann, fname, origin_descr))
@ -233,8 +233,8 @@ let check_field_assignment
end;
if should_report_mutable then
begin
let origin_descr = TypeAnnotation.descr_origin ta_rhs in
report_error
let origin_descr = TypeAnnotation.descr_origin tenv ta_rhs in
report_error tenv
find_canonical_duplicate
node
(TypeErr.Field_not_mutable (fname, origin_descr))
@ -244,7 +244,7 @@ let check_field_assignment
(** Check that nonnullable fields are initialized in constructors. *)
let check_constructor_initialization
let check_constructor_initialization tenv
find_canonical_duplicate
curr_pname
curr_pdesc
@ -258,7 +258,7 @@ let check_constructor_initialization
match PatternMatch.get_this_type (Cfg.Procdesc.get_attributes curr_pdesc) with
| Some (Tptr (Tstruct { instance_fields; name } as ts, _)) ->
let do_field (fn, ft, _) =
let annotated_with f = match get_field_annotation fn ts with
let annotated_with f = match get_field_annotation tenv fn ts with
| None -> false
| Some (_, ia) -> f ia in
let nullable_annotated = annotated_with Annotations.ia_is_nullable in
@ -295,7 +295,7 @@ let check_constructor_initialization
let fld_cname = Ident.java_fieldname_get_class fn in
string_equal (Typename.name name) fld_cname in
not injector_readonly_annotated &&
PatternMatch.type_is_class ft &&
PatternMatch.type_is_class tenv ft &&
in_current_class &&
not (Ident.java_fieldname_is_outer_instance fn) in
@ -306,7 +306,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
report_error
report_error tenv
find_canonical_duplicate
start_node
(TypeErr.Field_not_initialized (fn, curr_pname))
@ -318,7 +318,7 @@ let check_constructor_initialization
if activate_field_over_annotated &&
nullable_annotated &&
not (may_be_nullable_in_final_typestate ()) then
report_error
report_error tenv
find_canonical_duplicate
start_node
(TypeErr.Field_over_annotated (fn, curr_pname))
@ -349,7 +349,7 @@ let spec_make_return_nullable curr_pname =
| None -> ()
(** Check the annotations when returning from a method. *)
let check_return_annotation
let check_return_annotation tenv
find_canonical_duplicate curr_pname exit_node ret_range
ret_ia ret_implicitly_nullable loc : unit =
let ret_annotated_nullable = Annotations.ia_is_nullable ret_ia in
@ -359,7 +359,7 @@ let check_return_annotation
| Some (_, final_ta, _) ->
let final_nullable = TypeAnnotation.get_value Annotations.Nullable final_ta in
let final_present = TypeAnnotation.get_value Annotations.Present final_ta in
let origin_descr = TypeAnnotation.descr_origin final_ta in
let origin_descr = TypeAnnotation.descr_origin tenv final_ta in
let return_not_nullable =
final_nullable &&
not ret_annotated_nullable &&
@ -388,7 +388,7 @@ let check_return_annotation
if return_not_nullable then Annotations.Nullable else Annotations.Present in
report_error
report_error tenv
find_canonical_duplicate
exit_node
(TypeErr.Return_annotation_inconsistent (ann, curr_pname, origin_descr))
@ -398,7 +398,7 @@ let check_return_annotation
if return_over_annotated then
begin
report_error
report_error tenv
find_canonical_duplicate
exit_node
(TypeErr.Return_over_annotated curr_pname)
@ -409,7 +409,7 @@ let check_return_annotation
()
(** Check the receiver of a virtual call. *)
let check_call_receiver
let check_call_receiver tenv
find_canonical_duplicate
curr_pname
node
@ -423,7 +423,7 @@ let check_call_receiver
match call_params with
| ((original_this_e, this_e), typ) :: _ ->
let (_, this_ta, _) =
typecheck_expr node instr_ref curr_pname typestate this_e
typecheck_expr tenv node instr_ref curr_pname typestate this_e
(typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.ONone, []) loc in
let null_method_call = TypeAnnotation.get_value Annotations.Nullable this_ta in
let optional_get_on_absent =
@ -433,9 +433,9 @@ let check_call_receiver
if null_method_call || optional_get_on_absent then
begin
let ann = if null_method_call then Annotations.Nullable else Annotations.Present in
let descr = explain_expr node original_this_e in
let origin_descr = TypeAnnotation.descr_origin this_ta in
report_error
let descr = explain_expr tenv node original_this_e in
let origin_descr = TypeAnnotation.descr_origin tenv this_ta in
report_error tenv
find_canonical_duplicate
node
(TypeErr.Call_receiver_annotation_inconsistent
@ -446,7 +446,7 @@ let check_call_receiver
| [] -> ()
(** Check the parameters of a call. *)
let check_call_parameters
let check_call_parameters tenv
find_canonical_duplicate curr_pname node typestate callee_attributes
sig_params call_params loc instr_ref typecheck_expr : unit =
let callee_pname = callee_attributes.ProcAttributes.proc_name in
@ -462,13 +462,13 @@ let check_call_parameters
(t2, TypeAnnotation.const Annotations.Nullable false TypeOrigin.ONone, []) loc in
let parameter_not_nullable =
not param_is_this &&
PatternMatch.type_is_class t1 &&
PatternMatch.type_is_class tenv t1 &&
not formal_is_nullable &&
TypeAnnotation.get_value Annotations.Nullable ta2 in
let parameter_absent =
activate_optional_present &&
not param_is_this &&
PatternMatch.type_is_class t1 &&
PatternMatch.type_is_class tenv t1 &&
formal_is_present &&
not (TypeAnnotation.get_value Annotations.Present ta2) in
if parameter_not_nullable || parameter_absent then
@ -478,14 +478,14 @@ let check_call_parameters
then Annotations.Nullable
else Annotations.Present in
let description =
match explain_expr node orig_e2 with
match explain_expr tenv node orig_e2 with
| Some descr -> descr
| None -> "formal parameter " ^ (Mangled.to_string s1) in
let origin_descr = TypeAnnotation.descr_origin ta2 in
let origin_descr = TypeAnnotation.descr_origin tenv ta2 in
let param_num = IList.length sparams' + (if has_this then 0 else 1) in
let callee_loc = callee_attributes.ProcAttributes.loc in
report_error
report_error tenv
find_canonical_duplicate
node
(TypeErr.Parameter_annotation_inconsistent (
@ -527,7 +527,7 @@ let check_overridden_annotations
let overriden_ia, _ = overriden_signature.Annotations.ret in
Annotations.ia_is_nullable overriden_ia in
if ret_is_nullable && not ret_overridden_nullable then
report_error
report_error tenv
find_canonical_duplicate
start_node
(TypeErr.Inconsistent_subclass_return_annotation (proc_name, overriden_proc_name))
@ -541,7 +541,7 @@ let check_overridden_annotations
let () =
if not (Annotations.ia_is_nullable current_ia)
&& Annotations.ia_is_nullable overriden_ia then
report_error
report_error tenv
find_canonical_duplicate
start_node
(TypeErr.Inconsistent_subclass_parameter_annotation

@ -88,8 +88,8 @@ let origin_is_fun_library ta = match get_origin ta with
proc_origin.TypeOrigin.is_library
| _ -> false
let descr_origin ta : TypeErr.origin_descr =
let descr_opt = TypeOrigin.get_description ta.origin in
let descr_origin tenv ta : TypeErr.origin_descr =
let descr_opt = TypeOrigin.get_description tenv ta.origin in
match descr_opt with
| None -> ("", None, None)
| Some (str, loc_opt, sig_opt) -> ("(Origin: " ^ str ^ ")", loc_opt, sig_opt)

@ -16,7 +16,7 @@ type t
val const : Annotations.annotation -> bool -> TypeOrigin.t -> t
(** Human-readable description of the origin of a nullable value. *)
val descr_origin : t -> TypeErr.origin_descr
val descr_origin : Tenv.t -> t -> TypeErr.origin_descr
val equal : t -> t -> bool
val from_item_annotation : Typ.item_annotation -> TypeOrigin.t -> t

@ -85,7 +85,7 @@ module ComplexExpressions = struct
(* This is used to turn complex expressions into pvar's.*)
(* Arbitrary function parameters and field access are allowed *)
(* when the relevant options are active. *)
let exp_to_string_map_dexp map_dexp node' exp =
let exp_to_string_map_dexp tenv map_dexp node' exp =
let rec dexp_to_string dexp =
let case_not_handled () =
@ -130,7 +130,7 @@ module ComplexExpressions = struct
| DExp.Dunknown ->
case_not_handled () in
match map_dexp (Errdesc.exp_rv_dexp node' exp) with
match map_dexp (Errdesc.exp_rv_dexp tenv node' exp) with
| Some de ->
begin
try Some (dexp_to_string de)
@ -138,9 +138,9 @@ module ComplexExpressions = struct
end
| None -> None
let exp_to_string node' exp =
let exp_to_string tenv node' exp =
let map_dexp de_opt = de_opt in
exp_to_string_map_dexp map_dexp node' exp
exp_to_string_map_dexp tenv map_dexp node' exp
end (* ComplexExpressions *)
@ -160,7 +160,7 @@ type checks =
(** Typecheck an expression. *)
let rec typecheck_expr
find_canonical_duplicate visited checks node instr_ref curr_pname
find_canonical_duplicate visited checks tenv node instr_ref curr_pname
typestate e tr_default loc : TypeState.range = match e with
| Exp.Lvar pvar ->
(match TypeState.lookup_pvar pvar typestate with
@ -172,14 +172,14 @@ let rec typecheck_expr
| None -> tr_default)
| Exp.Const (Const.Cint i) when IntLit.iszero i ->
let (typ, _, locs) = tr_default in
if PatternMatch.type_is_class typ
if PatternMatch.type_is_class tenv typ
then (typ, TypeAnnotation.const Annotations.Nullable true (TypeOrigin.Const loc), locs)
else
let t, ta, ll = tr_default in
(t, TypeAnnotation.with_origin ta (TypeOrigin.Const loc), ll)
| Exp.Exn e1 ->
typecheck_expr
find_canonical_duplicate visited checks
find_canonical_duplicate visited checks tenv
node instr_ref curr_pname
typestate e1 tr_default loc
| Exp.Const _ ->
@ -189,9 +189,9 @@ let rec typecheck_expr
let _, _, locs = tr_default in
let (_, ta, locs') =
typecheck_expr
find_canonical_duplicate visited checks node instr_ref curr_pname typestate exp
find_canonical_duplicate visited checks tenv node instr_ref curr_pname typestate exp
(typ, TypeAnnotation.const Annotations.Nullable false TypeOrigin.ONone, locs) loc in
let tr_new = match EradicateChecks.get_field_annotation fn typ with
let tr_new = match EradicateChecks.get_field_annotation tenv fn typ with
| Some (t, ia) ->
(
t,
@ -200,7 +200,7 @@ let rec typecheck_expr
)
| None -> tr_default in
if checks.eradicate then
EradicateChecks.check_field_access
EradicateChecks.check_field_access tenv
find_canonical_duplicate curr_pname node instr_ref exp fn ta loc;
tr_new
| Exp.Lindex (array_exp, index_exp) ->
@ -208,7 +208,7 @@ let rec typecheck_expr
typecheck_expr
find_canonical_duplicate
visited
checks
checks tenv
node
instr_ref
curr_pname
@ -217,14 +217,14 @@ let rec typecheck_expr
tr_default
loc in
let index =
match EradicateChecks.explain_expr node index_exp with
match EradicateChecks.explain_expr tenv node index_exp with
| Some s -> Format.sprintf "%s" s
| None -> "?" in
let fname = Ident.create_fieldname
(Mangled.from_string index)
0 in
if checks.eradicate then
EradicateChecks.check_array_access
EradicateChecks.check_array_access tenv
find_canonical_duplicate
curr_pname
node
@ -289,7 +289,7 @@ let typecheck_instr
match TypeState.lookup_pvar pvar typestate with
| Some _ when not is_assignment -> typestate
| _ ->
(match EradicateChecks.get_field_annotation fn typ with
(match EradicateChecks.get_field_annotation tenv fn typ with
| Some (t, ia) ->
let range =
(
@ -306,7 +306,7 @@ let typecheck_instr
| Some (Exp.Const (Const.Cfun pn), _, _, _)
when not (ComplexExpressions.procname_used_in_condition pn) ->
begin
match ComplexExpressions.exp_to_string node' exp with
match ComplexExpressions.exp_to_string tenv node' exp with
| None -> default
| Some exp_str ->
let pvar = Pvar.mk (Mangled.from_string exp_str) curr_pname in
@ -372,7 +372,7 @@ let typecheck_instr
| Exp.Lvar _ | Exp.Lfield _ when ComplexExpressions.all_nested_fields () ->
(* treat var.field1. ... .fieldn as a constant *)
begin
match ComplexExpressions.exp_to_string node' exp with
match ComplexExpressions.exp_to_string tenv node' exp with
| Some exp_str ->
let pvar = Pvar.mk (Mangled.from_string exp_str) curr_pname in
let typestate' = update_typestate_fld pvar fn typ in
@ -460,7 +460,7 @@ let typecheck_instr
(* typecheck_expr with fewer parameters, using a common template for typestate range *)
let typecheck_expr_simple typestate1 exp1 typ1 origin1 loc1 =
typecheck_expr
find_canonical_duplicate calls_this checks node instr_ref
find_canonical_duplicate calls_this checks tenv node instr_ref
curr_pname typestate1 exp1
(typ1, TypeAnnotation.const Annotations.Nullable false origin1, [loc1])
loc1 in
@ -490,12 +490,12 @@ let typecheck_instr
let e1', typestate1 = convert_complex_exp_to_pvar node true e1 typestate loc in
let check_field_assign () = match e1 with
| Exp.Lfield (_, fn, f_typ) ->
let t_ia_opt = EradicateChecks.get_field_annotation fn f_typ in
let t_ia_opt = EradicateChecks.get_field_annotation tenv fn f_typ in
if checks.eradicate then
EradicateChecks.check_field_assignment
EradicateChecks.check_field_assignment tenv
find_canonical_duplicate curr_pname node
instr_ref typestate1 e1' e2 typ loc fn t_ia_opt
(typecheck_expr find_canonical_duplicate calls_this checks)
(typecheck_expr find_canonical_duplicate calls_this checks tenv)
| _ -> () in
let typestate2 =
match e1' with
@ -531,7 +531,7 @@ let typecheck_instr
let (_, ta, _) = typecheck_expr
find_canonical_duplicate
calls_this
checks
checks tenv
node
instr_ref
curr_pname
@ -540,7 +540,7 @@ let typecheck_instr
(t, TypeAnnotation.const Annotations.Nullable false TypeOrigin.ONone, [loc])
loc in
if checks.eradicate then
EradicateChecks.check_array_access
EradicateChecks.check_array_access tenv
find_canonical_duplicate
curr_pname
node
@ -567,7 +567,7 @@ let typecheck_instr
loc,
cflags)
->
Ondemand.analyze_proc_name ~propagate_exceptions:true curr_pdesc callee_pname;
Ondemand.analyze_proc_name tenv ~propagate_exceptions:true curr_pdesc callee_pname;
let callee_attributes =
match Specs.proc_resolve_attributes (* AttributesTable.load_attributes *) callee_pname with
| Some proc_attributes ->
@ -652,11 +652,11 @@ let typecheck_instr
if checks.eradicate && should_report then
begin
let cond = Exp.BinOp (Binop.Ne, Exp.Lvar pvar, Exp.null) in
EradicateChecks.report_error
EradicateChecks.report_error tenv
find_canonical_duplicate
node
(TypeErr.Condition_redundant
(true, EradicateChecks.explain_expr node cond, false))
(true, EradicateChecks.explain_expr tenv node cond, false))
(Some instr_ref)
loc curr_pname
end;
@ -778,7 +778,7 @@ let typecheck_instr
Some (DExp.Dretcall (dexp_get, args, loc, call_flags))
| _ -> None in
begin
match ComplexExpressions.exp_to_string_map_dexp
match ComplexExpressions.exp_to_string_map_dexp tenv
convert_dexp_key_to_dexp_get node exp_key with
| Some map_get_str ->
let pvar_map_get = Pvar.mk (Mangled.from_string map_get_str) curr_pname in
@ -803,7 +803,7 @@ let typecheck_instr
L.stdout " %s unique id: %s@." classification unique_id
end;
if cflags.CallFlags.cf_virtual && checks.eradicate then
EradicateChecks.check_call_receiver
EradicateChecks.check_call_receiver tenv
find_canonical_duplicate
curr_pname
node
@ -814,7 +814,7 @@ let typecheck_instr
loc
(typecheck_expr find_canonical_duplicate calls_this checks);
if checks.eradicate then
EradicateChecks.check_call_parameters
EradicateChecks.check_call_parameters tenv
find_canonical_duplicate
curr_pname
node
@ -824,7 +824,7 @@ let typecheck_instr
call_params
loc
instr_ref
(typecheck_expr find_canonical_duplicate calls_this checks);
(typecheck_expr find_canonical_duplicate calls_this checks tenv);
let typestate2 =
if checks.check_extension then
let etl' = IList.map (fun ((_, e), t) -> (e, t)) call_params in
@ -915,7 +915,7 @@ let typecheck_instr
Some (DExp.Dretcall (fun_dexp, args, loc, call_flags))
| _ -> None in
begin
match ComplexExpressions.exp_to_string_map_dexp map_dexp node' e with
match ComplexExpressions.exp_to_string_map_dexp tenv map_dexp node' e with
| Some e_str ->
let pvar =
Pvar.mk (Mangled.from_string e_str) curr_pname in
@ -957,7 +957,7 @@ let typecheck_instr
typecheck_expr_simple typestate2 e' Typ.Tvoid TypeOrigin.ONone loc in
if checks.eradicate then
EradicateChecks.check_zero
EradicateChecks.check_zero tenv
find_canonical_duplicate curr_pname
node' e' typ
ta true_branch EradicateChecks.From_condition
@ -1004,7 +1004,7 @@ let typecheck_instr
typecheck_expr_simple typestate2 e' Typ.Tvoid TypeOrigin.ONone loc in
if checks.eradicate then
EradicateChecks.check_nonzero find_canonical_duplicate curr_pname
EradicateChecks.check_nonzero tenv find_canonical_duplicate curr_pname
node e' typ ta true_branch from_call idenv linereader loc instr_ref;
begin
match from_call with

@ -254,24 +254,24 @@ module Strict = struct
let (ia, _) = signature.Annotations.ret in
Annotations.ia_get_strict ia
let this_type_get_strict signature =
let this_type_get_strict tenv signature =
match signature.Annotations.params with
| (p, _, this_type):: _ when Mangled.to_string p = "this" ->
begin
match PatternMatch.type_get_annotation this_type with
match PatternMatch.type_get_annotation tenv this_type with
| Some ia -> Annotations.ia_get_strict ia
| None -> None
end
| _ -> None
let signature_get_strict signature =
let signature_get_strict tenv signature =
match method_get_strict signature with
| None -> this_type_get_strict signature
| None -> this_type_get_strict tenv signature
| Some x -> Some x
let origin_descr_get_strict origin_descr = match origin_descr with
let origin_descr_get_strict tenv origin_descr = match origin_descr with
| _, _, Some signature ->
signature_get_strict signature
signature_get_strict tenv signature
| _, _, None ->
None
@ -280,14 +280,14 @@ module Strict = struct
(* Return (Some parameters) if there is a method call on a @Nullable object,*)
(* where the origin of @Nullable in the analysis is the return value of a Strict method*)
(* with parameters. A method is Strict if it or its class are annotated @Strict. *)
let err_instance_get_strict err_instance : Typ.annotation option =
let err_instance_get_strict tenv err_instance : Typ.annotation option =
match err_instance with
| Call_receiver_annotation_inconsistent (Annotations.Nullable, _, _, origin_descr)
| Null_field_access (_, _, origin_descr, _) ->
origin_descr_get_strict origin_descr
origin_descr_get_strict tenv origin_descr
| Parameter_annotation_inconsistent (Annotations.Nullable, _, _, _, _, origin_descr)
when report_on_method_arguments ->
origin_descr_get_strict origin_descr
origin_descr_get_strict tenv origin_descr
| _ -> None
end (* Strict *)
@ -305,7 +305,7 @@ type st_report_error =
unit
(** Report an error right now. *)
let report_error_now
let report_error_now tenv
(st_report_error : st_report_error) node err_instance loc pname : unit =
let demo_mode = true in
let do_print_base ew_string kind_s s =
@ -526,7 +526,7 @@ let report_error_now
None in
let ew_string = if is_err then "Error" else "Warning" in
(if demo_mode then do_print_demo else do_print) ew_string kind_s description;
let always_report = Strict.err_instance_get_strict err_instance <> None in
let always_report = Strict.err_instance_get_strict tenv err_instance <> None in
st_report_error
pname
(Cfg.Node.get_proc_desc node)
@ -542,22 +542,22 @@ 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. *)
let report_error (st_report_error : st_report_error) find_canonical_duplicate node
let report_error tenv (st_report_error : st_report_error) find_canonical_duplicate node
err_instance instr_ref_opt loc pname_java =
let should_report_now =
add_err find_canonical_duplicate err_instance instr_ref_opt loc in
if should_report_now then
report_error_now st_report_error node err_instance loc pname_java
report_error_now tenv st_report_error node err_instance loc pname_java
(** Report the forall checks at the end of the analysis and reset the error table *)
let report_forall_checks_and_reset st_report_error proc_name =
let report_forall_checks_and_reset tenv st_report_error proc_name =
let iter (err_instance, instr_ref_opt) err_state =
match instr_ref_opt, get_forall err_instance with
| Some instr_ref, is_forall ->
let node = InstrRef.get_node instr_ref in
State.set_node node;
if is_forall && err_state.always
then report_error_now st_report_error node err_instance err_state.loc proc_name
then report_error_now tenv st_report_error node err_instance err_state.loc proc_name
| None, _ -> () in
H.iter iter err_tbl;
reset ()

@ -29,7 +29,7 @@ module InstrRef : InstrRefT
module Strict :
sig
val signature_get_strict : Annotations.annotated_signature -> Typ.annotation option
val signature_get_strict : Tenv.t -> Annotations.annotated_signature -> Typ.annotation option
end (* Strict *)
@ -79,11 +79,11 @@ type st_report_error =
unit
val report_error :
st_report_error ->
Tenv.t -> st_report_error ->
(Cfg.Node.t -> Cfg.Node.t) -> Cfg.Node.t ->
err_instance -> InstrRef.t option -> Location.t ->
Procname.t -> unit
val report_forall_checks_and_reset : st_report_error -> Procname.t -> unit
val report_forall_checks_and_reset : Tenv.t -> st_report_error -> Procname.t -> unit
val reset : unit -> unit

@ -77,7 +77,7 @@ let to_string = function
| ONone -> "ONone"
| Undef -> "Undef"
let get_description origin =
let get_description tenv origin =
let atline loc =
" at line " ^ (string_of_int loc.Location.line) in
match origin with
@ -88,7 +88,7 @@ let get_description origin =
| Formal s ->
Some ("method parameter " ^ Mangled.to_string s, None, None)
| Proc po ->
let strict = match TypeErr.Strict.signature_get_strict po.annotated_signature with
let strict = match TypeErr.Strict.signature_get_strict tenv po.annotated_signature with
| Some ann ->
let str = "@Strict" in
(match ann.Typ.parameters with

@ -30,7 +30,7 @@ type t =
val equal : t -> t -> bool
(** Get a description to be used for error messages. *)
val get_description : t -> TypeErr.origin_descr option
val get_description : Tenv.t -> t -> TypeErr.origin_descr option
(** Join with left priority *)
val join : t -> t -> t

@ -75,8 +75,8 @@ let pp ext fmt typestate =
pp_map typestate.map;
ext.pp fmt typestate.extension
let type_join typ1 typ2 =
if PatternMatch.type_is_object typ1 then typ2 else typ1
let type_join tenv typ1 typ2 =
if PatternMatch.type_is_object tenv typ1 then typ2 else typ1
let locs_join locs1 locs2 =
IList.merge_sorted_nodup Location.compare [] locs1 locs2
@ -86,13 +86,13 @@ let range_add_locs (typ, ta, locs1) locs2 =
(typ, ta, locs')
(** Join m2 to m1 if there are no inconsistencies, otherwise return m1. *)
let map_join m1 m2 =
let map_join tenv m1 m2 =
let tjoined = ref m1 in
let range_join (typ1, ta1, locs1) (typ2, ta2, locs2) =
match TypeAnnotation.join ta1 ta2 with
| None -> None
| Some ta' ->
let typ' = type_join typ1 typ2 in
let typ' = type_join tenv typ1 typ2 in
let locs' = locs_join locs1 locs2 in
Some (typ', ta', locs') in
let extend_lhs exp2 range2 = (* extend lhs if possible, otherwise return false *)
@ -119,13 +119,13 @@ let map_join m1 m2 =
!tjoined
)
let join ext t1 t2 =
let join tenv ext t1 t2 =
if Config.from_env_variable "ERADICATE_TRACE"
then L.stderr "@.@.**********join@.-------@.%a@.------@.%a@.********@.@."
(pp ext) t1
(pp ext) t2;
{
map = map_join t1.map t2.map;
map = map_join tenv t1.map t2.map;
extension = ext.join t1.extension t2.extension;
}

@ -38,7 +38,7 @@ val add : Pvar.t -> range -> 'a t -> 'a t
val empty : 'a ext -> 'a t
val equal : 'a t -> 'a t -> bool
val get_extension : 'a t -> 'a
val join : 'a ext -> 'a t -> 'a t -> 'a t
val join : Tenv.t -> 'a ext -> 'a t -> 'a t -> 'a t
val lookup_id : Ident.t -> 'a t -> range option
val lookup_pvar : Pvar.t -> 'a t -> range option
val pp : 'a ext -> Format.formatter -> 'a t -> unit

@ -58,7 +58,7 @@ let create_harness cfg cg tenv =
match pname with
| Procname.Java harness_procname -> harness_procname
| _ -> assert false in
Inhabit.inhabit_trace lifecycle_trace harness_procname cg cfg
Inhabit.inhabit_trace tenv lifecycle_trace harness_procname cg cfg
) tenv
| None -> ()
) AndroidFramework.get_lifecycles

@ -80,7 +80,7 @@ let inhabit_alloc sizeof_typ sizeof_len ret_typ alloc_kind env =
(** find or create a Sil expression with type typ *)
(* TODO: this should be done in a differnt way: just make typ a param of the harness procedure *)
let rec inhabit_typ typ cfg env =
let rec inhabit_typ tenv typ cfg env =
try (TypMap.find typ env.cache, env)
with Not_found ->
let inhabit_internal typ env = match typ with
@ -108,7 +108,7 @@ let rec inhabit_typ typ cfg env =
(* 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) cfg env in
inhabit_constructor tenv constructor (allocated_obj_exp, ptr_to_typ) cfg 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 =
@ -141,21 +141,21 @@ let rec inhabit_typ typ cfg env =
cur_inhabiting = env.cur_inhabiting })
(** inhabit each of the types in the formals list *)
and inhabit_args formals cfg env =
and inhabit_args tenv formals cfg env =
let inhabit_arg (_, formal_typ) (args, env) =
let (exp, env) = inhabit_typ formal_typ cfg env in
let (exp, env) = inhabit_typ tenv formal_typ cfg env in
((exp, formal_typ) :: args, env) in
IList.fold_right inhabit_arg formals ([], env)
(** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the
* remaining arguments *)
and inhabit_constructor constr_name (allocated_obj, obj_type) cfg env =
and inhabit_constructor tenv constr_name (allocated_obj, obj_type) cfg 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 *)
let (args, env) =
let non_receiver_formals = tl_or_empty (formals_from_name cfg constr_name) in
inhabit_args non_receiver_formals cfg env in
inhabit_args tenv non_receiver_formals cfg env in
let constr_instr =
let fun_exp = fun_exp_from_name constr_name in
Sil.Call ([], fun_exp, (allocated_obj, obj_type) :: args, env.pc, CallFlags.default) in
@ -174,7 +174,7 @@ let inhabit_call_with_args procname procdesc args env =
env_add_instr call_instr env
(** create Sil that inhabits args to and calls proc_name *)
let inhabit_call (procname, receiver) cfg env =
let inhabit_call tenv (procname, receiver) cfg env =
try
match procdesc_from_name cfg procname with
| Some procdesc ->
@ -187,7 +187,7 @@ let inhabit_call (procname, receiver) cfg env =
"Expected at least one formal to bind receiver to in method %a@."
Procname.pp procname;
assert false in
let (args, env) = inhabit_args formals cfg env in
let (args, env) = inhabit_args tenv formals cfg env in
inhabit_call_with_args procname procdesc args env
| None -> env
with Not_found -> env
@ -254,7 +254,7 @@ let setup_harness_cfg harness_name env cg cfg =
(** create a procedure named harness_name that calls each of the methods in trace in the specified
* order with the specified receiver and add it to the execution environment *)
let inhabit_trace trace harness_name cg cfg =
let inhabit_trace tenv trace harness_name cg cfg =
if IList.length trace > 0 then
let source_file = Cg.get_source cg in
let harness_file = create_dummy_harness_file harness_name in
@ -267,7 +267,7 @@ let inhabit_trace trace harness_name cg cfg =
cur_inhabiting = TypSet.empty;
harness_name = harness_name; } in
(* invoke lifecycle methods *)
let env'' = IList.fold_left (fun env to_call -> inhabit_call to_call cfg env) empty_env trace in
let env'' = IList.fold_left (fun env to_call -> inhabit_call tenv to_call cfg env) empty_env trace in
try
setup_harness_cfg harness_name env'' cg cfg;
write_harness_to_file (IList.rev env''.instrs) harness_file

@ -15,5 +15,5 @@ type lifecycle_trace = (Procname.t * Typ.t option) list
(** create a procedure named harness_name that calls each of the methods in trace add it to the
cg/cfg *)
val inhabit_trace : lifecycle_trace -> Procname.java -> Cg.t -> Cfg.cfg -> unit
val inhabit_trace : Tenv.t -> lifecycle_trace -> Procname.java -> Cg.t -> Cfg.cfg -> unit

@ -963,7 +963,7 @@ let rec instruction context pc instr : translation =
match instruction_thread_start context original_cn ms obj args var_opt with
| Some start_call -> instruction context pc start_call
| None ->
let cn' = match JTransType.extract_cn_no_obj sil_obj_type with
let cn' = match JTransType.extract_cn_no_obj tenv sil_obj_type with
| Some cn -> cn
| None -> original_cn in
let call_node = create_call_node cn' invoke_kind in

@ -86,7 +86,7 @@ let rec create_array_type typ dim =
Typ.Tptr(Typ.Tarray (content_typ, None), Typ.Pk_pointer)
else typ
let extract_cn_no_obj typ =
let extract_cn_no_obj _tenv typ =
match typ with
| Typ.Tptr (Tstruct { name = TN_csu (Class _, _) as name }, Pk_pointer) ->
let class_name = Typename.name name in

@ -75,7 +75,7 @@ val create_array_type : Typ.t -> int -> Typ.t
val extract_cn_type_np : Typ.t -> Typ.t
(** [extract_cn_type_np] returns the Java class name of typ when typ is a pointer type, otherwise returns None *)
val extract_cn_no_obj : Typ.t -> JBasics.class_name option
val extract_cn_no_obj : Tenv.t -> Typ.t -> JBasics.class_name option
(** returns a string representation of a Java basic type. *)
val string_of_basic_type : JBasics.java_basic_type -> string

Loading…
Cancel
Save