let get_bhv_annots b cfg =
let default, bname = match b with Some b -> false, b.b_name
| None -> true, Macros.name_of_default_behavior
in
let kf = Cil2cfg.cfg_kf cfg in
Wp_parameters.feedback "select annotations for '%s' behavior of '%a'@."
bname Kernel_function.pretty_name kf;
let spec = get_spec kf in
let _ = match get_behav bname spec.spec_behavior with None -> ()
| Some b ->
begin
match b.b_assigns with [] -> ()
| assigns ->
Wp_parameters.warning
"no proof obligation generation for function assigns:@.%a@."
Macros.pp_assigns assigns
end
in
let annots = Hannots.create 7 in
let add_in_tbl _num lp kind e =
let (h, g) = try Hannots.find annots e with Not_found -> [], [] in
let h, g = match kind with
| Ahyp -> lp @ h, g
| Agoal -> h, lp @ g
in Hannots.replace annots e (h, g)
in
let g = Cil2cfg.cfg_graph cfg in
let add_annots kind lp before v =
let edges = if before then CFG.pred_e g v else CFG.succ_e g v in
match edges with [] -> ()
| e::[] -> add_in_tbl None lp kind e
| _ -> ignore (List.fold_left
(fun n e -> add_in_tbl (Some n) lp kind e; n+1) 1 edges)
in
let get_node_annot v =
Wp_parameters.debug ~level:2 "get_node_annot for node %a"
Cil2cfg.VL.pretty v;
match !v with
| Cil2cfg.Vstart _ ->
let pre = get_preconditions bname spec in
let _ = add_annots Ahyp pre false v in
let lp = complet_behaviors_props default spec in
let _ = add_annots Agoal lp false v in
let lp = disjoint_behaviors_props default spec in
let _ = add_annots Agoal lp false v in
()
| Cil2cfg.Vexit _ ->
let post = get_postconditions bname spec in
let before = true in
let _ = add_annots Agoal post before v in
()
| Cil2cfg.VfctIn _ | Cil2cfg.VfctOut _ -> ()
| Cil2cfg.VblkIn s ->
let annot_before, _annot_after = get_stmt_annots bname s in
add_annots Agoal annot_before true v;
| Cil2cfg.VblkOut s ->
let _annot_before, annot_after = get_stmt_annots bname s in
add_annots Agoal annot_after false v;
| Cil2cfg.Vstmt s ->
let annot_before, annot_after = get_stmt_annots bname s in
add_annots Agoal annot_before true v;
add_annots Agoal annot_after false v;
| Cil2cfg.Vtest (s, _) ->
let annot_before, annot_after = get_stmt_annots bname s in
add_annots Agoal annot_before true v;
if annot_after <> [] then
Wp_parameters.warning ~once:true
"Ignoring annotation rooted after 'if' statement"
| Cil2cfg.Vloop (_, s) ->
let annot_before, annot_after = get_stmt_annots bname s in
add_annots Agoal annot_before true v;
if annot_after <> [] then
Wp_parameters.warning ~once:true
"Ignoring annotation rooted after 'loop' statement";
let inv = get_loop_invariant bname s in
add_annots Agoal inv true v;
add_annots Ahyp inv false v
in
CFG.iter_vertex get_node_annot g;
{ behavior_name = (match b with None -> None | Some b -> Some b.b_name);
find_hyps = (fun e ->
try let h, _ = Hannots.find annots e in h with Not_found -> []);
find_goals = (fun e ->
try let _, g = Hannots.find annots e in g with Not_found -> []);
find_loop_assigns = (fun e -> get_loop_assigns bname e);
called_preconditions =
(fun kf -> get_ext_preconditions (get_spec kf));
called_postconditions =
(fun kf -> get_ext_postconditions (get_spec kf));
called_assigns =
(fun kf -> get_ext_fct_assigns (get_spec kf));
}