[bpt/coccinelle.git] / parsing_c / ast_to_flow.ml

(* Yoann Padioleau
 * 
 * Copyright (C) 2006, 2007 Ecole des Mines de Nantes
 *
 * This program is free software; you can redistribute it and/or
 * modify it under the terms of the GNU General Public License (GPL)
 * version 2 as published by the Free Software Foundation.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * file license.txt for more details.
 *)
open Common

open Ast_c
open Control_flow_c

open Ograph_extended
open Oassoc
open Oassocb


(*****************************************************************************)
(* todo?: compute target level with goto (but rare that different I think)
 * ver1: just do init, 
 * ver2: compute depth of label (easy, intercept compound in the visitor)
 * 
 * checktodo: after a switch, need check that all the st in the
 * compound start with a case: ?
 * 
 * checktodo: how ensure that when we call aux_statement recursivly, we
 * pass it xi_lbl and not just auxinfo ? how enforce that ?
 * in fact we must either pass a xi_lbl or a newxi
 * 
 * todo: can have code (and so nodes) in many places, in the size of an
 * array, in the init of initializer, but also in StatementExpr, ...
 * 
 * todo?: steal code from CIL ? (but seems complicated ... again) *)
(*****************************************************************************)

(*****************************************************************************)
(* Types *)
(*****************************************************************************)

type error = 
  | DeadCode          of Common.parse_info option
  | CaseNoSwitch      of Common.parse_info
  | OnlyBreakInSwitch of Common.parse_info
  | NoEnclosingLoop   of Common.parse_info
  | GotoCantFindLabel of string * Common.parse_info
  | NoExit of Common.parse_info
  | DuplicatedLabel of string
  | NestedFunc
  | ComputedGoto
  | Define of Common.parse_info

exception Error of error

(*****************************************************************************)
(* Helpers *)
(*****************************************************************************)

let add_node node labels nodestr g = 
   g#add_node (Control_flow_c.mk_node node labels [] nodestr)
let add_bc_node node labels parent_labels nodestr g = 
   g#add_node (Control_flow_c.mk_node node labels parent_labels  nodestr)
