parsing_c/ast_to_flow.ml

   1 open Common
   2
   3 open Ast_c
   4 open Control_flow_c
   5
   6 open Ograph_extended
   7 open Oassoc
   8 open Oassocb
   9
  10
  11 (*****************************************************************************)
  12 (* todo?: compute target level with goto (but rare that different I think)
  13  * ver1: just do init,
  14  * ver2: compute depth of label (easy, intercept compound in the visitor)
  15  *
  16  * checktodo: after a switch, need check that all the st in the
  17  * compound start with a case: ?
  18  *
  19  * checktodo: how ensure that when we call aux_statement recursivly, we
  20  * pass it xi_lbl and not just auxinfo ? how enforce that ?
  21  * in fact we must either pass a xi_lbl or a newxi
  22  *
  23  * todo: can have code (and so nodes) in many places, in the size of an
  24  * array, in the init of initializer, but also in StatementExpr, ...
  25  *
  26  * todo?: steal code from CIL ? (but seems complicated ... again) *)
  27 (*****************************************************************************)
  28
  29 (*****************************************************************************)
  30 (* Types *)
  31 (*****************************************************************************)
  32
  33 type error =
  34   | DeadCode          of Common.parse_info option
  35   | CaseNoSwitch      of Common.parse_info
  36   | OnlyBreakInSwitch of Common.parse_info
  37   | NoEnclosingLoop   of Common.parse_info
  38   | GotoCantFindLabel of string * Common.parse_info
  39   | NoExit of Common.parse_info
  40   | DuplicatedLabel of string
  41   | NestedFunc
  42   | ComputedGoto
  43
  44 exception Error of error
  45
  46 (*****************************************************************************)
  47 (* Helpers *)
  48 (*****************************************************************************)
  49
  50 let add_node node labels nodestr g =
  51    g#add_node (Control_flow_c.mk_node node labels [] nodestr)
  52 let add_bc_node node labels parent_labels nodestr g =
  53    g#add_node (Control_flow_c.mk_node node labels parent_labels  nodestr)
  54 let add_arc_opt (starti, nodei) g =
  55   starti +> do_option (fun starti -> g#add_arc ((starti, nodei), Direct))
  56
  57
  58 let lbl_0 = []
  59
  60 let pinfo_of_ii ii = Ast_c.get_opi (List.hd ii).Ast_c.pinfo
  61
  62
  63
  64 (*****************************************************************************)
  65 (* Contextual information passed in aux_statement *)
  66 (*****************************************************************************)
  67
  68 (* Sometimes have a continue/break and we must know where we must jump.
  69  *
  70  * ctl_brace: The node list in context_info record the number of '}' at the
  71  * context point, for instance at the switch point. So that when deeper,
  72  * we can compute the difference between the number of '}' from root to
  73  * the context point to close the good number of '}' . For instance
  74  * where there is a 'continue', we must close only until the for.
  75  *)
  76 type context_info =
  77   | NoInfo
  78   | LoopInfo   of nodei * nodei (* start, end *) * node list * int list
  79   | SwitchInfo of nodei * nodei (* start, end *) * node list * int list
  80
  81 (* for the Compound case I need to do different things depending if
  82  * the compound is the compound of the function definition, the compound of
  83  * a switch, so this type allows to specify this and enable to factorize
  84  * code for the Compound
  85  *)
  86 and compound_caller =
  87   FunctionDef | Statement | Switch of (nodei -> xinfo -> xinfo)
  88
  89 (* other information used internally in ast_to_flow and passed recursively *)
  90 and xinfo =  {
  91
  92   ctx: context_info; (* cf above *)
  93   ctx_stack: context_info list;
  94
  95   (* are we under a ifthen[noelse]. Used for ErrorExit *)
  96   under_ifthen: bool;
  97   compound_caller: compound_caller;
  98
  99   (* does not change recursively. Some kind of globals. *)
 100   labels_assoc: (string, nodei) oassoc;
 101   exiti:      nodei option;
 102   errorexiti: nodei option;
 103
 104   (* ctl_braces: the nodei list is to handle current imbrication depth.
 105    * It contains the must-close '}'.
 106    * update: now it is instead a node list.
 107    *)
 108   braces: node list;
 109
 110   (* ctl: *)
 111   labels: int list;
 112   }
 113
 114
 115 let initial_info = {
 116   ctx = NoInfo;
 117   ctx_stack = [];
 118   under_ifthen = false;
 119   compound_caller = Statement;
 120   braces = [];
 121   labels = [];
 122
 123   (* don't change when recurse *)
 124   labels_assoc = new oassocb [];
 125   exiti = None;
 126   errorexiti = None;
 127 }
 128
 129
 130 (*****************************************************************************)
 131 (* (Semi) Globals, Julia's style. *)
 132 (*****************************************************************************)
 133 (* global graph *)
 134 let g = ref (new ograph_mutable)
 135
 136 let counter_for_labels = ref 0
 137 let counter_for_braces = ref 0
 138
 139 (* For switch we use compteur too (or pass int ref) cos need know order of the
 140  * case if then later want to go from CFG to (original) AST.
 141  * update: obsolete now I think
 142  *)
 143 let counter_for_switch = ref 0
 144
 145
 146 (*****************************************************************************)
 147 (* helpers *)
 148 (*****************************************************************************)
 149
 150 (* alt: do via a todo list, so can do all in one pass (but more complex)
 151  * todo: can also count the depth level and associate it to the node, for
 152  * the ctl_braces:
 153  *)
 154 let compute_labels_and_create_them st =
 155
 156   (* map C label to index number in graph *)
 157   let (h: (string, nodei) oassoc ref) = ref (new oassocb []) in
 158
 159   begin
 160     st +> Visitor_c.vk_statement { Visitor_c.default_visitor_c with
 161       Visitor_c.kstatement = (fun (k, bigf) st ->
 162         match st with
 163         | Labeled (Ast_c.Label (s, _st)),ii ->
 164             (* at this point I put a lbl_0, but later I will put the
 165              * good labels. *)
 166             let newi = !g +> add_node (Label (st,(s,ii))) lbl_0  (s^":") in
 167             begin
 168               (* the C label already exists ? *)
 169               if (!h#haskey s) then raise (Error (DuplicatedLabel s));
 170               h := !h#add (s, newi);
 171               (* not k _st !!! otherwise in lbl1: lbl2: i++; we miss lbl2 *)
 172               k st;
 173             end
 174         | st -> k st
 175       )
 176     };
 177     !h;
 178   end
 179
 180
 181 (* ctl_braces: *)
 182 let insert_all_braces xs starti =
 183   xs  +> List.fold_left (fun acc node ->
 184     (* Have to build a new node (clone), cos cant share it.
 185      * update: This is now done by the caller. The clones are in xs.
 186      *)
 187     let newi = !g#add_node node in
 188     !g#add_arc ((acc, newi), Direct);
 189     newi
 190   ) starti
 191
 192 (*****************************************************************************)
 193 (* Statement *)
 194 (*****************************************************************************)
 195
 196 (* Take in a (optional) start node, return an (optional) end node.
 197  *
 198  * history:
 199  *
 200  * ver1: old code was returning an nodei, but goto has no end, so
 201  * aux_statement should return nodei option.
 202  *
 203  * ver2: old code was taking a nodei, but should also take nodei
 204  * option.
 205  *
 206  * ver3: deadCode detection. What is dead code ? When there is no
 207  * starti to start from ? So make starti an option too ? Si on arrive
 208  * sur un label: au moment d'un deadCode, on peut verifier les
 209  * predecesseurs de ce label, auquel cas si y'en a, ca veut dire
 210  * qu'en fait c'est pas du deadCode et que donc on peut se permettre
 211  * de partir d'un starti à None. Mais si on a xx; goto far:; near:
 212  * yy; zz; far: goto near:. Bon ca doit etre un cas tres tres rare,
 213  * mais a cause de notre parcours, on va rejeter ce programme car au
 214  * moment d'arriver sur near: on n'a pas encore de predecesseurs pour
 215  * ce label. De meme, meme le cas simple ou la derniere instruction
 216  * c'est un return, alors ca va generer un DeadCode :(
 217  *
 218  * So make a first pass where dont launch exn at all. Create nodes,
 219  * if starti is None then dont add arc. Then make a second pass that
 220  * just checks that all nodes (except enter) have predecessors.
 221  * So make starti an option too. So type is now
 222  *
 223  *      nodei option -> statement -> nodei option.
 224  *
 225  * todo?: if the pb is at a fake node, then try first successos that
 226  * is non fake.
 227  *
 228  * ver4: because of special needs of coccinelle, need pass more info, cf
 229  * type additionnal_info defined above.
 230  *
 231  * - to complete (break, continue (and enclosing loop), switch (and
 232  * associated case, casedefault)) we need to pass additionnal info.
 233  * The start/exit when enter in a loop, to know the current 'for'.
 234  *
 235  * - to handle the braces, need again pass additionnal info.
 236  *
 237  * - need pass the labels.
 238  *
 239  * convention: xi for the auxinfo passed recursively
 240  *
 241  *)
 242
 243 let rec (aux_statement: (nodei option * xinfo) -> statement -> nodei option) =
 244  fun (starti, xi) stmt ->
 245
 246   if not !Flag_parsing_c.label_strategy_2
 247   then incr counter_for_labels;
 248
 249   let lbl =
 250     if !Flag_parsing_c.label_strategy_2
 251     then xi.labels
 252     else xi.labels @ [!counter_for_labels]
 253   in
 254
 255   (* Normally the new auxinfo to pass recursively to the next aux_statement.
 256    * But in some cases we add additionnal stuff in which case we don't use
 257    * this 'xi_lbl' but a 'newxi' specially built.
 258    *)
 259   let xi_lbl =
 260     if !Flag_parsing_c.label_strategy_2
 261     then { xi with
 262       compound_caller = Statement;
 263     }
 264     else { xi with
 265       labels = xi.labels @ [ !counter_for_labels ];
 266       compound_caller = Statement;
 267     }
 268   in
 269
 270   (* ------------------------- *)
 271   match stmt with
 272
 273   (*  coupling: the Switch case copy paste parts of the Compound case *)
 274   | Ast_c.Compound statxs, ii ->
 275       (* flow_to_ast: *)
 276       let (i1, i2) = tuple_of_list2 ii in
 277
 278       (* ctl_braces: *)
 279       incr counter_for_braces;
 280       let brace = !counter_for_braces in
 281
 282       let s1 = "{" ^ i_to_s brace in
 283       let s2 = "}" ^ i_to_s brace in
 284
 285       let lbl = match xi.compound_caller with
 286         | FunctionDef -> xi.labels (* share label with function header *)
 287         | Statement -> xi.labels @ [!counter_for_labels]
 288         | Switch _ -> xi.labels
 289       in
 290
 291       let newi = !g +> add_node (SeqStart (stmt, brace, i1)) lbl s1 in
 292       let endnode = mk_node     (SeqEnd (brace, i2))         lbl [] s2 in
 293       let endnode_dup = mk_fake_node (SeqEnd (brace, i2))    lbl [] s2 in
 294 (*
 295       let _endnode_dup =
 296         mk_node (SeqEnd (brace, Ast_c.fakeInfo())) lbl [] s2 in
 297 *)
 298
 299       let newxi = { xi_lbl with braces = endnode_dup:: xi_lbl.braces } in
 300
 301       let newxi = match xi.compound_caller with
 302         | Switch todo_in_compound ->
 303             (* note that side effect in todo_in_compound *)
 304             todo_in_compound newi newxi
 305         | FunctionDef | Statement -> newxi
 306       in
 307
 308       !g +> add_arc_opt (starti, newi);
 309       let starti = Some newi in
 310
 311       aux_statement_list starti (xi, newxi) statxs
 312
 313       (* braces: *)
 314       +> Common.fmap (fun starti ->
 315             (* subtil: not always return a Some.
 316              * Note that if starti is None, alors forcement ca veut dire
 317              * qu'il y'a eu un return (ou goto), et donc forcement les
 318              * braces auront au moins ete crée une fois, et donc flow_to_ast
 319              * marchera.
 320              * Sauf si le goto revient en arriere ? mais dans ce cas
 321              * ca veut dire que le programme boucle. Pour qu'il boucle pas
 322              * il faut forcement au moins un return.
 323              *)
 324             let endi = !g#add_node endnode in
 325             !g#add_arc ((starti, endi), Direct);
 326             endi
 327            )
 328
 329
 330    (* ------------------------- *)
 331   | Labeled (Ast_c.Label (s, st)), ii ->
 332       let ilabel = xi.labels_assoc#find s in
 333       let node = mk_node (unwrap (!g#nodes#find ilabel)) lbl [] (s ^ ":") in
 334       !g#replace_node (ilabel, node);
 335       !g +> add_arc_opt (starti, ilabel);
 336       aux_statement (Some ilabel, xi_lbl) st
 337
 338
 339   | Jump (Ast_c.Goto s), ii ->
 340      (* special_cfg_ast: *)
 341      let newi = !g +> add_node (Goto (stmt, (s,ii))) lbl ("goto " ^ s ^ ":") in
 342      !g +> add_arc_opt (starti, newi);
 343
 344      let ilabel =
 345        try xi.labels_assoc#find s
 346        with Not_found ->
 347          (* jump vers ErrorExit a la place ?
 348           * pourquoi tant de "cant jump" ? pas detecté par gcc ?
 349           *)
 350          raise (Error (GotoCantFindLabel (s, pinfo_of_ii ii)))
 351      in
 352      (* !g +> add_arc_opt (starti, ilabel);
 353       * todo: special_case: suppose that always goto to toplevel of function,
 354       * hence the Common.init
 355       * todo?: can perhaps report when a goto is not a classic error_goto ?
 356       * that is when it does not jump to the toplevel of the function.
 357       *)
 358      let newi = insert_all_braces (Common.list_init xi.braces) newi in
 359      !g#add_arc ((newi, ilabel), Direct);
 360      None
 361
 362   | Jump (Ast_c.GotoComputed e), ii ->
 363       raise (Error (ComputedGoto))
 364
 365    (* ------------------------- *)
 366   | Ast_c.ExprStatement opte, ii ->
 367       (* flow_to_ast:   old: when opte = None, then do not add in CFG. *)
 368       let s =
 369         match opte with
 370         | None -> "empty;"
 371         | Some e ->
 372             let ((unwrap_e, typ), ii) = e in
 373             (match unwrap_e with
 374             | FunCall (((Ident f, _typ), _ii), _args) ->
 375                 f ^ "(...)"
 376             | Assignment (((Ident var, _typ), _ii), SimpleAssign, e) ->
 377                 var ^ " = ... ;"
 378             | Assignment
 379                 (((RecordAccess (((Ident var, _typ), _ii), field), _typ2),
 380                   _ii2),
 381                  SimpleAssign,
 382                  e) ->
 383                    var ^ "." ^ field ^ " = ... ;"
 384
 385             | _ -> "statement"
 386         )
 387       in
 388       let newi = !g +> add_node (ExprStatement (stmt, (opte, ii))) lbl s in
 389       !g +> add_arc_opt (starti, newi);
 390       Some newi
 391
 392
 393    (* ------------------------- *)
 394   | Selection  (Ast_c.If (e, st1, (Ast_c.ExprStatement (None), []))), ii ->
 395       (* sometome can have ExprStatement None but it is a if-then-else,
 396        * because something like   if() xx else ;
 397        * so must force to have [] in the ii associated with ExprStatement
 398        *)
 399
 400       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 401       let ii = [i1;i2;i3] in
 402      (* starti -> newi --->   newfakethen -> ... -> finalthen --> lasti
 403       *                  |                                      |
 404       *                  |->   newfakeelse -> ... -> finalelse -|
 405       * update: there is now also a link directly to lasti.
 406       *
 407       * because of CTL, now do different things if we are in a ifthen or
 408       * ifthenelse.
 409       *)
 410       let newi = !g +> add_node (IfHeader (stmt, (e, ii))) lbl ("if") in
 411       !g +> add_arc_opt (starti, newi);
 412       let newfakethen = !g +> add_node TrueNode        lbl "[then]" in
 413       let newfakeelse = !g +> add_node FallThroughNode lbl "[fallthrough]" in
 414       let afteri = !g +> add_node AfterNode lbl "[after]" in
 415       let lasti  = !g +> add_node (EndStatement (Some iifakeend)) lbl "[endif]"
 416       in
 417
 418       (* for ErrorExit heuristic *)
 419       let newxi = { xi_lbl with  under_ifthen = true; } in
 420
 421       !g#add_arc ((newi, newfakethen), Direct);
 422       !g#add_arc ((newi, newfakeelse), Direct);
 423       !g#add_arc ((newi, afteri), Direct);
 424       !g#add_arc ((afteri, lasti), Direct);
 425       !g#add_arc ((newfakeelse, lasti), Direct);
 426
 427       let finalthen = aux_statement (Some newfakethen, newxi) st1 in
 428       !g +> add_arc_opt (finalthen, lasti);
 429       Some lasti
 430
 431
 432   | Selection  (Ast_c.If (e, st1, st2)), ii ->
 433      (* starti -> newi --->   newfakethen -> ... -> finalthen --> lasti
 434       *                 |                                      |
 435       *                 |->   newfakeelse -> ... -> finalelse -|
 436       * update: there is now also a link directly to lasti.
 437       *)
 438       let (iiheader, iielse, iifakeend) =
 439         match ii with
 440         | [i1;i2;i3;i4;i5] -> [i1;i2;i3], i4, i5
 441         | _ -> raise Impossible
 442       in
 443       let newi = !g +> add_node (IfHeader (stmt, (e, iiheader))) lbl "if" in
 444       !g +> add_arc_opt (starti, newi);
 445       let newfakethen = !g +> add_node TrueNode  lbl "[then]" in
 446       let newfakeelse = !g +> add_node FalseNode lbl "[else]" in
 447       let elsenode = !g +> add_node (Else iielse) lbl "else" in
 448
 449
 450       !g#add_arc ((newi, newfakethen), Direct);
 451       !g#add_arc ((newi, newfakeelse), Direct);
 452
 453       !g#add_arc ((newfakeelse, elsenode), Direct);
 454
 455       let finalthen = aux_statement (Some newfakethen, xi_lbl) st1 in
 456       let finalelse = aux_statement (Some elsenode, xi_lbl) st2 in
 457
 458       (match finalthen, finalelse with
 459         | (None, None) -> None
 460         | _ ->
 461             let lasti =
 462               !g +> add_node (EndStatement(Some iifakeend)) lbl "[endif]" in
 463             let afteri =
 464               !g +> add_node AfterNode lbl "[after]" in
 465             !g#add_arc ((newi, afteri),  Direct);
 466             !g#add_arc ((afteri, lasti), Direct);
 467             begin
 468               !g +> add_arc_opt (finalthen, lasti);
 469               !g +> add_arc_opt (finalelse, lasti);
 470               Some lasti
 471            end)
 472
 473
 474    (* ------------------------- *)
 475   | Selection  (Ast_c.Switch (e, st)), ii ->
 476       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 477       let ii = [i1;i2;i3] in
 478
 479       (* The newswitchi is for the labels to know where to attach.
 480        * The newendswitch (endi) is for the 'break'. *)
 481       let newswitchi=
 482         !g+> add_node (SwitchHeader(stmt,(e,ii))) lbl "switch" in
 483       let newendswitch =
 484         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endswitch]" in
 485
 486       !g +> add_arc_opt (starti, newswitchi);
 487
 488        (* call compound case. Need special info to pass to compound case
 489         * because we need to build a context_info that need some of the
 490         * information build inside the compound case: the nodei of {
 491         *)
 492        let finalthen =
 493          match st with
 494          | Ast_c.Compound statxs, ii ->
 495              let statxs = Ast_c.stmt_elems_of_sequencable statxs in
 496
 497              (* todo? we should not allow to match a stmt that corresponds
 498               * to a compound of a switch, so really SeqStart (stmt, ...)
 499               * here ? so maybe should change the SeqStart labeling too.
 500               * So need pass a todo_in_compound2 function.
 501               *)
 502              let todo_in_compound newi newxi =
 503                let newxi' = { newxi with
 504                  ctx = SwitchInfo (newi(*!!*), newendswitch, xi.braces, lbl);
 505                  ctx_stack = newxi.ctx::newxi.ctx_stack
 506                }
 507                in
 508                !g#add_arc ((newswitchi, newi), Direct);
 509                (* new: if have not a default case, then must add an edge
 510                 * between start to end.
 511                 * todo? except if the case[range] coverthe whole spectrum
 512                 *)
 513                if not (statxs +> List.exists (function
 514                | (Labeled (Ast_c.Default _), _) -> true
 515                | _ -> false
 516                ))
 517                then begin
 518                  (* when there is no default, then a valid path is
 519                   * from the switchheader to the end. In between we
 520                   * add a Fallthrough.
 521                   *)
 522
 523                  let newafter = !g+>add_node FallThroughNode lbl "[switchfall]"
 524                  in
 525                  !g#add_arc ((newafter, newendswitch), Direct);
 526                  !g#add_arc ((newswitchi, newafter), Direct);
 527                  (* old:
 528                     !g#add_arc ((newswitchi, newendswitch), Direct) +> adjust_g;
 529                  *)
 530                end;
 531                newxi'
 532              in
 533              let newxi = { xi with compound_caller =
 534                  Switch todo_in_compound
 535              }
 536              in
 537              aux_statement (None (* no starti *), newxi) st
 538          | x -> raise Impossible
 539        in
 540        !g +> add_arc_opt (finalthen, newendswitch);
 541
 542
 543        (* what if has only returns inside. We must  try to see if the
 544         * newendswitch has been used via a 'break;'  or because no
 545         * 'default:')
 546         *)
 547        let res =
 548          (match finalthen with
 549          | Some finalthen ->
 550
 551              let afteri = !g +> add_node AfterNode lbl "[after]" in
 552              !g#add_arc ((newswitchi, afteri),  Direct);
 553              !g#add_arc ((afteri, newendswitch), Direct);
 554
 555
 556              !g#add_arc ((finalthen, newendswitch), Direct);
 557              Some newendswitch
 558          | None ->
 559              if (!g#predecessors newendswitch)#null
 560              then begin
 561                  assert ((!g#successors newendswitch)#null);
 562                  !g#del_node newendswitch;
 563                  None
 564              end
 565              else begin
 566
 567                let afteri = !g +> add_node AfterNode lbl "[after]" in
 568                !g#add_arc ((newswitchi, afteri),  Direct);
 569                !g#add_arc ((afteri, newendswitch), Direct);
 570
 571
 572                Some newendswitch
 573              end
 574          )
 575        in
 576        res
 577
 578
 579   | Labeled (Ast_c.Case  (_, _)), ii
 580   | Labeled (Ast_c.CaseRange  (_, _, _)), ii ->
 581
 582       incr counter_for_switch;
 583       let switchrank = !counter_for_switch in
 584       let node, st =
 585         match stmt with
 586         | Labeled (Ast_c.Case  (e, st)), ii ->
 587             (Case (stmt, (e, ii))),  st
 588         | Labeled (Ast_c.CaseRange  (e, e2, st)), ii ->
 589             (CaseRange (stmt, ((e, e2), ii))), st
 590         | _ -> raise Impossible
 591       in
 592
 593       let newi = !g +> add_node node  lbl "case:" in
 594
 595       (match Common.optionise (fun () ->
 596         (* old: xi.ctx *)
 597         (xi.ctx::xi.ctx_stack) +> Common.find_some (function
 598         | SwitchInfo (a, b, c, _) -> Some (a, b, c)
 599         | _ -> None
 600         ))
 601       with
 602       | Some (startbrace, switchendi, _braces) ->
 603           (* no need to attach to previous for the first case, cos would be
 604            * redundant. *)
 605           starti +> do_option (fun starti ->
 606             if starti <> startbrace
 607             then !g +> add_arc_opt (Some starti, newi);
 608             );
 609
 610           let s = ("[casenode] " ^ i_to_s switchrank) in
 611           let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in
 612           !g#add_arc ((startbrace, newcasenodei), Direct);
 613           !g#add_arc ((newcasenodei, newi), Direct);
 614       | None -> raise (Error (CaseNoSwitch (pinfo_of_ii ii)))
 615       );
 616       aux_statement (Some newi, xi_lbl) st
 617
 618
 619   | Labeled (Ast_c.Default st), ii ->
 620       incr counter_for_switch;
 621       let switchrank = !counter_for_switch in
 622
 623       let newi = !g +> add_node (Default(stmt, ((),ii))) lbl "case default:" in
 624       !g +> add_arc_opt (starti, newi);
 625
 626       (match xi.ctx with
 627       | SwitchInfo (startbrace, switchendi, _braces, _parent_lbl) ->
 628           let s = ("[casenode] " ^ i_to_s switchrank) in
 629           let newcasenodei = !g +> add_node (CaseNode switchrank) lbl s in
 630           !g#add_arc ((startbrace, newcasenodei), Direct);
 631           !g#add_arc ((newcasenodei, newi), Direct);
 632       | _ -> raise (Error (CaseNoSwitch (pinfo_of_ii ii)))
 633       );
 634       aux_statement (Some newi, xi_lbl) st
 635
 636
 637
 638
 639
 640
 641    (* ------------------------- *)
 642   | Iteration  (Ast_c.While (e, st)), ii ->
 643      (* starti -> newi ---> newfakethen -> ... -> finalthen -
 644       *             |---|-----------------------------------|
 645       *                 |-> newfakelse
 646       *)
 647
 648       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 649       let ii = [i1;i2;i3] in
 650
 651       let newi = !g +> add_node (WhileHeader (stmt, (e,ii))) lbl "while" in
 652       !g +> add_arc_opt (starti, newi);
 653       let newfakethen = !g +> add_node InLoopNode  lbl "[whiletrue]" in
 654       (* let newfakeelse = !g +> add_node FalseNode lbl "[endwhile]" in *)
 655       let newafter = !g +> add_node FallThroughNode lbl "[whilefall]" in
 656       let newfakeelse =
 657         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endwhile]" in
 658
 659       let newxi = { xi_lbl with
 660          ctx = LoopInfo (newi, newfakeelse,  xi_lbl.braces, lbl);
 661          ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 662         }
 663       in
 664
 665       !g#add_arc ((newi, newfakethen), Direct);
 666       !g#add_arc ((newafter, newfakeelse), Direct);
 667       !g#add_arc ((newi, newafter), Direct);
 668       let finalthen = aux_statement (Some newfakethen, newxi) st in
 669       !g +> add_arc_opt (finalthen, newi);
 670       Some newfakeelse
 671
 672
 673   (* This time, may return None, for instance if goto in body of dowhile
 674    * (whereas While cant return None). But if return None, certainly
 675    * some deadcode.
 676    *)
 677   | Iteration  (Ast_c.DoWhile (st, e)), ii ->
 678      (* starti -> doi ---> ... ---> finalthen (opt) ---> whiletaili
 679       *             |--------- newfakethen ---------------|  |---> newfakelse
 680       *)
 681       let is_zero =
 682         match Ast_c.unwrap_expr e with
 683         | Constant (Int "0") -> true
 684         | _ -> false
 685       in
 686
 687       let (iido, iiwhiletail, iifakeend) =
 688         match ii with
 689         | [i1;i2;i3;i4;i5;i6] -> i1, [i2;i3;i4;i5], i6
 690         | _ -> raise Impossible
 691       in
 692       let doi = !g +> add_node (DoHeader (stmt, iido))  lbl "do" in
 693       !g +> add_arc_opt (starti, doi);
 694       let taili = !g +> add_node (DoWhileTail (e, iiwhiletail)) lbl "whiletail"
 695       in
 696
 697
 698       (*let newfakeelse = !g +> add_node FalseNode lbl "[enddowhile]" in *)
 699       let newafter = !g +> add_node FallThroughNode lbl "[dowhilefall]" in
 700       let newfakeelse =
 701         !g +> add_node (EndStatement (Some iifakeend)) lbl "[enddowhile]" in
 702
 703       let newxi = { xi_lbl with
 704          ctx = LoopInfo (taili, newfakeelse, xi_lbl.braces, lbl);
 705          ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 706         }
 707       in
 708
 709       if not is_zero
 710       then begin
 711         let newfakethen = !g +> add_node InLoopNode lbl "[dowhiletrue]" in
 712         !g#add_arc ((taili, newfakethen), Direct);
 713         !g#add_arc ((newfakethen, doi), Direct);
 714       end;
 715
 716       !g#add_arc ((newafter, newfakeelse), Direct);
 717       !g#add_arc ((taili, newafter), Direct);
 718
 719
 720       let finalthen = aux_statement (Some doi, newxi) st in
 721       (match finalthen with
 722       | None ->
 723           if (!g#predecessors taili)#null
 724           then raise (Error (DeadCode (Some (pinfo_of_ii ii))))
 725           else Some newfakeelse
 726       | Some finali ->
 727           !g#add_arc ((finali, taili), Direct);
 728           Some newfakeelse
 729       )
 730
 731
 732
 733   | Iteration  (Ast_c.For (e1opt, e2opt, e3opt, st)), ii ->
 734       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 735       let ii = [i1;i2;i3] in
 736
 737       let newi =
 738         !g+>add_node(ForHeader(stmt,((e1opt,e2opt,e3opt),ii))) lbl "for" in
 739       !g +> add_arc_opt (starti, newi);
 740       let newfakethen = !g +> add_node InLoopNode  lbl "[fortrue]" in
 741       (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
 742       let newafter = !g +> add_node FallThroughNode lbl "[forfall]" in
 743       let newfakeelse =
 744         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endfor]" in
 745
 746       let newxi = { xi_lbl with
 747            ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl);
 748            ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 749         }
 750       in
 751
 752       !g#add_arc ((newi, newfakethen), Direct);
 753       !g#add_arc ((newafter, newfakeelse), Direct);
 754       !g#add_arc ((newi, newafter), Direct);
 755       let finalthen = aux_statement (Some newfakethen, newxi) st in
 756       !g +> add_arc_opt (finalthen, newi);
 757       Some newfakeelse
 758
 759
 760   (* to generate less exception with the breakInsideLoop, analyse
 761    * correctly the loop deguisé comme list_for_each. Add a case ForMacro
 762    * in ast_c (and in lexer/parser), and then do code that imitates the
 763    * code for the For.
 764    * update: the list_for_each was previously converted into Tif by the
 765    * lexer, now they are returned as Twhile so less pbs. But not perfect.
 766    * update: now I recognize the list_for_each macro so no more problems.
 767    *)
 768   | Iteration  (Ast_c.MacroIteration (s, es, st)), ii ->
 769       let (i1,i2,i3, iifakeend) = tuple_of_list4 ii in
 770       let ii = [i1;i2;i3] in
 771
 772       let newi =
 773         !g+>add_node(MacroIterHeader(stmt,((s,es),ii))) lbl "foreach" in
 774       !g +> add_arc_opt (starti, newi);
 775       let newfakethen = !g +> add_node InLoopNode  lbl "[fortrue]" in
 776       (*let newfakeelse = !g +> add_node FalseNode lbl "[endfor]" in*)
 777       let newafter = !g +> add_node FallThroughNode lbl "[foreachfall]" in
 778       let newfakeelse =
 779         !g +> add_node (EndStatement (Some iifakeend)) lbl "[endforeach]" in
 780
 781       let newxi = { xi_lbl with
 782            ctx = LoopInfo (newi, newfakeelse, xi_lbl.braces, lbl);
 783            ctx_stack = xi_lbl.ctx::xi_lbl.ctx_stack
 784         }
 785       in
 786
 787       !g#add_arc ((newi, newfakethen), Direct);
 788       !g#add_arc ((newafter, newfakeelse), Direct);
 789       !g#add_arc ((newi, newafter), Direct);
 790       let finalthen = aux_statement (Some newfakethen, newxi) st in
 791       !g +> add_arc_opt (finalthen, newi);
 792       Some newfakeelse
 793
 794
 795
 796    (* ------------------------- *)
 797   | Jump ((Ast_c.Continue|Ast_c.Break) as x),ii ->
 798       let context_info =
 799         match xi.ctx with
 800           SwitchInfo (startbrace, loopendi, braces, parent_lbl) ->
 801             if x = Ast_c.Break
 802             then xi.ctx
 803             else
 804               (try
 805                 xi.ctx_stack +> Common.find_some (function
 806                     LoopInfo (_,_,_,_) as c ->  Some c
 807                   | _ -> None)
 808               with Not_found ->
 809                 raise (Error (OnlyBreakInSwitch (pinfo_of_ii ii))))
 810         | LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> xi.ctx
 811         | NoInfo -> raise (Error (NoEnclosingLoop (pinfo_of_ii ii))) in
 812
 813       let parent_label =
 814         match context_info with
 815           LoopInfo (loopstarti, loopendi, braces, parent_lbl) -> parent_lbl
 816         | SwitchInfo (startbrace, loopendi, braces, parent_lbl) -> parent_lbl
 817         | NoInfo -> raise Impossible in
 818
 819       (* flow_to_ast: *)
 820       let (node_info, string) =
 821         let parent_string =
 822           String.concat "," (List.map string_of_int parent_label) in
 823         (match x with
 824           | Ast_c.Continue ->
 825               (Continue (stmt, ((), ii)),
 826                Printf.sprintf "continue; [%s]" parent_string)
 827           | Ast_c.Break    ->
 828               (Break    (stmt, ((), ii)),
 829                Printf.sprintf "break; [%s]" parent_string)
 830           | _ -> raise Impossible
 831           ) in
 832
 833       (* idea: break or continue records the label of its parent loop or
 834          switch *)
 835       let newi = !g +> add_bc_node node_info lbl parent_label string in
 836       !g +> add_arc_opt (starti, newi);
 837
 838       (* let newi = some starti in *)
 839
 840       (match context_info with
 841       | LoopInfo (loopstarti, loopendi, braces, parent_lbl) ->
 842           let desti =
 843             (match x with
 844             | Ast_c.Break -> loopendi
 845             | Ast_c.Continue -> loopstarti
 846             | x -> raise Impossible
 847             ) in
 848           let difference = List.length xi.braces - List.length braces in
 849           assert (difference >= 0);
 850           let toend = take difference xi.braces in
 851           let newi = insert_all_braces toend newi in
 852           !g#add_arc ((newi, desti), Direct);
 853           None
 854
 855       | SwitchInfo (startbrace, loopendi, braces, parent_lbl) ->
 856           assert (x = Ast_c.Break);
 857           let difference = List.length xi.braces - List.length braces in
 858           assert (difference >= 0);
 859           let toend = take difference xi.braces in
 860           let newi = insert_all_braces toend newi in
 861           !g#add_arc ((newi, loopendi), Direct);
 862           None
 863       | NoInfo -> raise Impossible
 864       )
 865
 866   | Jump ((Ast_c.Return | Ast_c.ReturnExpr _) as kind), ii ->
 867      (match xi.exiti, xi.errorexiti with
 868      | None, None -> raise (Error (NoExit (pinfo_of_ii ii)))
 869      | Some exiti, Some errorexiti ->
 870
 871       (* flow_to_ast: *)
 872       let s =
 873         match kind with
 874         | Ast_c.Return -> "return"
 875         | Ast_c.ReturnExpr _ -> "return ..."
 876         | _ -> raise Impossible
 877       in
 878       let newi =
 879         !g +> add_node
 880           (match kind with
 881           | Ast_c.Return ->       Return (stmt, ((),ii))
 882           | Ast_c.ReturnExpr e -> ReturnExpr (stmt, (e, ii))
 883           | _ -> raise Impossible
 884           )
 885           lbl s
 886       in
 887       !g +> add_arc_opt (starti, newi);
 888       let newi = insert_all_braces xi.braces newi in
 889
 890       if xi.under_ifthen
 891       then !g#add_arc ((newi, errorexiti), Direct)
 892       else !g#add_arc ((newi, exiti), Direct)
 893       ;
 894       None
 895      | _ -> raise Impossible
 896      )
 897
 898
 899   (* ------------------------- *)
 900   | Ast_c.Decl decl, ii ->
 901      let s =
 902        match decl with
 903        | (Ast_c.DeclList
 904              ([{v_namei = Some ((s, _),_); v_type = typ; v_storage = sto}, _], _)) ->
 905            "decl:" ^ s
 906        | _ -> "decl_novar_or_multivar"
 907      in
 908
 909      let newi = !g +> add_node (Decl (decl)) lbl s in
 910      !g +> add_arc_opt (starti, newi);
 911      Some newi
 912
 913   (* ------------------------- *)
 914   | Ast_c.Asm body, ii ->
 915       let newi = !g +> add_node (Asm (stmt, ((body,ii)))) lbl "asm;" in
 916       !g +> add_arc_opt (starti, newi);
 917       Some newi
 918
 919   | Ast_c.MacroStmt, ii ->
 920       let newi = !g +> add_node (MacroStmt (stmt, ((),ii))) lbl "macro;" in
 921       !g +> add_arc_opt (starti, newi);
 922       Some newi
 923
 924
 925   (* ------------------------- *)
 926   | Ast_c.NestedFunc def, ii ->
 927       raise (Error NestedFunc)
 928
 929
 930
 931
 932
 933
 934
 935 and aux_statement_list starti (xi, newxi) statxs =
 936   statxs
 937   +> List.fold_left (fun starti statement_seq ->
 938     if !Flag_parsing_c.label_strategy_2
 939     then incr counter_for_labels;
 940
 941     let newxi' =
 942       if !Flag_parsing_c.label_strategy_2
 943       then { newxi with labels = xi.labels @ [ !counter_for_labels ] }
 944       else newxi
 945     in
 946
 947     match statement_seq with
 948     | Ast_c.StmtElem statement ->
 949         aux_statement (starti, newxi') statement
 950
 951     | Ast_c.CppDirectiveStmt directive ->
 952         pr2_once ("ast_to_flow: filter a directive");
 953         starti
 954
 955     | Ast_c.IfdefStmt ifdef ->
 956         pr2_once ("ast_to_flow: filter a directive");
 957         starti
 958
 959     | Ast_c.IfdefStmt2 (ifdefs, xxs) ->
 960
 961         let (head, body, tail) = Common.head_middle_tail ifdefs in
 962
 963         let newi = !g +> add_node (IfdefHeader (head)) newxi'.labels "[ifdef]" in
 964         let taili = !g +> add_node (IfdefEndif (tail)) newxi'.labels "[endif]" in
 965         !g +> add_arc_opt (starti, newi);
 966
 967         let elsenodes =
 968           body +> List.map (fun elseif ->
 969             let elsei =
 970               !g +> add_node (IfdefElse (elseif)) newxi'.labels "[elseif]" in
 971             !g#add_arc ((newi, elsei), Direct);
 972             elsei
 973           ) in
 974
 975         let finalxs =
 976           Common.zip (newi::elsenodes) xxs +> List.map (fun (start_nodei, xs)->
 977             let finalthen =
 978               aux_statement_list (Some start_nodei) (newxi, newxi) xs in
 979             !g +> add_arc_opt (finalthen, taili);
 980           )
 981         in
 982         Some taili
 983
 984   ) starti
 985
 986
 987 (*****************************************************************************)
 988 (* Definition of function *)
 989 (*****************************************************************************)
 990
 991 let (aux_definition: nodei -> definition -> unit) = fun topi funcdef ->
 992
 993   let lbl_start = [!counter_for_labels] in
 994
 995   let ({f_name = funcs;
 996         f_type = functype;
 997         f_storage= sto;
 998         f_body= compound;
 999         f_attr= attrs;
1000         }, ii) = funcdef in
1001   let iifunheader, iicompound =
1002     (match ii with
1003     | is::ioparen::icparen::iobrace::icbrace::iifake::isto ->
1004         is::ioparen::icparen::iifake::isto,
1005         [iobrace;icbrace]
1006     | _ -> raise Impossible
1007     )
1008   in
1009
1010   let topstatement = Ast_c.Compound compound, iicompound in
1011
1012   let headi = !g +> add_node
1013     (FunHeader ({
1014       Ast_c.f_name = funcs;
1015       f_type = functype;
1016       f_storage = sto;
1017       f_attr = attrs;
1018       f_body = [] (* empty body *)
1019       }, iifunheader))
1020     lbl_start ("function " ^ funcs) in
1021   let enteri     = !g +> add_node Enter     lbl_0 "[enter]"     in
1022   let exiti      = !g +> add_node Exit      lbl_0 "[exit]"      in
1023   let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in
1024
1025   !g#add_arc ((topi, headi), Direct);
1026   !g#add_arc ((headi, enteri), Direct);
1027
1028   (* ---------------------------------------------------------------- *)
1029   (* todocheck: assert ? such as we have "consommer" tous les labels  *)
1030   let info =
1031     { initial_info with
1032       labels = lbl_start;
1033       labels_assoc = compute_labels_and_create_them topstatement;
1034       exiti      = Some exiti;
1035       errorexiti = Some errorexiti;
1036       compound_caller = FunctionDef;
1037     }
1038   in
1039
1040   let lasti = aux_statement (Some enteri, info) topstatement in
1041   !g +> add_arc_opt (lasti, exiti)
1042
1043 (*****************************************************************************)
1044 (* Entry point *)
1045 (*****************************************************************************)
1046
1047 (* Helpers for SpecialDeclMacro.
1048  *
1049  * could also force the coccier to define
1050  * the toplevel macro statement as in @@ toplevel_declarator MACRO_PARAM;@@
1051  * and so I would not need this hack and instead I would to a cleaner
1052  * match in cocci_vs_c_3.ml of a A.MacroTop vs B.MacroTop
1053  *)
1054 let specialdeclmacro_to_stmt (s, args, ii) =
1055   let (iis, iiopar, iicpar, iiptvirg) = tuple_of_list4 ii in
1056   let ident = (Ast_c.Ident s, Ast_c.noType()), [iis] in
1057   let f = (Ast_c.FunCall (ident, args), Ast_c.noType()), [iiopar;iicpar] in
1058   let stmt = Ast_c.ExprStatement (Some f), [iiptvirg] in
1059   stmt,  (f, [iiptvirg])
1060
1061
1062
1063 let ast_to_control_flow e =
1064
1065   (* globals (re)initialialisation *)
1066   g := (new ograph_mutable);
1067   counter_for_labels := 1;
1068   counter_for_braces := 0;
1069   counter_for_switch := 0;
1070
1071   let topi = !g +> add_node TopNode lbl_0 "[top]" in
1072
1073   match e with
1074   | Ast_c.Definition ((defbis,_) as def) ->
1075       let _funcs = defbis.f_name in
1076       let _c = defbis.f_body in
1077       (* if !Flag.show_misc then pr2 ("build info function " ^ funcs); *)
1078       aux_definition topi def;
1079       Some !g
1080
1081   | Ast_c.Declaration _
1082   | Ast_c.CppTop (Ast_c.Include _)
1083   | Ast_c.MacroTop _
1084     ->
1085       let (elem, str) =
1086         match e with
1087         | Ast_c.Declaration decl ->
1088             (Control_flow_c.Decl decl),  "decl"
1089         | Ast_c.CppTop (Ast_c.Include inc) ->
1090             (Control_flow_c.Include inc), "#include"
1091         | Ast_c.MacroTop (s, args, ii) ->
1092             let (st, (e, ii)) = specialdeclmacro_to_stmt (s, args, ii) in
1093             (Control_flow_c.ExprStatement (st, (Some e, ii))), "macrotoplevel"
1094           (*(Control_flow_c.MacroTop (s, args,ii), "macrotoplevel") *)
1095         | _ -> raise Impossible
1096       in
1097       let ei =   !g +> add_node elem    lbl_0 str in
1098       let endi = !g +> add_node EndNode lbl_0 "[end]" in
1099
1100       !g#add_arc ((topi, ei),Direct);
1101       !g#add_arc ((ei, endi),Direct);
1102       Some !g
1103
1104   | Ast_c.CppTop (Ast_c.Define ((id,ii), (defkind, defval)))  ->
1105       let s = ("#define " ^ id) in
1106       let headeri = !g+>add_node (DefineHeader ((id, ii), defkind)) lbl_0 s in
1107       !g#add_arc ((topi, headeri),Direct);
1108
1109       (match defval with
1110       | Ast_c.DefineExpr e ->
1111           let ei   = !g +> add_node (DefineExpr e) lbl_0 "defexpr" in
1112           let endi = !g +> add_node EndNode        lbl_0 "[end]" in
1113           !g#add_arc ((headeri, ei) ,Direct);
1114           !g#add_arc ((ei, endi) ,Direct);
1115
1116       | Ast_c.DefineType ft ->
1117           let ei   = !g +> add_node (DefineType ft) lbl_0 "deftyp" in
1118           let endi = !g +> add_node EndNode         lbl_0 "[end]" in
1119           !g#add_arc ((headeri, ei) ,Direct);
1120           !g#add_arc ((ei, endi) ,Direct);
1121
1122       | Ast_c.DefineStmt st ->
1123
1124           (* can have some return; inside the statement *)
1125           let exiti      = !g +> add_node Exit      lbl_0 "[exit]"      in
1126           let errorexiti = !g +> add_node ErrorExit lbl_0 "[errorexit]" in
1127           let goto_labels = compute_labels_and_create_them st in
1128
1129           let info = { initial_info with
1130             labels_assoc = goto_labels;
1131             exiti      = Some exiti;
1132             errorexiti = Some errorexiti;
1133           }
1134           in
1135
1136           let lasti = aux_statement (Some headeri , info) st in
1137           lasti +> do_option (fun lasti ->
1138             (* todo? if don't have a lasti ? no EndNode ? CTL will work ? *)
1139             let endi = !g +> add_node EndNode lbl_0 "[end]" in
1140             !g#add_arc ((lasti, endi), Direct)
1141           )
1142
1143
1144       | Ast_c.DefineDoWhileZero ((st,_e), ii) ->
1145           let headerdoi =
1146             !g +> add_node (DefineDoWhileZeroHeader ((),ii)) lbl_0 "do0" in
1147           !g#add_arc ((headeri, headerdoi), Direct);
1148           let info = initial_info in
1149           let lasti = aux_statement (Some headerdoi , info) st in
1150           lasti +> do_option (fun lasti ->
1151             let endi = !g +> add_node EndNode lbl_0 "[end]" in
1152             !g#add_arc ((lasti, endi), Direct)
1153           )
1154
1155       | Ast_c.DefineFunction def ->
1156           aux_definition headeri def;
1157
1158       | Ast_c.DefineText (s, ii) ->
1159           raise Todo
1160       | Ast_c.DefineEmpty ->
1161           let endi = !g +> add_node EndNode lbl_0 "[end]" in
1162           !g#add_arc ((headeri, endi),Direct);
1163       | Ast_c.DefineInit _ ->
1164           raise Todo
1165       | Ast_c.DefineTodo ->
1166           raise Todo
1167       );
1168
1169       Some !g
1170
1171
1172   | _ -> None
1173
1174
1175 (*****************************************************************************)
1176 (* CFG loop annotation *)
1177 (*****************************************************************************)
1178
1179 let annotate_loop_nodes g =
1180   let firsti = Control_flow_c.first_node g in
1181
1182   (* just for opti a little *)
1183   let already = Hashtbl.create 101 in
1184
1185   g +> Ograph_extended.dfs_iter_with_path firsti (fun xi path ->
1186     Hashtbl.add already xi true;
1187     let succ = g#successors xi in
1188     let succ = succ#tolist in
1189     succ +> List.iter (fun (yi,_edge) ->
1190       if Hashtbl.mem already yi && List.mem yi (xi::path)
1191       then
1192         let node = g#nodes#find yi in
1193         let ((node2, nodeinfo), nodestr) = node in
1194         let node' = ((node2, {nodeinfo with is_loop = true}), (nodestr ^ "*"))
1195         in
1196         g#replace_node (yi, node');
1197     );
1198   );
1199
1200
1201   g
1202
1203
1204 (*****************************************************************************)
1205 (* CFG checks *)
1206 (*****************************************************************************)
1207
1208 (* the second phase, deadcode detection. Old code was raising DeadCode if
1209  * lasti = None, but maybe not. In fact if have 2 return in the then
1210  * and else of an if ?
1211  *
1212  * alt: but can assert that at least there exist
1213  * a node to exiti, just check #pred of exiti.
1214  *
1215  * Why so many deadcode in Linux ? Ptet que le label est utilisé
1216  * mais dans le corps d'une macro et donc on le voit pas :(
1217  *
1218  *)
1219 let deadcode_detection g =
1220
1221   g#nodes#iter (fun (k, node) ->
1222     let pred = g#predecessors k in
1223     if pred#null then
1224       (match unwrap node with
1225       (* old:
1226        * | Enter -> ()
1227        * | EndStatement _ -> pr2 "deadcode sur fake node, pas grave";
1228        *)
1229       | TopNode -> ()
1230       | FunHeader _ -> ()
1231       | ErrorExit -> ()
1232       | Exit -> ()     (* if have 'loop: if(x) return; i++; goto loop' *)
1233       | SeqEnd _ -> () (* todo?: certaines '}' deviennent orphelins *)
1234       | x ->
1235           (match Control_flow_c.extract_fullstatement node with
1236           | Some (st, ii) -> raise (Error (DeadCode (Some (pinfo_of_ii ii))))
1237           | _ -> pr2 "CFG: orphelin nodes, maybe something wierd happened"
1238           )
1239       )
1240   )
1241
1242 (*------------------------------------------------------------------------*)
1243 (* special_cfg_braces: the check are really specific to the way we
1244  * have build our control_flow, with the { } in the graph so normally
1245  * all those checks here are useless.
1246  *
1247  * ver1: to better error reporting, to report earlier the message, pass
1248  * the list of '{' (containing morover a brace_identifier) instead of
1249  * just the depth.
1250  *)
1251
1252 let (check_control_flow: cflow -> unit) = fun g ->
1253
1254   let nodes = g#nodes  in
1255   let starti = first_node g in
1256   let visited = ref (new oassocb []) in
1257
1258   let print_trace_error xs =  pr2 "PB with flow:";  Common.pr2_gen xs; in
1259
1260   let rec dfs (nodei, (* Depth depth,*) startbraces,  trace)  =
1261     let trace2 = nodei::trace in
1262     if !visited#haskey nodei
1263     then
1264       (* if loop back, just check that go back to a state where have same depth
1265          number *)
1266       let (*(Depth depth2)*) startbraces2 = !visited#find nodei in
1267       if  (*(depth = depth2)*) startbraces <> startbraces2
1268       then
1269         begin
1270           pr2 (sprintf "PB with flow: the node %d has not same braces count"
1271                  nodei);
1272           print_trace_error trace2
1273         end
1274     else
1275       let children = g#successors nodei in
1276       let _ = visited := !visited#add (nodei, (* Depth depth*) startbraces) in
1277
1278       (* old: good, but detect a missing } too late, only at the end
1279       let newdepth =
1280         (match fst (nodes#find nodei) with
1281         | StartBrace i -> Depth (depth + 1)
1282         | EndBrace i   -> Depth (depth - 1)
1283         | _ -> Depth depth
1284         )
1285       in
1286       *)
1287       let newdepth =
1288         (match unwrap (nodes#find nodei),  startbraces with
1289         | SeqStart (_,i,_), xs  -> i::xs
1290         | SeqEnd (i,_), j::xs ->
1291             if i = j
1292             then xs
1293             else
1294               begin
1295                 pr2 (sprintf ("PB with flow: not corresponding match between }%d and excpeted }%d at node %d") i j nodei);
1296                 print_trace_error trace2;
1297                 xs
1298               end
1299         | SeqEnd (i,_), [] ->
1300             pr2 (sprintf "PB with flow: too much } at }%d " i);
1301             print_trace_error trace2;
1302             []
1303         | _, xs ->  xs
1304         )
1305       in
1306
1307
1308       if children#tolist = []
1309       then
1310         if (* (depth = 0) *) startbraces <> []
1311         then print_trace_error trace2
1312       else
1313         children#tolist +> List.iter (fun (nodei,_) ->
1314           dfs (nodei, newdepth, trace2)
1315         )
1316     in
1317
1318   dfs (starti, (* Depth 0*) [], [])
1319
1320 (*****************************************************************************)
1321 (* Error report *)
1322 (*****************************************************************************)
1323
1324 let report_error error =
1325   let error_from_info info =
1326     Common.error_message_short info.file ("", info.charpos)
1327   in
1328   match error with
1329   | DeadCode          infoopt ->
1330       (match infoopt with
1331       | None ->   pr2 "FLOW: deadcode detected, but cant trace back the place"
1332       | Some info -> pr2 ("FLOW: deadcode detected: " ^ error_from_info info)
1333       )
1334   | CaseNoSwitch      info ->
1335       pr2 ("FLOW: case without corresponding switch: " ^ error_from_info info)
1336   | OnlyBreakInSwitch info ->
1337       pr2 ("FLOW: only break are allowed in switch: " ^ error_from_info info)
1338   | NoEnclosingLoop   (info) ->
1339       pr2 ("FLOW: can't find enclosing loop: " ^ error_from_info info)
1340   | GotoCantFindLabel (s, info) ->
1341       pr2 ("FLOW: cant jump to " ^ s ^ ": because we can't find this label")
1342   | NoExit info ->
1343       pr2 ("FLOW: can't find exit or error exit: " ^ error_from_info info)
1344   | DuplicatedLabel s ->
1345       pr2 ("FLOW: duplicate label" ^ s)
1346   | NestedFunc  ->
1347       pr2 ("FLOW: not handling yet nested function")
1348   | ComputedGoto ->
1349       pr2 ("FLOW: not handling computed goto yet")