let rec reduce_by_predicate ~result env positive p =
let result =
match positive,p.content with
| true,Ptrue | false,Pfalse -> env
| true,Pfalse | false,Ptrue ->
overwrite_current_state env Cvalue.Model.bottom
| true,Pand (p1,p2 ) | false,Por(p1,p2)->
let r1 = reduce_by_predicate ~result env positive p1 in
reduce_by_predicate ~result r1 positive p2
| true,Por (p1,p2 ) | false,Pand (p1, p2) ->
join_env
(reduce_by_predicate ~result env positive p1)
(reduce_by_predicate ~result env positive p2)
| true,Pimplies (p1,p2) ->
join_env
(reduce_by_predicate ~result env false p1)
(reduce_by_predicate ~result env true p2)
| false,Pimplies (p1,p2) ->
reduce_by_predicate ~result
(reduce_by_predicate ~result env true p1)
false
p2
| _,Pnot p -> reduce_by_predicate ~result env (not positive) p
| true,Piff (p1, p2) ->
let red1 =
reduce_by_predicate ~result env true (Logic_const.pand (p1, p2)) in
let red2 =
reduce_by_predicate ~result env false (Logic_const.por (p1, p2)) in
join_env red1 red2
| false,Piff (p1, p2) ->
reduce_by_predicate ~result env true
(Logic_const.por
(Logic_const.pand (p1, Logic_const.pnot p2),
Logic_const.pand (Logic_const.pnot p1, p2)))
| _,Pxor(p1,p2) ->
reduce_by_predicate ~result env
(not positive) (Logic_const.piff(p1, p2))
| _,Prel (op,t1,t2) ->
begin
try
let eval = match t1.term_type with
| t when isLogicRealOrFloatType t ->
eval_float (Value_parameters.AllRoundingModes.get ())
| t when isLogicIntegralType t -> eval_int
| Ctype (TPtr _) -> eval_int
| _ -> raise Predicate_alarm
in
reduce_by_relation eval ~result env positive t1 op t2
with
| Predicate_alarm -> env
| Reduce_to_bottom ->
overwrite_current_state env Cvalue.Model.bottom
end
| _,Pvalid ({ term_node = TLval _} as t) ->
begin
try
let l = eval_tlval env result t in
let aux env (typ, lval) =
let loc = make_loc lval (Bit_utils.sizeof typ) in
if valid_cardinal_zero_or_one ~for_writing:false loc then
let state =
reduce_by_valid_loc ~positive ~for_writing:false
loc typ (env_current_state env)
in
overwrite_current_state env state
else env
in
List.fold_left aux env l
with Predicate_alarm -> env
end
| _, Pvalid _ -> env
| _,Pinitialized tsets ->
begin try
let locb = eval_term env result tsets in
List.fold_left
(fun env (e, loc) ->
let state = reduce_by_initialized_loc ~with_alarms:warn_raise_mode
~positive (e, loc) (env_current_state env)
in
overwrite_current_state env state
) env locb
with
| Predicate_alarm -> env
end
| _,Pat _ -> env
| _,Papp _
| _,Pexists (_, _) | _,Pforall (_, _)
| _,Pvalid_range (_, _, _)| _,Pvalid_index (_, _)
| _,Plet (_, _) | _,Pif (_, _, _)
| _,Pfresh _ | _,Psubtype _
| _, Pseparated _
-> env
in
result
and reduce_by_relation eval ~result env positive t1 rel t2 =
let env = reduce_by_left_relation eval ~result env positive t1 rel t2 in
let inv_binop = match rel with
| Rgt -> Rlt | Rlt -> Rgt | Rle -> Rge | Rge -> Rle
| _ -> rel
in
reduce_by_left_relation eval ~result env positive t2 inv_binop t1
and reduce_by_left_relation eval ~result env positive tl rel tr =
let with_alarms = warn_raise_mode in
try
let state = env_current_state env in
let typ_loc, loc = eval_term_as_exact_loc env result tl in
let value_for_loc =
Cvalue.Model.find ~conflate_bottom:true ~with_alarms state loc in
let value_for_loc = do_cast ~with_alarms typ_loc value_for_loc in
let cond_v =
List.fold_left (fun v (_, v') -> Location_Bytes.join v v')
Location_Bytes.bottom (eval_term env result tr)
in
let op = lop_to_cop rel in
let v_sym = eval.eval_symetric positive op cond_v value_for_loc in
let v_asym = eval.eval_antisymetric ~typ_loc positive op cond_v v_sym in
if V.equal v_asym V.bottom then raise Reduce_to_bottom;
if V.equal v_asym value_for_loc
then env
else
let state' = Cvalue.Model.reduce_binding ~with_alarms state loc v_asym in
overwrite_current_state env state'
with Predicate_alarm | Not_an_exact_loc -> env