let add_arc_opt (starti, nodei) g = 
  starti +> do_option (fun starti -> g#add_arc ((starti, nodei), Direct))


let lbl_0 = [] 

let pinfo_of_ii ii = Ast_c.get_opi (List.hd ii).Ast_c.pinfo



(*****************************************************************************)
(* Contextual information passed in aux_statement *)
(*****************************************************************************)

(* Sometimes have a continue/break and we must know where we must jump.
 *    
 * ctl_brace: The node list in context_info record the number of '}' at the 
 * context point, for instance at the switch point. So that when deeper,
 * we can compute the difference between the number of '}' from root to
 * the context point to close the good number of '}' . For instance 
 * where there is a 'continue', we must close only until the for.
 *)
type context_info =
  | NoInfo 
  | LoopInfo   of nodei * nodei (* start, end *) * node list * int list
  | SwitchInfo of nodei * nodei (* start, end *) * node list * int list

(* for the Compound case I need to do different things depending if 
 * the compound is the compound of the function definition, the compound of
 * a switch, so this type allows to specify this and enable to factorize
 * code for the Compound
 *)
and compound_caller = 
  FunctionDef | Statement | Switch of (nodei -> xinfo -> xinfo)

(* other information used internally in ast_to_flow and passed recursively *) 
and xinfo =  { 

  ctx: context_info; (* cf above *)
  ctx_stack: context_info list;

  (* are we under a ifthen[noelse]. Used for ErrorExit *)
  under_ifthen: bool; 
  compound_caller: compound_caller;

  (* does not change recursively. Some kind of globals. *)
  labels_assoc: (string, nodei) oassoc; 
  exiti:      nodei option;
  errorexiti: nodei option;

  (* ctl_braces: the nodei list is to handle current imbrication depth.
   * It contains the must-close '}'. 
   * update: now it is instead a node list. 
   *)
  braces: node list;

  (* ctl: *)
  labels: int list; 
  }


let initial_info = {
  ctx = NoInfo; 
  ctx_stack = [];
  under_ifthen = false;
  compound_caller = Statement;
  braces = [];
  labels = []; 

  (* don't change when recurse *)
  labels_assoc = new oassocb [];
  exiti = None;
  errorexiti = None;
} 


(*****************************************************************************)
(* (Semi) Globals, Julia's style. *)
(*****************************************************************************)
(* global graph *)
let g = ref (new ograph_mutable) 

let counter_for_labels = ref 0
let counter_for_braces = ref 0

(* For switch we use compteur too (or pass int ref) cos need know order of the
 * case if then later want to go from CFG to (original) AST. 
 * update: obsolete now I think
 *)
let counter_for_switch = ref 0


(*****************************************************************************)
(* helpers *)
(*****************************************************************************)

(* alt: do via a todo list, so can do all in one pass (but more complex) 
 * todo: can also count the depth level and associate it to the node, for 
 * the ctl_braces: 
 *)
let compute_labels_and_create_them st = 

  (* map C label to index number in graph *)
  let (h: (string, nodei) oassoc ref) = ref (new oassocb []) in

  begin
    st +> Visitor_c.vk_statement { Visitor_c.default_visitor_c with 
      Visitor_c.kstatement = (fun (k, bigf) st -> 
        match st with
        | Labeled (Ast_c.Label (name, _st)),ii -> 
            (* at this point I put a lbl_0, but later I will put the
             * good labels. *)
            let s = Ast_c.str_of_name name in
            let newi = !g +> add_node (Label (st,name, ((),ii))) lbl_0  (s^":") 
            in
            begin
              (* the C label already exists ? *)
              if (!h#haskey s) then raise (Error (DuplicatedLabel s));
              h := !h#add (s, newi);
              (* not k _st !!! otherwise in lbl1: lbl2: i++; we miss lbl2 *)
              k st; 
            end
        | st -> k st
      )
    };
    !h;
  end


(* ctl_braces: *)
let insert_all_braces xs starti = 
  xs  +> List.fold_left (fun acc node -> 
    (* Have to build a new node (clone), cos cant share it. 
     * update: This is now done by the caller. The clones are in xs.
     *)
    let newi = !g#add_node node in
    !g#add_arc ((acc, newi), Direct);
    newi
  ) starti

(*****************************************************************************)
(* Statement *)
(*****************************************************************************)

(* Take in a (optional) start node, return an (optional) end node.
 * 
 * history:
 * 
 * ver1: old code was returning an nodei, but goto has no end, so
 * aux_statement should return nodei option.
 * 
 * ver2: old code was taking a nodei, but should also take nodei
 * option.
 * 
 * ver3: deadCode detection. What is dead code ? When there is no
 * starti to start from ? So make starti an option too ? Si on arrive
 * sur un label: au moment d'un deadCode, on peut verifier les
 * predecesseurs de ce label, auquel cas si y'en a, ca veut dire
 * qu'en fait c'est pas du deadCode et que donc on peut se permettre
 * de partir d'un starti à None. Mais si on a xx; goto far:; near:
 * yy; zz; far: goto near:. Bon ca doit etre un cas tres tres rare,
 * mais a cause de notre parcours, on va rejeter ce programme car au
 * moment d'arriver sur near: on n'a pas encore de predecesseurs pour
 * ce label. De meme, meme le cas simple ou la derniere instruction
 * c'est un return, alors ca va generer un DeadCode :(
 * 
 * So make a first pass where dont launch exn at all. Create nodes,
 * if starti is None then dont add arc. Then make a second pass that
 * just checks that all nodes (except enter) have predecessors.
 * So make starti an option too. So type is now
 * 
 *      nodei option -> statement -> nodei option.
 * 
 * todo?: if the pb is at a fake node, then try first successos that 
 * is non fake. 
 * 
 * ver4: because of special needs of coccinelle, need pass more info, cf
 * type additionnal_info defined above.
 * 
 * - to complete (break, continue (and enclosing loop), switch (and
 * associated case, casedefault)) we need to pass additionnal info.
 * The start/exit when enter in a loop, to know the current 'for'.
 * 
 * - to handle the braces, need again pass additionnal info.
 * 
 * - need pass the labels.
 * 
 * convention: xi for the auxinfo passed recursively
 * 
 *)

let rec (aux_statement: (nodei option * xinfo) -> statement -> nodei option) = 
 fun (starti, xi) stmt ->

  if not !Flag_parsing_c.label_strategy_2
  then incr counter_for_labels;
    
  let lbl = 
    if !Flag_parsing_c.label_strategy_2 
    then xi.labels 
    else xi.labels @ [!counter_for_labels]
  in

  (* Normally the new auxinfo to pass recursively to the next aux_statement.
   * But in some cases we add additionnal stuff in which case we don't use
   * this 'xi_lbl' but a 'newxi' specially built.
   *)
  let xi_lbl = 
    if !Flag_parsing_c.label_strategy_2
    then { xi with
      compound_caller = Statement;
    }
    else { xi with 
      labels = xi.labels @ [ !counter_for_labels ]; 
      compound_caller = Statement;
    } 
  in
      
  (* ------------------------- *)        
  match stmt with

  (*  coupling: the Switch case copy paste parts of the Compound case *)
  | Ast_c.Compound statxs, ii -> 
      (* flow_to_ast: *)
      let (i1, i2) = tuple_of_list2 ii in

      (* ctl_braces: *)
      incr counter_for_braces;
      let brace = !counter_for_braces in

      let s1 = "{" ^ i_to_s brace in
      let s2 = "}" ^ i_to_s brace in

      let lbl = match xi.compound_caller with
        | FunctionDef -> xi.labels (* share label with function header *)
        | Statement -> xi.labels @ [!counter_for_labels]
        | Switch _ -> xi.labels
      in
 
      let newi = !g +> add_node (SeqStart (stmt, brace, i1)) lbl s1 in
      let endnode = mk_node     (SeqEnd (brace, i2))         lbl [] s2 in
      let endnode_dup = mk_fake_node (SeqEnd (brace, i2))    lbl [] s2 in
(*
      let _endnode_dup =
        mk_node (SeqEnd (brace, Ast_c.fakeInfo())) lbl [] s2 in
*)

      let newxi = { xi_lbl with braces = endnode_dup:: xi_lbl.braces } in

      let newxi = match xi.compound_caller with
        | Switch todo_in_compound -> 
            (* note that side effect in todo_in_compound *)
            todo_in_compound newi newxi
        | FunctionDef | Statement -> newxi
      in

      !g +> add_arc_opt (starti, newi);
      let starti = Some newi in

      aux_statement_list starti (xi, newxi) statxs

      (* braces: *)
      +> Common.fmap (fun starti -> 
            (* subtil: not always return a Some.
             * Note that if starti is None, alors forcement ca veut dire
             * qu'il y'a eu un return (ou goto), et donc forcement les 
             * braces auront au moins ete crée une fois, et donc flow_to_ast
             * marchera.
             * Sauf si le goto revient en arriere ? mais dans ce cas
             * ca veut dire que le programme boucle. Pour qu'il boucle pas
             * il faut forcement au moins un return.
             *)
            let endi = !g#add_node endnode in
            !g#add_arc ((starti, endi), Direct);
            endi 
           ) 


   (* ------------------------- *)        
  | Labeled (Ast_c.Label (name, st)), ii -> 
      let s = Ast_c.str_of_name name in
      let ilabel = xi.labels_assoc#find s in
      let node = mk_node (unwrap (!g#nodes#find ilabel)) lbl [] (s ^ ":") in
      !g#replace_node (ilabel, node);
      !g +> add_arc_opt (starti, ilabel);
      aux_statement (Some ilabel, xi_lbl) st


  | Jump (Ast_c.Goto name), ii -> 
      let s = Ast_c.str_of_name name in
     (* special_cfg_ast: *)
     let newi = !g +> add_node (Goto (stmt, name, ((),ii))) lbl ("goto "^s^":")
     in
     !g +> add_arc_opt (starti, newi);

     let ilabel = 
       try xi.labels_assoc#find s 
       with Not_found -> 
         (* jump vers ErrorExit a la place ? 
          * pourquoi tant de "cant jump" ? pas detecté par gcc ? 
          *)
         raise (Error (GotoCantFindLabel (s, pinfo_of_ii ii)))
     in
     (* !g +> add_arc_opt (starti, ilabel); 
      * todo: special_case: suppose that always goto to toplevel of function,
      * hence the Common.init 
      * todo?: can perhaps report when a goto is not a classic error_goto ? 
      * that is when it does not jump to the toplevel of the function.
      *)
     let newi = insert_all_braces (Common.list_init xi.braces) newi in
     !g#add_arc ((newi, ilabel), Direct);
     None
      
  | Jump (Ast_c.GotoComputed e), ii -> 
      raise (Error (ComputedGoto))
      
   (* ------------------------- *)        
  | Ast_c.ExprStatement opte, ii -> 
      (* flow_to_ast:   old: when opte = None, then do not add in CFG. *)
      let s = 
        match opte with
        | None -> "empty;"
        | Some e -> 
            let ((unwrap_e, typ), ii) = e in
            (match unwrap_e with
            | FunCall (((Ident (namef), _typ), _ii), _args) -> 
                Ast_c.str_of_name namef ^ "(...)"
            | Assignment (((Ident (namevar), _typ), _ii), SimpleAssign, e) -> 
                Ast_c.str_of_name namevar ^ " = ... ;"
            | Assignment 
                (((RecordAccess (((Ident (namevar), _typ), _ii), field), _typ2),
                  _ii2),
                 SimpleAssign, 
                 e) -> 
                let sfield = Ast_c.str_of_name field in
                Ast_c.str_of_name namevar ^ "." ^ sfield ^ " = ... ;"
                   
            | _ -> "statement"
        )
      in
      let newi = !g +> add_node (ExprStatement (stmt, (opte, ii))) lbl s in
      !g +> add_arc_opt (starti, newi);
      Some newi
      

   (* ------------------------- *)        
  | Selection  (Ast_c.If (e, st1, (Ast_c.ExprStatement (None), []))), ii ->
      (* sometome can have ExprStatement None but it is a if-then-else,
       * because something like   if() xx else ;
       * so must force to have [] in the ii associated with ExprStatement 
       *)
      
      let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
      let ii = [i1;i2;i3] in
     (* starti -> newi --->   newfakethen -> ... -> finalthen --> lasti
      *                  |                                      |
      *                  |->   newfakeelse -> ... -> finalelse -|
      * update: there is now also a link directly to lasti.
      *  
      * because of CTL, now do different things if we are in a ifthen or
      * ifthenelse.
      *)
      let newi = !g +> add_node (IfHeader (stmt, (e, ii))) lbl ("if") in
      !g +> add_arc_opt (starti, newi);
      let newfakethen = !g +> add_node TrueNode        lbl "[then]" in
      let newfakeelse = !g +> add_node FallThroughNode lbl "[fallthrough]" in
      let afteri = !g +> add_node AfterNode lbl "[after]" in
      let lasti  = !g +> add_node (EndStatement (Some iifakeend)) lbl "[endif]"
      in

      (* for ErrorExit heuristic *)
      let newxi = { xi_lbl with  under_ifthen = true; } in

      !g#add_arc ((newi, newfakethen), Direct);
      !g#add_arc ((newi, newfakeelse), Direct);
      !g#add_arc ((newi, afteri), Direct);
      !g#add_arc ((afteri, lasti), Direct);
      !g#add_arc ((newfakeelse, lasti), Direct);

      let finalthen = aux_statement (Some newfakethen, newxi) st1 in
      !g +> add_arc_opt (finalthen, lasti);
      Some lasti

      
  | Selection  (Ast_c.If (e, st1, st2)), ii -> 
     (* starti -> newi --->   newfakethen -> ... -> finalthen --> lasti
      *                 |                                      |
      *                 |->   newfakeelse -> ... -> finalelse -|
      * update: there is now also a link directly to lasti.
      *)
      let (iiheader, iielse, iifakeend) = 
        match ii with
        | [i1;i2;i3;i4;i5] -> [i1;i2;i3], i4, i5
        | _ -> raise Impossible
      in
      let newi = !g +> add_node (IfHeader (stmt, (e, iiheader))) lbl "if" in
      !g +> add_arc_opt (starti, newi);
      let newfakethen = !g +> add_node TrueNode  lbl "[then]" in
      let newfakeelse = !g +> add_node FalseNode lbl "[else]" in
      let elsenode = !g +> add_node (Else iielse) lbl "else" in


      !g#add_arc ((newi, newfakethen), Direct);
      !g#add_arc ((newi, newfakeelse), Direct);

      !g#add_arc ((newfakeelse, elsenode), Direct);

      let finalthen = aux_statement (Some newfakethen, xi_lbl) st1 in
      let finalelse = aux_statement (Some elsenode, xi_lbl) st2 in

      (match finalthen, finalelse with 
        | (None, None) -> None
        | _ -> 
            let lasti = 
              !g +> add_node (EndStatement(Some iifakeend)) lbl "[endif]" in
            let afteri = 
              !g +> add_node AfterNode lbl "[after]" in
            !g#add_arc ((newi, afteri),  Direct);
            !g#add_arc ((afteri, lasti), Direct);
            begin
              !g +> add_arc_opt (finalthen, lasti);
              !g +> add_arc_opt (finalelse, lasti);
              Some lasti
           end)
        
      
   (* ------------------------- *)        
  | Selection  (Ast_c.Switch (e, st)), ii -> 
      let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
      let ii = [i1;i2;i3] in

      (* The newswitchi is for the labels to know where to attach.
       * The newendswitch (endi) is for the 'break'. *)
      let newswitchi= 
        !g+> add_node (SwitchHeader(stmt,(e,ii))) lbl "switch" in
      let newendswitch = 
        !g +> add_node (EndStatement (Some iifakeend)) lbl "[endswitch]" in

      !g +> add_arc_opt (starti, newswitchi);

       (* call compound case. Need special info to pass to compound case
        * because we need to build a context_info that need some of the
        * information build inside the compound case: the nodei of {
        *)
       let finalthen = 
         match st with
         | Ast_c.Compound statxs, ii -> 
             let statxs = Ast_c.stmt_elems_of_sequencable statxs in
             
             (* todo? we should not allow to match a stmt that corresponds
              * to a compound of a switch, so really SeqStart (stmt, ...)
              * here ? so maybe should change the SeqStart labeling too.
              * So need pass a todo_in_compound2 function.
              *)
             let todo_in_compound newi newxi = 
               let newxi' = { newxi with 
                 ctx = SwitchInfo (newi(*!!*), newendswitch, xi.braces, lbl);
                 ctx_stack = newxi.ctx::newxi.ctx_stack
               }
               in
               !g#add_arc ((newswitchi, newi), Direct); 
               (* new: if have not a default case, then must add an edge 
                * between start to end.
                * todo? except if the case[range] coverthe whole spectrum 
                *)
               if not (statxs +> List.exists (function 
               | (Labeled (Ast_c.Default _), _) -> true
               | _ -> false
               ))
               then begin
                 (* when there is no default, then a valid path is 
                  * from the switchheader to the end. In between we
                  * add a Fallthrough.
                  *)

                 let newafter = !g+>add_node FallThroughNode lbl "[switchfall]"
                 in
                 !g#add_arc ((newafter, newendswitch), Direct);
                 !g#add_arc ((newswitchi, newafter), Direct);
                 (* old:
                    !g#add_arc ((newswitchi, newendswitch), Direct) +> adjust_g;
                 *)
               end;
               newxi'
             in
             let newxi = { xi with compound_caller = 
                 Switch todo_in_compound 
             } 
             in
             aux_statement (None (* no starti *), newxi) st
         | x -> raise Impossible
       in
       !g +> add_arc_opt (finalthen, newendswitch);


       (* what if has only returns inside. We must  try to see if the
        * newendswitch has been used via a 'break;'  or because no 
        * 'default:')
        *)
       let res = 
         (match finalthen with
         | Some finalthen -> 

             let afteri = !g +> add_node AfterNode lbl "[after]" in
             !g#add_arc ((newswitchi, afteri),  Direct);
             !g#add_arc ((afteri, newendswitch), Direct);


             !g#add_arc ((finalthen, newendswitch), Direct);
             Some newendswitch
         | None -> 
             if (!g#predecessors newendswitch)#null
             then begin
                 assert ((!g#successors newendswitch)#null);
                 !g#del_node newendswitch;
                 None
             end
             else begin

               let afteri = !g +> add_node AfterNode lbl "[after]" in
               !g#add_arc ((newswitchi, afteri),  Direct);
               !g#add_arc ((afteri, newendswitch), Direct);


               Some newendswitch
             end
         )
       in
       res
       

  | Labeled (Ast_c.Case  (_, _)), ii
  | Labeled (Ast_c.CaseRange  (_, _, _)), ii -> 

      incr counter_for_switch;
      let switchrank = !counter_for_switch in
      let node, st = 
        match stmt with 
        | Labeled (Ast_c.Case  (e, st)), ii -> 
            (Case (stmt, (e, ii))),  st
        | Labeled (Ast_c.CaseRange  (e, e2, st)), ii -> 
            (CaseRange (stmt, ((e, e2), ii))), st
        | _ -> raise Impossible
      in

      let newi = !g +> add_node node  lbl "case:" in

      (match Common.optionise (fun () -> 
        (* old: xi.ctx *)
        (xi.ctx::xi.ctx_stack) +> Common.find_some (function 
        | SwitchInfo (a, b, c, _) -> Some (a, b, c)
        | _ -> None
        ))
      with
      | Some (startbrace, switchendi, _braces) -> 
          (* no need to attach to previous for the first case, cos would be
           * redundant. *)
          starti +> do_option (fun starti -> 
            if starti <> startbrace
            then !g +> add_arc_opt (Some starti, newi); 
            );

          let s = ("[casenode] " ^ i_to_s switchrank) in
          let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in
          !g#add_arc ((startbrace, newcasenodei), Direct);
          !g#add_arc ((newcasenodei, newi), Direct);
      | None -> raise (Error (CaseNoSwitch (pinfo_of_ii ii)))
      );
      aux_statement (Some newi, xi_lbl) st
      

  | Labeled (Ast_c.Default st), ii -> 
      incr counter_for_switch;
      let switchrank = !counter_for_switch in

      let newi = !g +> add_node (Default(stmt, ((),ii))) lbl "case default:" in
      !g +> add_arc_opt (starti, newi);

      (match xi.ctx with
      | SwitchInfo (startbrace, switchendi, _braces, _parent_lbl) -> 
          let s = ("[casenode] " ^ i_to_s switchrank) in
          let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in
          !g#add_arc ((startbrace, newcasenodei), Direct);
          !g#add_arc ((newcasenodei, newi), Direct);
      | _ -> raise (Error (CaseNoSwitch (pinfo_of_ii ii)))
      );
      aux_statement (Some newi, xi_lbl) st






   (* ------------------------- *)        
  | Iteration  (Ast_c.While (e, st)), ii -> 
     (* starti -> newi ---> newfakethen -> ... -> finalthen -
      *             |---|-----------------------------------|
      *                 |-> newfakelse 
      *)

      let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
      let ii = [i1;i2;i3] in

      let newi = !g +> add_node (WhileHeader (stmt, (e,ii))) lbl "while" in
      !g +> add_arc_opt (starti, newi);
      let newfakethen = !g +> add_node InLoopNode  lbl "[whiletrue]" in
      (* let newfakeelse = !g +> add_node FalseNode lbl "[endwhile]" in *)
      let newafter = !g +> add_node FallThroughNode lbl "[whilefall]" in
      let newfakeelse = 
        !g +> add_node (EndStatement (Some iifakeend)) lbl "[endwhile]" in

      let newxi = { xi_lbl with
         ctx = LoopInfo (newi, newfakeelse,  xi_lbl.braces, lbl);
         ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
        }
      in

      !g#add_arc ((newi, newfakethen), Direct);
      !g#add_arc ((newafter, newfakeelse), Direct);
      !g#add_arc ((newi, newafter), Direct);
      let finalthen = aux_statement (Some newfakethen, newxi) st in
      !g +> add_arc_opt (finalthen, newi);
      Some newfakeelse

      
  (* This time, may return None, for instance if goto in body of dowhile
   * (whereas While cant return None). But if return None, certainly 
   * some deadcode.
   *)
  | Iteration  (Ast_c.DoWhile (st, e)), ii -> 
     (* starti -> doi ---> ... ---> finalthen (opt) ---> whiletaili
      *             |--------- newfakethen ---------------|  |---> newfakelse
      *)
      let is_zero = 
        match Ast_c.unwrap_expr e with
        | Constant (Int "0") -> true
        | _ -> false
      in

      let (iido, iiwhiletail, iifakeend) = 
        match ii with
        | [i1;i2;i3;i4;i5;i6] -> i1, [i2;i3;i4;i5], i6
        | _ -> raise Impossible
      in
      let doi = !g +> add_node (DoHeader (stmt, iido))  lbl "do" in
      !g +> add_arc_opt (starti, doi);
      let taili = !g +> add_node (DoWhileTail (e, iiwhiletail)) lbl "whiletail"
      in
      

      (*let newfakeelse = !g +> add_node FalseNode lbl "[enddowhile]" in *)
      let newafter = !g +> add_node FallThroughNode lbl "[dowhilefall]" in
      let newfakeelse = 
        !g +> add_node (EndStatement (Some iifakeend)) lbl "[enddowhile]" in

      let newxi = { xi_lbl with
         ctx = LoopInfo (taili, newfakeelse, xi_lbl.braces, lbl);
         ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
        }
      in

      if not is_zero
      then begin
        let newfakethen = !g +> add_node InLoopNode lbl "[dowhiletrue]" in
        !g#add_arc ((taili, newfakethen), Direct); 
        !g#add_arc ((newfakethen, doi), Direct); 
      end;

      !g#add_arc ((newafter, newfakeelse), Direct);
      !g#add_arc ((taili, newafter), Direct);


      let finalthen = aux_statement (Some doi, newxi) st in 
      (match finalthen with
      | None -> 
          if (!g#predecessors taili)#null
          then raise (Error (DeadCode (Some (pinfo_of_ii ii))))
          else Some newfakeelse
      | Some finali -> 
          !g#add_arc ((finali, taili), Direct);
          Some newfakeelse
      )
          


  | Iteration  (Ast_c.For (e1opt, e2opt, e3opt, st)), ii -> 
      let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
      let ii = [i1;i2;i3] in

      let newi = 
        !g+>add_node(ForHeader(stmt,((e1opt,e2opt,e3opt),ii))) lbl "for" in
      !g +> add_arc_opt (starti, newi);
      let newfakethen = !g +> add_node InLoopNode  lbl "[fortrue]" in
      (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
      let newafter = !g +> add_node FallThroughNode lbl "[forfall]" in
      let newfakeelse = 
        !g +> add_node (EndStatement (Some iifakeend)) lbl "[endfor]" in

      let newxi = { xi_lbl with
           ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl); 
           ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
        }
      in

      !g#add_arc ((newi, newfakethen), Direct);
      !g#add_arc ((newafter, newfakeelse), Direct);
      !g#add_arc ((newi, newafter), Direct);
      let finalthen = aux_statement (Some newfakethen, newxi) st in
      !g +> add_arc_opt (finalthen, newi);
      Some newfakeelse


  (* to generate less exception with the breakInsideLoop, analyse
   * correctly the loop deguisé comme list_for_each. Add a case ForMacro
   * in ast_c (and in lexer/parser), and then do code that imitates the
   * code for the For. 
   * update: the list_for_each was previously converted into Tif by the 
   * lexer, now they are returned as Twhile so less pbs. But not perfect.
   * update: now I recognize the list_for_each macro so no more problems.
   *)
  | Iteration  (Ast_c.MacroIteration (s, es, st)), ii -> 
      let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
      let ii = [i1;i2;i3] in

      let newi = 
        !g+>add_node(MacroIterHeader(stmt,((s,es),ii))) lbl "foreach" in
      !g +> add_arc_opt (starti, newi);
      let newfakethen = !g +> add_node InLoopNode  lbl "[fortrue]" in
      (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
      let newafter = !g +> add_node FallThroughNode lbl "[foreachfall]" in
      let newfakeelse = 
        !g +> add_node (EndStatement (Some iifakeend)) lbl "[endforeach]" in

      let newxi = { xi_lbl with
           ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl); 
           ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
        }
      in

      !g#add_arc ((newi, newfakethen), Direct);
      !g#add_arc ((newafter, newfakeelse), Direct);
      !g#add_arc ((newi, newafter), Direct);
      let finalthen = aux_statement (Some newfakethen, newxi) st in
      !g +> add_arc_opt (finalthen, newi);
      Some newfakeelse



   (* ------------------------- *)        
  | Jump ((Ast_c.Continue|Ast_c.Break) as x),ii ->  
      let context_info =
        match xi.ctx with
          SwitchInfo (startbrace, loopendi, braces, parent_lbl) -> 
            if x =*= Ast_c.Break
            then xi.ctx
            else
              (try 
                xi.ctx_stack +> Common.find_some (function 
                    LoopInfo (_,_,_,_) as c ->  Some c
                  | _ -> None)
              with Not_found -> 
                raise (Error (OnlyBreakInSwitch (pinfo_of_ii ii))))
        | LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> xi.ctx
        | NoInfo -> raise (Error (NoEnclosingLoop (pinfo_of_ii ii))) in

      let parent_label =
        match context_info with
          LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> parent_lbl
        | SwitchInfo (startbrace, loopendi, braces, parent_lbl) -> parent_lbl
        | NoInfo -> raise Impossible in

      (* flow_to_ast: *)
      let (node_info, string) =
        let parent_string =
          String.concat "," (List.map string_of_int parent_label) in
        (match x with
          | Ast_c.Continue ->
              (Continue (stmt, ((), ii)),
               Printf.sprintf "continue; [%s]" parent_string)
          | Ast_c.Break    ->
              (Break    (stmt, ((), ii)),
               Printf.sprintf "break; [%s]" parent_string)
          | _ -> raise Impossible
          ) in

      (* idea: break or continue records the label of its parent loop or
         switch *)
      let newi = !g +> add_bc_node node_info lbl parent_label string in
      !g +> add_arc_opt (starti, newi);

      (* let newi = some starti in *)

      (match context_info with
      | LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> 
          let desti = 
            (match x with 
            | Ast_c.Break -> loopendi 
            | Ast_c.Continue -> loopstarti 
            | x -> raise Impossible
            ) in
          let difference = List.length xi.braces - List.length braces in
          assert (difference >= 0);
          let toend = take difference xi.braces in
          let newi = insert_all_braces toend newi in
          !g#add_arc ((newi, desti), Direct);
          None

      | SwitchInfo (startbrace, loopendi, braces, parent_lbl) ->
          assert (x =*= Ast_c.Break);
          let difference = List.length xi.braces - List.length braces in
          assert (difference >= 0);
          let toend = take difference xi.braces in
          let newi = insert_all_braces toend newi in
          !g#add_arc ((newi, loopendi), Direct);
          None
      | NoInfo -> raise Impossible
      )

  | Jump ((Ast_c.Return | Ast_c.ReturnExpr _) as kind), ii -> 
     (match xi.exiti, xi.errorexiti with
     | None, None -> raise (Error (NoExit (pinfo_of_ii ii)))
     | Some exiti, Some errorexiti -> 

      (* flow_to_ast: *)
      let s = 
        match kind with
        | Ast_c.Return -> "return"
        | Ast_c.ReturnExpr _ -> "return ..."
        | _ -> raise Impossible
      in
      let newi = 
        !g +> add_node 
          (match kind with
          | Ast_c.Return ->       Return (stmt, ((),ii))
          | Ast_c.ReturnExpr e -> ReturnExpr (stmt, (e, ii))
          | _ -> raise Impossible
          )
          lbl s
      in
      !g +> add_arc_opt (starti, newi);
      let newi = insert_all_braces xi.braces newi in

      if xi.under_ifthen
      then !g#add_arc ((newi, errorexiti), Direct)
      else !g#add_arc ((newi, exiti), Direct)
      ;
      None
     | _ -> raise Impossible
     )


  (* ------------------------- *)        
  | Ast_c.Decl decl, ii -> 
     let s = 
       match decl with
       | (Ast_c.DeclList 
             ([{v_namei = Some (name, _); v_type = typ; v_storage = sto}, _], _)) ->
           "decl:" ^ Ast_c.str_of_name name
       | _ -> "decl_novar_or_multivar"
     in
            
     let newi = !g +> add_node (Decl (decl)) lbl s in
     !g +> add_arc_opt (starti, newi);
     Some newi
      
  (* ------------------------- *)        
  | Ast_c.Asm body, ii -> 
      let newi = !g +> add_node (Asm (stmt, ((body,ii)))) lbl "asm;" in
      !g +> add_arc_opt (starti, newi);
      Some newi

  | Ast_c.MacroStmt, ii -> 
      let newi = !g +> add_node (MacroStmt (stmt, ((),ii))) lbl "macro;" in
      !g +> add_arc_opt (starti, newi);
      Some newi


  (* ------------------------- *)        
  | Ast_c.NestedFunc def, ii -> 
      raise (Error NestedFunc)
      






and aux_statement_list starti (xi, newxi) statxs = 
  statxs 
  +> List.fold_left (fun starti statement_seq ->
    if !Flag_parsing_c.label_strategy_2
    then incr counter_for_labels;
    
    let newxi' = 
      if !Flag_parsing_c.label_strategy_2
      then { newxi with labels = xi.labels @ [ !counter_for_labels ] } 
      else newxi
    in

    match statement_seq with
    | Ast_c.StmtElem statement -> 
        aux_statement (starti, newxi') statement

    | Ast_c.CppDirectiveStmt directive -> 
        pr2_once ("ast_to_flow: filter a directive");
        starti

    | Ast_c.IfdefStmt ifdef -> 
        pr2_once ("ast_to_flow: filter a directive");
        starti

    | Ast_c.IfdefStmt2 (ifdefs, xxs) -> 

        let (head, body, tail) = Common.head_middle_tail ifdefs in

        let newi = !g +> add_node (IfdefHeader (head)) newxi'.labels "[ifdef]" in
        let taili = !g +> add_node (IfdefEndif (tail)) newxi'.labels "[endif]" in
        !g +> add_arc_opt (starti, newi);

        let elsenodes = 
          body +> List.map (fun elseif -> 
            let elsei = 
              !g +> add_node (IfdefElse (elseif)) newxi'.labels "[elseif]" in
            !g#add_arc ((newi, elsei), Direct);
            elsei
          ) in

        let _finalxs = 
          Common.zip (newi::elsenodes) xxs +> List.map (fun (start_nodei, xs)-> 
            let finalthen = 
              aux_statement_list (Some start_nodei) (newxi, newxi) xs in
            !g +> add_arc_opt (finalthen, taili);
          ) 
        in
        Some taili

  ) starti


(*****************************************************************************)
(* Definition of function *)
(*****************************************************************************)

let (aux_definition: nodei -> definition -> unit) = fun topi funcdef ->

  let lbl_start = [!counter_for_labels] in

  let ({f_name = namefuncs; 
        f_type = functype; 
        f_storage= sto; 
        f_body= compound;
        f_attr= attrs;
        f_old_c_style = oldstyle;
        }, ii) = funcdef in
  let iifunheader, iicompound = 
    (match ii with 
    | ioparen::icparen::iobrace::icbrace::iifake::isto -> 
        ioparen::icparen::iifake::isto,     
        [iobrace;icbrace]
    | _ -> raise Impossible
    )
  in

  let topstatement = Ast_c.Compound compound, iicompound in

  let headi = !g +> add_node 
    (FunHeader ({ 
      Ast_c.f_name = namefuncs;
      f_type = functype;
      f_storage = sto;
      f_attr = attrs;
      f_body = [] (* empty body *);
      f_old_c_style = oldstyle;
      }, iifunheader))
    lbl_start ("function " ^ Ast_c.str_of_name namefuncs) in
  let enteri     = !g +> add_node Enter     lbl_0 "[enter]"     in
  let exiti      = !g +> add_node Exit      lbl_0 "[exit]"      in
  let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in

  !g#add_arc ((topi, headi), Direct);
  !g#add_arc ((headi, enteri), Direct);

  (* ---------------------------------------------------------------- *)
  (* todocheck: assert ? such as we have "consommer" tous les labels  *)
  let info = 
    { initial_info with 
      labels = lbl_start;
      labels_assoc = compute_labels_and_create_them topstatement;
      exiti      = Some exiti;
      errorexiti = Some errorexiti;
      compound_caller = FunctionDef;
    } 
  in

  let lasti = aux_statement (Some enteri, info) topstatement in
  !g +> add_arc_opt (lasti, exiti)

(*****************************************************************************)
(* Entry point *)
(*****************************************************************************)

(* Helpers for SpecialDeclMacro. 
 * 
 * could also force the coccier to define
 * the toplevel macro statement as in @@ toplevel_declarator MACRO_PARAM;@@
 * and so I would not need this hack and instead I would to a cleaner
 * match in cocci_vs_c_3.ml of a A.MacroTop vs B.MacroTop
 *)
let specialdeclmacro_to_stmt (s, args, ii) =
  let (iis, iiopar, iicpar, iiptvirg) = tuple_of_list4 ii in
  let ident = Ast_c.RegularName (s, [iis]) in
  let identfinal = (Ast_c.Ident (ident), Ast_c.noType()), [] in
  let f = (Ast_c.FunCall (identfinal, args), Ast_c.noType()), [iiopar;iicpar] in
  let stmt = Ast_c.ExprStatement (Some f), [iiptvirg] in
  stmt,  (f, [iiptvirg])



let ast_to_control_flow e = 

  (* globals (re)initialialisation *) 
  g := (new ograph_mutable);
  counter_for_labels := 1;
  counter_for_braces := 0;
  counter_for_switch := 0;

  let topi = !g +> add_node TopNode lbl_0 "[top]" in

  match e with 
  | Ast_c.Definition ((defbis,_) as def) -> 
      let _funcs = defbis.f_name in
      let _c = defbis.f_body in
      (* if !Flag.show_misc then pr2 ("build info function " ^ funcs); *)
      aux_definition topi def;
      Some !g

  | Ast_c.Declaration _ 
  | Ast_c.CppTop (Ast_c.Include _)
  | Ast_c.MacroTop _
    -> 
      let (elem, str) = 
        match e with 
        | Ast_c.Declaration decl -> 
            (Control_flow_c.Decl decl),  "decl"
        | Ast_c.CppTop (Ast_c.Include inc) -> 
            (Control_flow_c.Include inc), "#include"
        | Ast_c.MacroTop (s, args, ii) -> 
            let (st, (e, ii)) = specialdeclmacro_to_stmt (s, args, ii) in
            (Control_flow_c.ExprStatement (st, (Some e, ii))), "macrotoplevel"
          (*(Control_flow_c.MacroTop (s, args,ii), "macrotoplevel") *)
        | _ -> raise Impossible
      in
      let ei =   !g +> add_node elem    lbl_0 str in
      let endi = !g +> add_node EndNode lbl_0 "[end]" in

      !g#add_arc ((topi, ei),Direct);
      !g#add_arc ((ei, endi),Direct);
      Some !g

  | Ast_c.CppTop (Ast_c.Define ((id,ii), (defkind, defval)))  -> 
      let s = ("#define " ^ id) in
      let headeri = !g+>add_node (DefineHeader ((id, ii), defkind)) lbl_0 s in
      !g#add_arc ((topi, headeri),Direct);

      (match defval with
      | Ast_c.DefineExpr e -> 
          let ei   = !g +> add_node (DefineExpr e) lbl_0 "defexpr" in
          let endi = !g +> add_node EndNode        lbl_0 "[end]" in
          !g#add_arc ((headeri, ei) ,Direct);
          !g#add_arc ((ei, endi) ,Direct);
          
      | Ast_c.DefineType ft -> 
          let ei   = !g +> add_node (DefineType ft) lbl_0 "deftyp" in
          let endi = !g +> add_node EndNode         lbl_0 "[end]" in
          !g#add_arc ((headeri, ei) ,Direct);
          !g#add_arc ((ei, endi) ,Direct);

      | Ast_c.DefineStmt st -> 

          (* can have some return; inside the statement *)
          let exiti      = !g +> add_node Exit      lbl_0 "[exit]"      in
          let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in
          let goto_labels = compute_labels_and_create_them st in

          let info = { initial_info with
            labels_assoc = goto_labels;
            exiti      = Some exiti;
            errorexiti = Some errorexiti;
          } 
          in

          let lasti = aux_statement (Some headeri , info) st in
          lasti +> do_option (fun lasti -> 
            (* todo? if don't have a lasti ? no EndNode ? CTL will work ? *)
            let endi = !g +> add_node EndNode lbl_0 "[end]" in
            !g#add_arc ((lasti, endi), Direct)
          )
          

      | Ast_c.DefineDoWhileZero ((st,_e), ii) -> 
          let headerdoi = 
            !g +> add_node (DefineDoWhileZeroHeader ((),ii)) lbl_0 "do0" in
          !g#add_arc ((headeri, headerdoi), Direct);
          let info = initial_info in
          let lasti = aux_statement (Some headerdoi , info) st in
          lasti +> do_option (fun lasti -> 
            let endi = !g +> add_node EndNode lbl_0 "[end]" in
            !g#add_arc ((lasti, endi), Direct)
          )

      | Ast_c.DefineFunction def -> 
          aux_definition headeri def;

      | Ast_c.DefineText (s, s_ii) -> 
          raise (Error(Define(pinfo_of_ii ii)))
      | Ast_c.DefineEmpty -> 
          let endi = !g +> add_node EndNode lbl_0 "[end]" in
          !g#add_arc ((headeri, endi),Direct);
      | Ast_c.DefineInit _ -> 
          raise (Error(Define(pinfo_of_ii ii)))
      | Ast_c.DefineTodo -> 
          raise (Error(Define(pinfo_of_ii ii)))
      );

      Some !g
      

  | _ -> None


(*****************************************************************************)
(* CFG loop annotation *)
(*****************************************************************************)

let annotate_loop_nodes g =
  let firsti = Control_flow_c.first_node g in

  (* just for opti a little *)
  let already = Hashtbl.create 101 in 

  g +> Ograph_extended.dfs_iter_with_path firsti (fun xi path -> 
    Hashtbl.add already xi true;
    let succ = g#successors xi in
    let succ = succ#tolist in
    succ +> List.iter (fun (yi,_edge) -> 
      if Hashtbl.mem already yi && List.mem yi (xi::path)
      then
        let node = g#nodes#find yi in
        let ((node2, nodeinfo), nodestr) = node in
        let node' = ((node2, {nodeinfo with is_loop = true}), (nodestr ^ "*")) 
        in
        g#replace_node (yi, node');
    );
  );


  g


(*****************************************************************************)
(* CFG checks *)
(*****************************************************************************)

(* the second phase, deadcode detection. Old code was raising DeadCode if
 * lasti = None, but maybe not. In fact if have 2 return in the then
 * and else of an if ? 
 * 
 * alt: but can assert that at least there exist
 * a node to exiti, just check #pred of exiti.
 * 
 * Why so many deadcode in Linux ? Ptet que le label est utilisé 
 * mais dans le corps d'une macro et donc on le voit pas :(
 * 
 *)
let deadcode_detection g = 

  g#nodes#iter (fun (k, node) -> 
    let pred = g#predecessors k in
    if pred#null then 
      (match unwrap node with
      (* old: 
       * | Enter -> ()
       * | EndStatement _ -> pr2 "deadcode sur fake node, pas grave"; 
       *)
      | TopNode -> ()
      | FunHeader _ -> ()
      | ErrorExit -> ()
      | Exit -> ()     (* if have 'loop: if(x) return; i++; goto loop' *)
      | SeqEnd _ -> () (* todo?: certaines '}' deviennent orphelins *)
      | x -> 
          (match Control_flow_c.extract_fullstatement node with
          | Some (st, ii) -> raise (Error (DeadCode (Some (pinfo_of_ii ii))))
          | _ -> pr2 "CFG: orphelin nodes, maybe something weird happened"
          )
      )
  )

(*------------------------------------------------------------------------*)
(* special_cfg_braces: the check are really specific to the way we
 * have build our control_flow, with the { } in the graph so normally
 * all those checks here are useless.
 * 
 * ver1: to better error reporting, to report earlier the message, pass
 * the list of '{' (containing morover a brace_identifier) instead of
 * just the depth. 
 *)

let (check_control_flow: cflow -> unit) = fun g ->

  let nodes = g#nodes  in
  let starti = first_node g in
  let visited = ref (new oassocb []) in

  let print_trace_error xs =  pr2 "PB with flow:";  Common.pr2_gen xs; in

  let rec dfs (nodei, (* Depth depth,*) startbraces,  trace)  = 
    let trace2 = nodei::trace in
    if !visited#haskey nodei 
    then 
      (* if loop back, just check that go back to a state where have same depth
         number *)
      let (*(Depth depth2)*) startbraces2 = !visited#find nodei in
      if  (*(depth = depth2)*) startbraces <> startbraces2
      then  
        begin 
          pr2 (sprintf "PB with flow: the node %d has not same braces count" 
                 nodei);  
          print_trace_error trace2  
        end
    else 
      let children = g#successors nodei in
      let _ = visited := !visited#add (nodei, (* Depth depth*) startbraces) in

      (* old: good, but detect a missing } too late, only at the end
      let newdepth = 
        (match fst (nodes#find nodei) with
        | StartBrace i -> Depth (depth + 1)
        | EndBrace i   -> Depth (depth - 1)
        | _ -> Depth depth
        ) 
      in
      *)
      let newdepth = 
        (match unwrap (nodes#find nodei),  startbraces with
        | SeqStart (_,i,_), xs  -> i::xs
        | SeqEnd (i,_), j::xs -> 
            if i =|= j 
            then xs
            else 
              begin 
                pr2 (sprintf ("PB with flow: not corresponding match between }%d and excpeted }%d at node %d") i j nodei); 
                print_trace_error trace2; 
                xs 
              end
        | SeqEnd (i,_), [] -> 
            pr2 (sprintf "PB with flow: too much } at }%d " i);
            print_trace_error trace2; 
            []
        | _, xs ->  xs
        ) 
      in

   
      if null children#tolist
      then 
        if (* (depth = 0) *) startbraces <> []
        then print_trace_error trace2
      else 
        children#tolist +> List.iter (fun (nodei,_) -> 
          dfs (nodei, newdepth, trace2)
        )
    in

  dfs (starti, (* Depth 0*) [], [])

(*****************************************************************************)
(* Error report *)
(*****************************************************************************)

let report_error error = 
  let error_from_info info = 
    Common.error_message_short info.file ("", info.charpos)
  in
  match error with
  | DeadCode          infoopt -> 
      (match infoopt with
      | None ->   pr2 "FLOW: deadcode detected, but cant trace back the place"
      | Some info -> pr2 ("FLOW: deadcode detected: " ^ error_from_info info)
      )
  | CaseNoSwitch      info -> 
      pr2 ("FLOW: case without corresponding switch: " ^ error_from_info info)
  | OnlyBreakInSwitch info -> 
      pr2 ("FLOW: only break are allowed in switch: " ^ error_from_info info)
  | NoEnclosingLoop   (info) -> 
      pr2 ("FLOW: can't find enclosing loop: " ^ error_from_info info)
  | GotoCantFindLabel (s, info) ->
      pr2 ("FLOW: cant jump to " ^ s ^ ": because we can't find this label")
  | NoExit info -> 
      pr2 ("FLOW: can't find exit or error exit: " ^ error_from_info info)
  | DuplicatedLabel s -> 
      pr2 ("FLOW: duplicate label" ^ s)
  | NestedFunc  -> 
      pr2 ("FLOW: not handling yet nested function")
  | ComputedGoto -> 
      pr2 ("FLOW: not handling computed goto yet")
  | Define info ->
      pr2 ("Unsupported form of #define: " ^ error_from_info info)