let rec cfg_stmts env stmts next = match stmts with
| [] -> next
| [s] -> cfg_stmt env s next
| s::tl ->
let next = cfg_stmts env tl next in
let ns = cfg_stmt env s next in
ns
and cfg_block env bkind b next =
let in_blk = get_node env (VblkIn (bkind, b)) in
let _ = add_edge env in_blk Enext next in
let out_blk = get_node env (VblkOut (bkind, b)) in
let _ = add_edge env out_blk Enone next in
let first_in_blk = cfg_stmts env b.bstmts out_blk in
let _ = add_edge env in_blk Enone first_in_blk in
in_blk
and cfg_switch env switch_stmt switch_exp blk case_stmts next =
let n_switch = get_node env (Vswitch (switch_stmt, switch_exp)) in
add_edge env n_switch Enext next;
let _first = cfg_stmts env blk.bstmts next in
let branch with_def s =
let n = get_stmt_node env s in
let rec find_case l = match l with
| [] -> false, []
| Case (e, _)::tl ->
let r = match find_case tl with
| true, [] -> true, []
| true, _ -> assert false
| false, l -> false, e::l
in r
| Default _ :: _ ->
true, []
| _::tl -> find_case tl
in
let def, case = find_case s.labels in
if case = [] && not def then
Wp_parameters.fatal "[cfg] switch branch without label";
add_edge env n_switch (Ecase case) n;
if def then true else with_def
in
let with_def = List.fold_left branch false case_stmts in
let _ = if not with_def then add_edge env n_switch (Ecase []) next in
n_switch
and cfg_stmt env s next =
!Db.progress ();
match s.skind with
| Instr (Call _) ->
let in_call = get_stmt_node env s in
add_edge env in_call Enone next;
let exit_node = get_node env (Vexit) in
add_edge env in_call Enone exit_node;
in_call
| Instr _ | Return _ ->
let n = get_stmt_node env s in
add_edge env n Enone next;
n
| Block b ->
cfg_block env (Bstmt s) b next
| UnspecifiedSequence seq ->
let b = Cil.block_from_unspecified_sequence seq in
cfg_block env (Bstmt s) b next
| If (e, b1, b2, _) ->
begin
let n_in = get_stmt_node env s in
let n_out = get_node env (Vtest (false, s, e)) in
add_edge env n_out Enone next;
let in_b1 = cfg_block env (Bthen s) b1 n_out in
let in_b2 = cfg_block env (Belse s) b2 n_out in
add_edge env n_in Ethen in_b1;
add_edge env n_in Eelse in_b2;
add_edge env n_in Enext next;
n_in
end
| Loop(_, b, _, _, _) ->
let loop = get_stmt_node env s in
add_edge env loop Enext next;
let in_b = cfg_block env (Bloop s) b loop in
add_edge env loop Enone in_b;
loop
| Break _ | Continue _ | Goto _ ->
let n = get_stmt_node env s in
let _ = match s.succs with
| [s'] -> add_edge env n Enone (get_stmt_node env s')
| _ -> Wp_parameters.fatal "[cfg] jump with more than one successor ?"
in n
| Switch (e, b, lstmts, _) ->
cfg_switch env s e b lstmts next
| TryExcept _ | TryFinally _ ->
Wp_parameters.not_yet_implemented "[cfg] exception handling"