let rec get_wp_edge ((_kf, _g, annots, he, wenv) as env) e =
!Db.progress ();
let v = Cil2cfg.edge_dst e in
Wp_parameters.debug ~level:3
"[get_wp_edge] get wp before %a@." Cil2cfg.pp_node v;
try
let res = R.find he e in
Wp_parameters.debug ~level:3
"[get_wp_edge] %a already computed@." Cil2cfg.pp_node v;
res
with Not_found ->
match WpAnnot.get_cut (annots.WpAnnot.get_annots e) with
| [] ->
let wp = compute_wp_edge env e in
R.set annots wenv he e wp
| cutp ->
Wp_parameters.debug ~level:3
"[get_wp_edge] cut at node %a@." Cil2cfg.pp_node v;
let add_cut_goal (g,p) acc =
if g then add_goal wenv acc p else acc
in
let edge_annot = List.fold_right add_cut_goal cutp W.empty in
let edge_annot = R.set annots wenv he e edge_annot in
let wp = compute_wp_edge env e in
let oblig = List.fold_right
(fun (_,p) acc -> add_hyp wenv acc p) cutp wp
in
R.add_oblig he Logic_const.pre_label oblig;
edge_annot
and get_only_succ env g v = match Cil2cfg.succ_e g v with
| [e'] -> get_wp_edge env e'
| ls -> Wp_parameters.fatal "CFV node %a has %d successors instead of 1@."
Cil2cfg.pp_node v (List.length ls)
and compute_wp_edge ((kf, g, annots, he, wenv) as env) e =
let v = Cil2cfg.edge_dst e in
Wp_parameters.debug ~level:3
"[compute_edge] before %a go...@." Cil2cfg.pp_node v;
let old_loc = Cil.CurrentLoc.get () in
let () = match Cil2cfg.node_stmt_opt v with
| Some s -> Cil.CurrentLoc.set (Stmt.loc s)
| None -> ()
in
let formals = Kernel_function.get_formals kf in
let res = match Cil2cfg.node_type v with
| Cil2cfg.Vstart ->
Wp_parameters.fatal "No CFG edge can lead to Vstart"
| Cil2cfg.VfctIn ->
let obj = get_only_succ env g v in
let obj = wp_scope wenv formals Mcfg.SC_Function_in obj in
let obj = wp_scope wenv [] Mcfg.SC_Global obj in
obj
| Cil2cfg.VblkIn (Cil2cfg.Bfct, b) ->
let obj = get_only_succ env g v in
let obj = wp_scope wenv b.blocals Mcfg.SC_Block_in obj in
wp_scope wenv formals Mcfg.SC_Function_frame obj
| Cil2cfg.VblkIn (_, b) ->
let obj = get_only_succ env g v in
wp_scope wenv b.blocals Mcfg.SC_Block_in obj
| Cil2cfg.VblkOut (_, _b) ->
let obj = get_only_succ env g v in
obj
| Cil2cfg.Vstmt s ->
let obj = get_only_succ env g v in
wp_stmt wenv s obj
| Cil2cfg.VcallIn (stmt, res, fct, args) ->
begin
let en, ee = Cil2cfg.get_call_out_edges g v in
let objn = get_wp_edge env en in
let obje = get_wp_edge env ee in
wp_call wenv annots stmt res fct args objn obje
end
| Cil2cfg.VcallOut (_s, _res, _fct, _args) ->
let obj = get_only_succ env g v in
obj
| Cil2cfg.VcallExit (_s, _res, _fct, _args) ->
let obj = get_only_succ env g v in
obj
| Cil2cfg.Vtest (true, _, c) ->
let et, ef = Cil2cfg.get_test_edges g v in
let t_obj = get_wp_edge env et in
let f_obj = get_wp_edge env ef in
W.test wenv c t_obj f_obj
| Cil2cfg.Vtest (false, _, _) ->
get_only_succ env g v
| Cil2cfg.Vswitch (_, e) ->
let cases, def_edge = Cil2cfg.get_switch_edges g v in
let cases_obj = List.map (fun (c,e) -> c, get_wp_edge env e) cases in
let def_obj = get_wp_edge env def_edge in
W.switch wenv e cases_obj def_obj
| Cil2cfg.Vloop (_, s) ->
begin
let get_loop_head = fun n -> get_only_succ env g n in
let get_vloop_effect = fun p -> wp_stmt wenv s p in
R.wp_loop g annots he v e get_loop_head get_vloop_effect
end
| Cil2cfg.VfctOut
| Cil2cfg.Vexit ->
let obj = get_only_succ env g v in
wp_scope wenv formals Mcfg.SC_Function_out obj
| Cil2cfg.Vend ->
W.empty
in
let res =
let blks = Cil2cfg.blocks_closed_by_edge g e in
let free_locals res b = wp_scope wenv b.blocals Mcfg.SC_Block_out res in
List.fold_left free_locals res blks
in
Wp_parameters.debug ~level:3
"[compute_edge] before %a done@." Cil2cfg.pp_node v;
Cil.CurrentLoc.set old_loc;
res