let call caller_env ~get_pre ~get_post ~get_exits ~get_assigns
stmt lv fct args c_assigns p_normal p_exits
=
let frame = L.get_frame caller_env in
let called_kf = match fct.enode with
| Lval (Var vinfo,NoOffset) -> Globals.Functions.get vinfo
| _ ->
Datalib.Collector.add_warning
~severe:true
~reason:"call through function pointer not implemented yet"
"Can not treat function call" ;
raise Failed
in
let kf_pid = WpAnnot.pid_for_function called_kf WpModel.model in
Datalib.Collector.add_depend kf_pid "calling" ;
let p_normal, x_opt = match lv with
| None -> p_normal, None
| Some lv ->
let t_result = Kernel_function.get_return_type called_kf in
let x_result = D.fresh "result" (Mdata.Vacsl (Ctype t_result)) in
let lv_t = Ctypes.object_of t_result in
let casted_result =
cast t_result (Cil.typeOfLval lv)
(WpModel.value_of_logic lv_t (F.var x_result))
in
let v_result = match casted_result with
| Warning(source,reason) ->
Datalib.Collector.add_warning
~severe:true ~source ~reason
"Can not cast the returned value" ;
raise Failed
| Result res -> res
in
let p =
begin
match addr (WpModel.mem_at frame Clabels.Here) lv with
| Warning(source, reason) ->
Datalib.Collector.add_warning
~severe:true ~source ~reason
"Can not assign the returned value, no translation for l-value" ;
raise Failed
| Result loc ->
WpModel.subst_lval frame lv_t loc v_result p_normal
end
in
p, Some x_result
in
let pre_label = Clabels.CallAt stmt.sid in
let m_pre = WpModel.mem_at frame pre_label in
let m_post = WpModel.mem_at frame Clabels.Here in
let called_pre = get_pre called_kf in
let called_assigns = get_assigns called_kf in
let called_post = get_post called_kf in
let called_exits = get_exits called_kf in
let translate_arg e =
match expr m_pre e with
| Warning(source,reason) ->
Datalib.Collector.add_warning ~source ~reason
"Can not call function, no translation for parameter '%a'"
!Ast_printer.d_exp e ;
raise Failed
| Result v -> v
in
let values = List.map translate_arg args in
let do_prop env item p =
match predicate env p with
| Warning(source,reason) ->
Datalib.Collector.add_warning
~source ~reason
"Ignored %s for function call" item ;
F.p_true
| Result p -> p
in
let env_post = L.call_post called_kf values m_pre m_post x_opt
in
let do_post (_id, post) p =
F.p_implies (do_prop env_post "post-condition" post) p
in
let pn0 =
if F.is_true p_normal then p_normal else
List.fold_right do_post called_post p_normal
in
let pn = match x_opt with None -> pn0 | Some r -> D.forall [r] pn0 in
let x_status, env_exits =
match WpModel.get_exit_status frame with
| None ->
let x_status =
D.fresh "exit_status" (Mdata.Vmodel Formula.Integer)
in
x_status, L.call_exit env_post x_status
| Some x -> x, L.call_exit env_post x
in
let do_exits (_id, e) p =
F.p_implies (do_prop env_exits "exit-condition" e) p
in
let pe =
if F.is_true p_exits then p_exits else
D.forall [x_status]
(List.fold_right do_exits called_exits p_exits) in
let env_pre = L.call_pre called_kf values m_pre in
let asgnd = assigned_of_assigns env_pre called_assigns in
let p1n = havoc_region WpAnnot.StmtAssigns frame asgnd pn in
let p1e = havoc_region WpAnnot.StmtAssigns frame asgnd pe in
let do_precond (_id, p) =
do_prop env_pre "pre-condition" p
in
let preconditions = List.map do_precond called_pre in
let precondition = F.p_conj preconditions in
let p2n = F.p_implies precondition p1n in
let p2e = F.p_implies precondition p1e in
let p3n = check_assigns c_assigns asgnd p2n in
let p3e = check_assigns c_assigns asgnd p2e in
let condlabel = "Requires_" ^ Kernel_function.get_name called_kf in
let p4n = F.p_and (F.p_named condlabel precondition) p3n in
let p4e = F.p_and (F.p_named condlabel precondition) p3e in
let pn = WpModel.update_at_label frame pre_label p4n in
let pe = WpModel.update_at_label frame pre_label p4e in
(pn,pe)