let rec eval_cond ~with_alarms state cond =
if hasAttribute "volatile" (typeAttr (typeOf cond.exp)) then state
else
let eval_symetric_int positive binop cond_expr value =
match positive,binop with
| false, Eq | true, Ne -> V.diff_if_one value cond_expr
| true, Eq | false, Ne -> V.narrow value cond_expr
| _,_ -> value
in
let eval_symetric_float = eval_symetric_int in
let eval_antisymetric_int ~typ_loc:_ positive binop cond_expr value =
try match positive,binop with
| true, Le | false, Gt ->
V.filter_le value ~cond_expr
| true, Ge | false, Lt ->
V.filter_ge value ~cond_expr
| false, Le | true, Gt ->
V.filter_gt value ~cond_expr
| false, Ge | true, Lt ->
V.filter_lt value ~cond_expr
| _,_ -> value
with V.Error_Bottom -> V.bottom
in
let eval_antisymetric_float ~typ_loc positive binop cond_expr value =
try match positive,binop with
| true, Le | false, Gt ->
V.filter_le_float value ~cond_expr
| true, Ge | false, Lt ->
V.filter_ge_float value ~cond_expr
| false, Le | true, Gt ->
V.filter_gt_float (Value_parameters.AllRoundingModes.get ())
~typ_loc value ~cond_expr
| false, Ge | true, Lt ->
V.filter_lt_float (Value_parameters.AllRoundingModes.get ())
~typ_loc value ~cond_expr
| _,_ -> value
with V.Error_Bottom -> V.bottom
in
let eval_as_exact_loc state e =
try
let lv = find_lv ~with_alarms state e in
let loc = lval_to_loc ~with_alarms state lv in
if not (valid_cardinal_zero_or_one loc)
then raise Not_an_exact_loc;
let typ = typeOfLval lv in
let value_for_loc =
Relations_type.Model.find ~conflate_bottom:true
~with_alarms state loc
in
let value_for_loc2 =
do_cast
~with_alarms
typ
value_for_loc
in
if Cvalue_type.V.has_sign_problems value_for_loc &&
not (Cvalue_type.V.equal value_for_loc value_for_loc2)
then begin
raise Not_an_exact_loc;
end;
loc, value_for_loc2, typ
with Cannot_find_lv ->
raise Not_an_exact_loc
in
let rec aux cond state =
match cond.positive,cond.exp.enode with
| _positive, BinOp ((Le|Ne|Eq|Gt|Lt|Ge as binop), exp1, exp2, _typ) ->
let eval_eq_ineq eval_symetric eval_antisymetric =
let loc1 = ref None in
let loc2 = ref None in
let result1 =
try
let left_loc,value_for_loc,typ_loc =
eval_as_exact_loc state exp1
in
loc1 := Some left_loc;
let cond_expr = eval_expr ~with_alarms state exp2 in
let v_sym =
eval_symetric cond.positive binop cond_expr value_for_loc
in
let v_asym =
eval_antisymetric ~typ_loc
cond.positive binop cond_expr v_sym
in
if V.equal v_asym V.bottom then raise Reduce_to_bottom;
if V.equal v_asym value_for_loc
then state
else
Relations_type.Model.reduce_binding state left_loc v_asym
with Not_an_exact_loc -> state
in
let result2 = try
let right_loc,value_for_loc,typ_loc =
eval_as_exact_loc result1 exp2
in
loc2 := Some right_loc;
let cond_expr = eval_expr ~with_alarms result1 exp1
in
let v_sym = eval_symetric
cond.positive binop cond_expr value_for_loc
in
let v_asym = eval_antisymetric
~typ_loc
cond.positive
(match binop with Gt -> Lt | Lt -> Gt | Le -> Ge | Ge -> Le
| _ -> binop)
cond_expr
v_sym
in
if V.equal v_asym V.bottom then raise Reduce_to_bottom;
if V.equal v_asym value_for_loc
then result1
else
Relations_type.Model.reduce_binding result1 right_loc v_asym
with Not_an_exact_loc -> result1
in
let result3 =
begin match (cond.positive, binop), !loc1, !loc2 with
((true,Eq)|(false, Ne)), Some(left_loc), Some(right_loc) ->
Relations_type.Model.reduce_equality
result2 left_loc right_loc
| _ -> result2
end
in
result3
in
let t1 = unrollType (typeOf exp1) in
if isIntegralType t1 || isPointerType t1
then
eval_eq_ineq eval_symetric_int eval_antisymetric_int
else
eval_eq_ineq eval_symetric_float eval_antisymetric_float
| true, BinOp (LAnd, exp1, exp2, _)
| false, BinOp (LOr, exp1, exp2, _) ->
let new_state = aux {cond with exp = exp1} state in
let result = aux {cond with exp = exp2} new_state in
result
| false, BinOp (LAnd, exp1, exp2, _)
| true, BinOp (LOr, exp1, exp2, _) ->
let new_v1 = try aux {cond with exp = exp1} state
with Reduce_to_bottom -> Relations_type.Model.bottom
in let new_v2 = try aux {cond with exp = exp2} state
with Reduce_to_bottom -> Relations_type.Model.bottom
in
Relations_type.Model.join new_v1 new_v2
| _, UnOp(LNot,exp,_) ->
aux
{ positive = not cond.positive;
exp = exp; }
state
| _, Lval _
when let t = typeOf cond.exp in
isIntegralType t || isPointerType t
->
(try
let loc,value_for_loc,_ = eval_as_exact_loc state cond.exp in
let new_value =
eval_symetric_int (not cond.positive)
Eq
(V.inject_ival Ival.singleton_zero)
value_for_loc
in
if V.equal new_value V.bottom then
raise Reduce_to_bottom
else
Relations_type.Model.reduce_binding
state loc new_value
with Not_an_exact_loc -> state)
| _ -> state
in
let result =
aux cond state
in
let condition_may_still_be_true_in_state env =
let cond_interp = eval_expr ~with_alarms env cond.exp in
(not cond.positive || V.contains_non_zero cond_interp) &&
(cond.positive || V.contains_zero cond_interp)
in
if (not (Relations_type.Model.equal result state)) &&
(not (condition_may_still_be_true_in_state result))
then raise Reduce_to_bottom;
let is_enumerable v =
let v_interp =
Relations_type.Model.find ~conflate_bottom:true ~with_alarms result v
in
ignore (Location_Bytes.cardinal_less_than v_interp 7);
v_interp
in
let rec enumerate_one_var l =
match l with
| [] -> raise Not_found
| v::t ->
try
let v_interp = is_enumerable v in
v,v_interp,t
with Abstract_interp.Not_less_than ->
enumerate_one_var t
in
let invert_cond vl =
try
let v1,v_interp1, _tail = enumerate_one_var vl in
let f one_val acc =
let env =
Relations_type.Model.reduce_binding
result v1 one_val
in
if condition_may_still_be_true_in_state env
then begin
Location_Bytes.join one_val acc
end
else begin
acc
end
in
let new_v_interp =
Location_Bytes.fold_enum
~split_non_enumerable:2
f v_interp1 Location_Bytes.bottom
in
let state_value =
if V.equal new_v_interp V.bottom
then raise Reduce_to_bottom
else Relations_type.Model.reduce_binding result v1 new_v_interp
in
state_value
with Not_found -> result
in
let result1 =
invert_cond (get_influential_vars ~with_alarms result cond.exp)
in
if not (Relations_type.Model.is_reachable result1)
then raise Reduce_to_bottom
else result1