let rec data_of_term env term =
match term.term_node with
| TConst c -> data_const c
| TUnOp (unop,a) ->
data_unop (kind_of term.term_type) unop
(kind_of a.term_type) (data_of_term env a)
| TBinOp(binop,a,b) ->
data_binop
(kind_of term.term_type) binop
(kind_of a.term_type) (data_of_term env a)
(kind_of b.term_type) (data_of_term env b)
| TLval(TResult _ ,off) ->
logic_offset env (F.var(result env.frame)) off
| TLval (TVar{lv_name = "\\exit_status"},_) ->
Data (F.var (status env.frame))
| TLval (TVar lv,off) ->
begin
match lvar env lv with
| Logic_cvar x ->
let tr,gloc = gaddress_of_cvar env x off in
data_load env tr gloc
| Logic_value (M.V_pointer(ty,loc)) ->
Loc (loc_offset env loc ty off)
| Logic_value v ->
let t = M.logic_of_value v in
logic_offset env t off
| Logic_term t ->
logic_offset env t off
| Logic_var x -> logic_offset env (F.var x) off
| Logic_byref -> gaddress_of_ref env lv off
end
| TLval(TMem e,off) ->
let tr,gloc = gaddress_of_mem env e off in
data_load env tr gloc
| TAddrOf(TVar{lv_origin=Some x},off) ->
begin
match xvar env x with
| None -> snd (gaddress_of_cvar env x off)
| Some v -> snd (memory_offset env x.vtype (Value v) off)
end
| TStartOf(TVar{lv_origin=Some x},off) ->
begin
match xvar env x with
| None -> gstartof_cvar env x off
| Some v -> gstartof_value env x.vtype v off
end
| TAddrOf(TMem e,off) ->
snd (gaddress_of_mem env e off)
| TStartOf(TMem e,off) ->
gstartof_mem env e off
| TAddrOf(TResult _,_)
| TStartOf(TResult _,_) -> WpLog.not_yet_implemented "&\\result"
| TAddrOf(TVar {lv_origin=None},_) ->
WpLog.fatal "taking address of a logic variable"
| TStartOf(TVar {lv_origin=None},_) ->
WpLog.not_yet_implemented "reference to a logic array"
| Tat(t,label) -> data_of_term (env_at env (c_label label)) t
| TSizeOf _
| TSizeOfE _
| TSizeOfStr _
| TAlignOf _
| TAlignOfE _ ->
let machdep = true in
let e' = Cil.constFoldTerm machdep term in
begin
match e'.term_node with
| TConst _ -> data_of_term env e'
| _ -> WpLog.fatal "unrecognized sizeof/alignof (%a)"
!Ast_printer.d_term term
end
| Tif (b, t, f) ->
Data
(F.e_cond (boolean_of_data (data_of_term env b))
(term_of_data (data_of_term env t))
(term_of_data (data_of_term env f)))
| Tbase_addr t ->
let obj = match t.term_type with
| Ctype ty -> object_of ty
| _ -> WpLog.fatal "Base-address of logic type object"
in
Loc (M.base_address
(mem_at_env env)
(loc_of_data obj (data_of_term env t)))
| Tblock_length t ->
let obj = match t.term_type with
| Ctype ty -> object_of ty
| _ -> WpLog.fatal "Block-length of logic type object"
in
data_of_integer
(M.block_length
(mem_at_env env)
(loc_of_data obj (data_of_term env t)))
| Trange (ti,tj ) ->
let option_int env = function
| None -> None
| Some x -> Some (integer_of_data (kind_of x.term_type)
(data_of_term env x))
in
let r = {F.inf =(option_int env ti);
F.sup =(option_int env tj)} in
Interval r
| Tempty_set -> List []
| Tunion xs -> union_map (data_of_term env) xs
| Tinter(a::b) ->
Set (List.fold_left
(fun s1 s2 ->
F.inter s1 (set_of (data_of_term env s2)))
(set_of (data_of_term env a)) b)
| Tinter [] -> WpLog.fatal "empty intersection"
| Tcomprehension (_, _, _) ->
WpLog.not_yet_implemented "Set comprehension"
| Tnull -> Loc M.null
| TCastE (ty,t) ->
if Cil.isPointerType ty && Cil.isLogicZero t then
Loc M.null
else
cast (data_of_term env t) (kind_of t.term_type) (kind_of_typ ty)
| TUpdate (_,TNoOffset,tv) ->
data_of_term env tv
| TUpdate (r,TField (f, TNoOffset),tv) ->
begin
match kind_of (r.term_type) with
| Kstruct _ ->
let record = record_of_data (data_of_term env r) in
let v = term_of_data (data_of_term env tv) in
let r = F.upd_field record f v in
Data (F.wrap r)
| _ ->
WpLog.fatal "Functional update of a non-record value"
end
| TUpdate (r,TIndex(k, TNoOffset),tv) ->
begin
match kind_of (r.term_type) with
| Karray _ ->
let array = array_of_data (data_of_term env r) in
let idx = integer_of_data (kind_of k.term_type)
(data_of_term env k) in
let v = term_of_data (data_of_term env tv) in
let r = F.upd_index array idx v in
Data (F.wrap r)
| _ ->
WpLog.fatal "Functional update of a non-array value"
end
| TUpdate (_,_,_) ->
WpLog.not_yet_implemented "ACSL extension for functional update"
| TDataCons({ctor_name="\\true"},[]) -> Data(F.wrap F.e_true)
| TDataCons({ctor_name="\\false"},[]) -> Data(F.wrap F.e_false)
| TDataCons (c,_) ->
WpLog.not_yet_implemented "Constructor (%s)" c.ctor_name
| TCoerce (_,_)
| TCoerceE (_,_) ->
WpLog.fatal "Only produced by Jessie plugin"
| Ttypeof _
| Ttype _ ->
WpLog.not_yet_implemented "Type Tag"
| Tlet (({l_var_info =x;
l_labels=[];l_tparams=[];
l_profile =[];l_body=(LBterm t1); l_type=Some _ } as linfo),t2) ->
if Logic_env.Logic_builtin_used.mem linfo then
Wp_parameters.not_yet_implemented "Built-ins symbols"
else
let var,env2 = bind_fresh env x in
let t1' = term_of_data (data_of_term env t1) in
let t2' = term_of_data (data_of_term env2 t2) in
Data (F.e_subst L.alpha var t1' t2')
| Tlet _ ->
WpLog.not_yet_implemented
"Complex Let-binding"
| Tapp (lfun,labels,args) ->
if Logic_env.Logic_builtin_used.mem lfun then
Wp_parameters.not_yet_implemented "Built-ins symbols"
else
Data (!rec_apply_function env lfun labels args)
| Tlambda (_,_) ->
WpLog.not_yet_implemented "Higher order functions"