let rec eval_term env result t =
let with_alarms = warn_raise_mode in
match t.term_node with
| Tat (t, lab) -> begin
let lab = convert_label lab in
eval_term { env with e_cur = lab } result t
end
| TConst (CInt64 (v, _, _)) -> [intType, Cvalue.V.inject_int v]
| TConst (CEnum e) ->
(match (constFold true e.eival).enode with
| Const (CInt64 (v, _, _)) -> [intType, Cvalue.V.inject_int v]
| _ -> raise Predicate_alarm)
| TConst (CChr c) -> [intType, Cvalue.V.inject_int
(Int.of_int (int_of_char c))]
| TConst (CReal (f, _, _)) ->
Value_parameters.result ~once:true "float support is experimental";
let f = Ival.F.of_float f in
let _, f = Ival.Float_abstract.inject_r f f in
[floatType, Cvalue.V.inject_ival (Ival.Float f)]
| TAddrOf _
| TStartOf _ ->
let conv (typ, loc) = (typ, loc_bits_to_loc_bytes loc) in
List.map conv (eval_tlval env result t)
| TLval _ ->
let lvals = eval_tlval env result t in
let eval_lval (typ, loc) =
let v = Cvalue.Model.find ~conflate_bottom:false
~with_alarms (env_current_state env)
(make_loc loc (Bit_utils.sizeof typ))
in
let v = do_cast ~with_alarms typ v in
(typ, v)
in
List.map eval_lval lvals
| TBinOp (op,t1,t2) -> begin
let l1 = eval_term env result t1 in
let l2 = eval_term env result t2 in
let aux (te1, v1) (_te2, v2) =
let te1 = unrollType te1 in
let v = match te1 with
| TInt _ | TPtr _ | TEnum _ ->
eval_binop_int ~with_alarms ~te1 v1 op v2
| TFloat _ ->
eval_binop_float ~with_alarms v1 op v2
| _ -> raise Predicate_alarm
in
(te1, v)
in
match op, l1, l2 with
| (PlusA | PlusPI | IndexPI | MinusA | MinusPI), _, _
| (Eq | Ne), _ , _ ->
List.fold_left (fun acc e1 ->
List.fold_left (fun acc e2 -> aux e1 e2 :: acc) acc l2) [] l1
| _, [e1], [e2] -> [aux e1 e2]
| _ ->
raise Predicate_alarm
end
| TUnOp (op, t) ->
let l = eval_term env result t in
let typ' t = match op with
| Neg -> t
| BNot -> t
| LNot -> intType
in
let eval typ v = eval_unop ~with_alarms v typ op in
List.map (fun (typ, v) -> typ' typ, eval typ v) l
| Trange (otlow, othigh) ->
let eval proj join = function
| None -> None
| Some t ->
let lbound = eval_term env result t in
let aux (typ, v) =
if not (isIntegralType typ) then raise Predicate_alarm;
try proj (Cvalue.V.project_ival v)
with Cvalue.V.Not_based_on_null -> None
in
match List.map aux lbound with
| [] -> raise Predicate_alarm
| h :: q ->
let join v1 v2 = match v1, v2 with
| None, _ | _, None -> None
| Some v1, Some v2 -> Some (join v1 v2)
in
List.fold_left join h q
in
let min = eval Ival.min_int Int.min otlow
and max = eval Ival.max_int Int.max othigh in
[intType, Cvalue.V.inject_ival (Ival.inject_range min max)]
| TCastE (typ, t) ->
let l = eval_term env result t in
List.map (fun (_, v) -> typ, do_cast ~with_alarms typ v) l
| Tif (tcond, ttrue, tfalse) ->
let l = eval_term env result tcond in
let vtrue = List.exists (fun (_, v) -> Cvalue.V.contains_non_zero v) l
and vfalse = List.exists (fun (_, v) -> Cvalue.V.contains_zero v) l in
(if vtrue then eval_term env result ttrue else [])
@ (if vfalse then eval_term env result tfalse else [])
| TSizeOf _ | TSizeOfE _ | TSizeOfStr _ | TAlignOf _ | TAlignOfE _ ->
let e = Cil.constFoldTerm true t in
let r = match e.term_node with
| TConst (CInt64 (v, _, _)) -> Cvalue.V.inject_int v
| _ -> V.top_int
in
[intType, r]
| _ -> raise Predicate_alarm
and eval_tlhost env result lv =
match lv with
| TVar { lv_origin = Some v } ->
let loc = Location_Bits.inject (Base.find v) Ival.zero in
[v.vtype, loc]
| TResult typ ->
(match result with
| Some v ->
let loc = Location_Bits.inject (Base.find v) Ival.zero in
[typ, loc]
| None -> raise Predicate_alarm)
| TVar { lv_origin = None } ->
raise Predicate_alarm
| TMem t ->
let l = eval_term env result t in
List.map (fun (t, loc) ->
match t with
| TPtr (t, _) -> t, loc_bytes_to_loc_bits loc
| _ -> raise Predicate_alarm
) l
and eval_toffset env result typ toffset =
match toffset with
| TNoOffset ->
[typ, Ival.singleton_zero]
| TIndex (trm, remaining) ->
let typ_pointed = match (unrollType typ) with
| TArray (t, _, _, _) -> t
| TPtr(t,_) ->
(match unrollType t with
| TArray (t, _,_,_) -> t
| _ -> raise Predicate_alarm)
| _ -> raise Predicate_alarm
in
let lloctrm = eval_term env result trm in
let aux (_typ, current) =
let offset =
try Cvalue.V.project_ival current
with Cvalue.V.Not_based_on_null -> raise Predicate_alarm
in
let loffsrem = eval_toffset env result typ_pointed remaining in
let aux (typ, r) =
let offset = Ival.scale_int64base (sizeof typ_pointed) offset in
typ, Ival.add offset r
in
List.map aux loffsrem
in
List.fold_left (fun acc trm -> aux trm @ acc) [] lloctrm
| TField (fi,remaining) ->
let current,_ = bitsOffset typ (Field(fi,NoOffset)) in
let loffs = eval_toffset env result fi.ftype remaining in
List.map (fun (typ, r) -> typ, Ival.add (Ival.of_int current) r) loffs
and eval_tlval env result t =
let process ftyp tlval toffs =
let lvals = eval_tlhost env result tlval in
let aux acc (typ, loc) =
let loffset = eval_toffset env result typ toffs in
let aux acc (typ_offs, offs) =
let loc = Location_Bits.location_shift offs loc in
(ftyp typ_offs, loc) :: acc
in
List.fold_left aux acc loffset
in
List.fold_left aux [] lvals
in
match t.term_node with
| TAddrOf (tlval, toffs)
| TStartOf (tlval, toffs) ->
process (fun typ -> TPtr (typ, [])) tlval toffs
| TLval (tlval, toffs) ->
process (fun typ -> typ) tlval toffs
| Tunion l -> List.concat (List.map (eval_tlval env result) l)
| Tempty_set -> []
| _ -> raise Predicate_alarm