parsing_c/control_flow_c_build.ml

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